communicating macros

for.lisp

;;;; inter-macro communication example
;;;; shared by pillton in #lisp

(defpackage "EXAMPLE"
  (:use "COMMON-LISP"))
(in-package "EXAMPLE")

(define-symbol-macro %block-vars% nil)
(define-symbol-macro %block-tests% nil)
(define-symbol-macro %results% nil)

(defmacro with-expansion-environment (&body body)
  `(symbol-macrolet ((%block-vars% nil)
                     (%block-tests% nil)
                     (%results% nil))
     ,@body))

(defmacro with-for/do (&body body &environment env)
  (let ((block-vars (macroexpand '%block-vars% env))
        (block-tests (macroexpand '%block-tests% env))
        (results (macroexpand '%results% env)))
    ;; vars is a list of lists of variable bindings.
    ;; tests is a list of expressions for each variable bindings.
    ;; results is a list of result forms.
    `(let* ,(loop
              for var-block in block-vars
              append
                (loop
                   for (var init-form) in var-block
                   collect
                     `(,var ,init-form)))
         (tagbody
          start
            ,@body
          update
            ,@(loop
                 for var-block in block-vars
                 for test in block-tests
                 append
                   (append (loop
                              for exp in var-block
                              for step? = (= 3 (length exp))
                              when step?
                              collect
                                `(setf ,(first exp) ,(third exp)))
                           (list `(when ,test
                                    (go end)))))
            (go start)
          end)
         (values ,@results))))

(defmacro with-do-primitive (varlist endlist &body body &environment env)
  (destructuring-bind (test &rest results) endlist
    `(symbol-macrolet ((%block-vars% ,(append (macroexpand '%block-vars% env)
                                               (list varlist)))
                       (%block-tests% ,(append (macroexpand '%block-tests% env)
                                                (list test)))
                       (%results% ,(append (macroexpand '%results% env)
                                           results)))
       ,@body)))

(defmacro with-clause ((binding (name &rest args)) &body body)
  `(,name (,binding ,@args) ,@body))

(defmacro for (bindings &body body)
  `(with-expansion-environment
     ,(reduce #'(lambda (binding binding-body)
                  (destructuring-bind (var clause) binding
                    `(with-clause (,var ,clause)
                       ,binding-body)))
              bindings
              :from-end t
              :initial-value `(with-for/do
                                 ,@body))))

(defmacro from ((var start below) &body body)
  (let ((start-var (gensym "START"))
        (below-var (gensym "BELOW")))
    `(let ((,below-var ,below)
           (,start-var ,start))
       (with-do-primitive ((,var ,start-var (1+ ,var)))
                          ((>= ,var ,below-var))
         ,@body))))

(defmacro collecting ((var form) &body body)
  (let ((tail-var (gensym "TAIL")))
    `(with-do-primitive ((,var (list ,form))
                         (,tail-var ,var (setf (cdr ,tail-var) (list ,form))))
                        (nil ,var)
       ,@body)))

(defmacro modifying-vector ((var form) &body body)
  (let ((object (gensym "OBJECT"))
        (index (gensym "INDEX"))
        (length (gensym "LENGTH")))
    `(let* ((,object ,form)
            (,length (array-total-size ,object)))
       (with-do-primitive ((,index 0 (1+ ,index)))
                          ((>= ,index ,length))
         (symbol-macrolet ((,var (aref ,object ,index)))
           ,@body)))))


#|

(defun test ()
  (let ((a (make-array 10)))
    (for ((i (from 0 10))
          (items (collecting (+ i 10)))
          (a-i (modifying-vector a)))
      (setf a-i i)
      (print items))
    (terpri)
    (write a :array t)
    (terpri)))

|#