statement-abstractor.lisp

(defvar *registry* (make-hash-table))

(defmacro define-statement-abstractor ((name &rest parameters) &body definitions)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf (gethash ',name *registry*)
           (list ',parameters
                 ',(cdr (assoc :rules definitions))
                 ',(cdr (or (assoc :whole definitions)
                            '(:whole (expr) expr)))))))

(defun statement-folder (rules)
  (lambda (stmt rest)
    (let ((m/sym (gensym)) else)
      (destructuring-bind (parameters body)
          (cdr (or (and (listp stmt)
                        (assoc (car stmt) rules))
                   (setq else (assoc :else rules))))
        `(macrolet
             ((,m/sym ,parameters ,body))
           (,m/sym ,(if (or else (not (listp stmt)))
                        stmt
                        (cdr stmt))
                   ,rest))))))

(defmacro statements-of ((name &rest arguments) &body statements)
  (let ((m/sym (gensym)))
    (destructuring-bind (parameters rules (whole-args whole-body))
        (gethash name *registry*)
      `(let ,(mapcar #'list parameters arguments)
         (macrolet ((,m/sym ,whole-args ,whole-body))
           (,m/sym ,(reduce (statement-folder rules) statements
                            :initial-value nil
                            :from-end t)))))))