340 lines
11 KiB
Common Lisp
340 lines
11 KiB
Common Lisp
;;;; quasiquote-2.0.lisp
|
|
|
|
(in-package #:quasiquote-2.0)
|
|
|
|
(defparameter *env* nil)
|
|
|
|
(defmacro nonsense-error (str)
|
|
`(error ,(concatenate 'string
|
|
str
|
|
" appears as a bare, non DIG-enclosed form. "
|
|
"For now I don't know how to make sense of this.")))
|
|
|
|
(defmacro define-nonsense-when-bare (name)
|
|
`(defmacro ,name (n-or-form &optional form)
|
|
(declare (ignore n-or-form form))
|
|
(nonsense-error ,(string name))))
|
|
|
|
(define-nonsense-when-bare inject)
|
|
(define-nonsense-when-bare oinject)
|
|
(define-nonsense-when-bare splice)
|
|
(define-nonsense-when-bare osplice)
|
|
(define-nonsense-when-bare macro-inject)
|
|
|
|
(defparameter *depth* 0)
|
|
|
|
|
|
(defparameter *injectors* nil)
|
|
|
|
(defparameter *void-elt* nil)
|
|
(defparameter *void-filter-needed* nil)
|
|
|
|
;; (defmacro with-injector-parsed (form)
|
|
;; `(let ((kwd (intern (string
|
|
|
|
(defun reset-injectors ()
|
|
(setf *injectors* nil))
|
|
|
|
(defparameter *known-injectors* '(inject splice oinject osplice
|
|
macro-inject omacro-inject
|
|
macro-splice omacro-splice
|
|
macro-inject-all omacro-inject-all
|
|
macro-splice-all omacro-splice-all))
|
|
|
|
(defun injector-form-p (form)
|
|
(and (consp form)
|
|
(find (car form) *known-injectors* :test #'eq)))
|
|
|
|
(defun injector-level (form)
|
|
(if (equal 2 (length form))
|
|
1
|
|
(cadr form)))
|
|
|
|
(defun injector-subform (form)
|
|
(if (equal 2 (length form))
|
|
(values (cdr form) '(cdr))
|
|
(values (cddr form) '(cddr))))
|
|
|
|
(defparameter *opaque-injectors* '(odig oinject osplice omacro-inject))
|
|
|
|
(defun transparent-p (form)
|
|
(not (find (car form) *opaque-injectors* :test #'eq)))
|
|
|
|
(defun look-into-injector (form path)
|
|
(let ((*depth* (- *depth* (injector-level form))))
|
|
(multiple-value-bind (subform subpath) (injector-subform form)
|
|
(search-all-active-sites subform (append subpath path) nil))))
|
|
|
|
(defparameter *known-diggers* '(dig odig))
|
|
|
|
(defun dig-form-p (form)
|
|
(and (consp form)
|
|
(find (car form) *known-diggers* :test #'eq)))
|
|
|
|
(defun look-into-dig (form path)
|
|
(let ((*depth* (+ *depth* (injector-level form))))
|
|
(multiple-value-bind (subform subpath) (injector-subform form)
|
|
(search-all-active-sites subform (append subpath path) nil))))
|
|
|
|
(defun handle-macro-1 (form)
|
|
(if (atom form)
|
|
(error "Sorry, symbol-macros are not implemented for now")
|
|
(let ((fun (macro-function (car form) *env*)))
|
|
(if (not fun)
|
|
(error "The subform of MACRO-1 injector is supposed to be macro, perhaps, something went wrong..."))
|
|
(macroexpand-1 form *env*))))
|
|
|
|
(defun handle-macro-all (form)
|
|
(if (atom form)
|
|
(error "Sorry, symbol-macros are not implemented for now")
|
|
(macroexpand form *env*)))
|
|
|
|
|
|
(defparameter *macro-handlers* `((macro-inject . ,#'handle-macro-1)
|
|
(omacro-inject . ,#'handle-macro-1)
|
|
(macro-splice . ,#'handle-macro-1)
|
|
(omacro-splice . ,#'handle-macro-1)
|
|
(macro-inject-all . ,#'handle-macro-all)
|
|
(omacro-inject-all . ,#'handle-macro-all)
|
|
(macro-splice-all . ,#'handle-macro-all)
|
|
(omacro-splice-all . ,#'handle-macro-all)))
|
|
|
|
(defun get-macro-handler (sym)
|
|
(or (cdr (assoc sym *macro-handlers*))
|
|
(error "Don't know how to handle this macro injector: ~a" sym)))
|
|
|
|
|
|
|
|
(defun macroexpand-macroinjector (place)
|
|
(if (not (splicing-injector (car place)))
|
|
(progn (setf (car place) (funcall (get-macro-handler (caar place))
|
|
(car (injector-subform (car place)))))
|
|
nil)
|
|
(let ((new-forms (funcall (get-macro-handler (caar place))
|
|
(car (injector-subform (car place))))))
|
|
(cond ((not new-forms)
|
|
(setf *void-filter-needed* t
|
|
(car place) *void-elt*))
|
|
((atom new-forms) (error "We need to splice the macroexpansion, but got atom: ~a" new-forms))
|
|
(t (setf (car place) (car new-forms))
|
|
(let ((tail (cdr place)))
|
|
(setf (cdr place) (cdr new-forms)
|
|
(cdr (last new-forms)) tail))))
|
|
t)))
|
|
|
|
|
|
(defun search-all-active-sites (form path toplevel-p)
|
|
;; (format t "SEARCH-ALL-ACTIVE-SITES: got form ~a~%" form)
|
|
(if (not form)
|
|
nil
|
|
(if toplevel-p
|
|
(cond ((atom (car form)) :just-quote-it!)
|
|
((injector-form-p (car form)) (if (equal *depth* (injector-level (car form)))
|
|
:just-form-it!
|
|
(if (transparent-p (car form))
|
|
(look-into-injector (car form) (cons 'car path)))))
|
|
((dig-form-p (car form))
|
|
;; (format t "Got dig form ~a~%" form)
|
|
(if (transparent-p (car form))
|
|
(look-into-dig (car form) (cons 'car path))))
|
|
(t (search-all-active-sites (car form) (cons 'car path) nil)
|
|
(search-all-active-sites (cdr form) (cons 'cdr path) nil)))
|
|
(when (consp form)
|
|
(cond ((dig-form-p (car form))
|
|
;; (format t "Got dig form ~a~%" form)
|
|
(if (transparent-p (car form))
|
|
(look-into-dig (car form) (cons 'car path))))
|
|
((injector-form-p (car form))
|
|
;; (format t "Got injector form ~a ~a ~a~%" form *depth* (injector-level (car form)))
|
|
(if (equal *depth* (injector-level (car form)))
|
|
(if (macro-injector-p (car form))
|
|
(progn (macroexpand-macroinjector form)
|
|
(return-from search-all-active-sites
|
|
(search-all-active-sites form path nil)))
|
|
(progn (push (cons form (cons 'car path)) *injectors*)
|
|
nil))
|
|
(if (transparent-p (car form))
|
|
(look-into-injector (car form) (cons 'car path)))))
|
|
(t (search-all-active-sites (car form) (cons 'car path) nil)))
|
|
(search-all-active-sites (cdr form) (cons 'cdr path) nil)))))
|
|
|
|
|
|
|
|
(defun codewalk-dig-form (form)
|
|
(reset-injectors)
|
|
(let ((it (search-all-active-sites form nil t)))
|
|
(values (nreverse *injectors*) it)))
|
|
|
|
(defun %codewalk-dig-form (form)
|
|
(if (not (dig-form-p form))
|
|
(error "Supposed to be called on dig form")
|
|
(let ((*depth* (+ (injector-level form) *depth*)))
|
|
(codewalk-dig-form (injector-subform form)))))
|
|
|
|
(defun path->setfable (path var)
|
|
(let ((res var))
|
|
;; First element is artifact of extra CAR-ing
|
|
(dolist (spec (cdr (reverse path)))
|
|
(setf res (list spec res)))
|
|
res))
|
|
|
|
(defun tree->cons-code (tree)
|
|
(if (atom tree)
|
|
`(quote ,tree)
|
|
`(cons ,(tree->cons-code (car tree))
|
|
,(tree->cons-code (cdr tree)))))
|
|
|
|
(defparameter *known-splicers* '(splice osplice
|
|
macro-splice omacro-splice
|
|
macro-splice-all omacro-splice-all))
|
|
|
|
(defun splicing-injector (form)
|
|
(and (consp form)
|
|
(find (car form) *known-splicers* :test #'eq)))
|
|
|
|
(defparameter *known-macro-injectors* '(macro-inject omacro-inject
|
|
macro-splice omacro-splice
|
|
macro-inject-all omacro-inject-all
|
|
macro-splice-all omacro-splice-all
|
|
))
|
|
|
|
(defun macro-injector-p (form)
|
|
(and (consp form)
|
|
(find (car form) *known-macro-injectors* :test #'eq)))
|
|
|
|
(defun filter-out-voids (lst void-sym)
|
|
(let (caars cadrs cdars cddrs)
|
|
;; search for all occurences of VOID
|
|
(labels ((rec (x)
|
|
(if (consp x)
|
|
(progn (cond ((consp (car x))
|
|
(cond ((eq void-sym (caar x)) (push x caars))
|
|
((eq void-sym (cdar x)) (push x cdars))))
|
|
((consp (cdr x))
|
|
(cond ((eq void-sym (cadr x)) (push x cadrs))
|
|
((eq void-sym (cddr x)) (push x cddrs)))))
|
|
(rec (car x))
|
|
(rec (cdr x))))))
|
|
(rec lst))
|
|
(if (or cdars cddrs)
|
|
(error "Void sym found on CDR position, which should not have happened"))
|
|
;; destructively transform LST
|
|
(dolist (elt caars)
|
|
(setf (car elt) (cdar elt)))
|
|
(dolist (elt cadrs)
|
|
(setf (cdr elt) (cddr elt)))
|
|
;; check that we indeed filtered-out all VOIDs
|
|
(labels ((rec (x)
|
|
(if (not (atom x))
|
|
(progn (rec (car x))
|
|
(rec (cdr x)))
|
|
(if (eq void-sym x)
|
|
(error "Not all VOIDs were filtered")))))
|
|
(rec lst))
|
|
lst))
|
|
|
|
(defun transform-dig-form (form)
|
|
(let ((the-form (copy-tree form)))
|
|
(let ((*void-filter-needed* nil)
|
|
(*void-elt* (gensym "VOID")))
|
|
(multiple-value-bind (site-paths cmd) (%codewalk-dig-form the-form)
|
|
(cond ((eq cmd :just-quote-it!)
|
|
`(quote ,(car (injector-subform the-form))))
|
|
((eq cmd :just-form-it!)
|
|
(car (injector-subform (car (injector-subform the-form)))))
|
|
(t (let ((cons-code (if (not site-paths)
|
|
(tree->cons-code (car (injector-subform the-form)))
|
|
(really-transform-dig-form the-form site-paths))))
|
|
(if (not *void-filter-needed*)
|
|
cons-code
|
|
`(filter-out-voids ,cons-code ',*void-elt*)))))))))
|
|
|
|
(defmacro make-list-form (o!-n form)
|
|
(let ((g!-n (gensym "N"))
|
|
(g!-i (gensym "I"))
|
|
(g!-res (gensym "RES")))
|
|
`(let ((,g!-n ,o!-n)
|
|
(,g!-res nil))
|
|
(dotimes (,g!-i ,g!-n)
|
|
(push ,form ,g!-res))
|
|
(nreverse ,g!-res))))
|
|
|
|
(defun mk-splicing-injector-let (x)
|
|
`(let ((it ,(car (injector-subform x))))
|
|
(assert (listp it))
|
|
(copy-list it)))
|
|
|
|
|
|
|
|
(defun mk-splicing-injector-setf (path g!-list g!-splicee)
|
|
(assert (eq 'car (car path)))
|
|
(let ((g!-rest (gensym "REST")))
|
|
`(let ((,g!-rest ,(path->setfable (cons 'cdr (cdr path)) g!-list)))
|
|
(assert (or (not ,g!-rest) (consp ,g!-rest)))
|
|
(if (not ,g!-splicee)
|
|
(setf ,(path->setfable (cdr path) g!-list)
|
|
,g!-rest)
|
|
(progn (setf ,(path->setfable (cdr path) g!-list) ,g!-splicee)
|
|
(setf (cdr (last ,g!-splicee)) ,g!-rest))))))
|
|
|
|
|
|
(defun really-transform-dig-form (the-form site-paths)
|
|
(let ((gensyms (make-list-form (length site-paths) (gensym "INJECTEE"))))
|
|
(let ((g!-list (gensym "LIST")))
|
|
(let ((lets nil)
|
|
(splicing-setfs nil)
|
|
(setfs nil))
|
|
(do ((site-path site-paths (cdr site-path))
|
|
(gensym gensyms (cdr gensym)))
|
|
((not site-path))
|
|
(destructuring-bind (site . path) (car site-path)
|
|
(push `(,(car gensym) ,(if (not (splicing-injector (car site)))
|
|
(car (injector-subform (car site)))
|
|
(mk-splicing-injector-let (car site))))
|
|
lets)
|
|
(if (not (splicing-injector (car site)))
|
|
(push `(setf ,(path->setfable path g!-list) ,(car gensym)) setfs)
|
|
(push (mk-splicing-injector-setf path g!-list (car gensym)) splicing-setfs))
|
|
(setf (car site) nil)))
|
|
`(let ,(nreverse lets)
|
|
(let ((,g!-list ,(tree->cons-code (car (injector-subform the-form)))))
|
|
,@(nreverse setfs)
|
|
;; we apply splicing setf in reverse order for them not to bork the paths of each other
|
|
,@splicing-setfs
|
|
,g!-list))))))
|
|
|
|
|
|
;; There are few types of recursive injection that may happen:
|
|
;; * compile-time injection:
|
|
;; (dig (inject (dig (inject a)))) -- this type will be handled automatically by subsequent macroexpansions
|
|
;; * run-time injection:
|
|
;; (dig (dig (inject 2 a)))
|
|
;; and A is '(dig (inject 3 'foo)) -- this one we guard against ? (probably, first we just ignore it
|
|
;; -- do not warn about it, and then it wont really happen.
|
|
;; * macroexpanded compile-time injection:
|
|
;; (dig (inject (my-macro a b c))),
|
|
;; where MY-MACRO expands into, say (splice (list 'a 'b 'c))
|
|
;; This is *not* handled automatically, and therefore we must do it by hand.
|
|
|
|
|
|
;; OK, now how to implement splicing ?
|
|
;; (dig (a (splice (list b c)) d))
|
|
;; should transform into code that yields
|
|
;; (a b c d)
|
|
;; what this code is?
|
|
;; (let ((#:a (copy-list (list b c))))
|
|
;; (let ((#:res (cons 'a nil 'd)))
|
|
;; ;; all non-splicing injects go here, as they do not spoil the path-structure
|
|
;; (setf (cdr #:res) #:a)
|
|
;; (setf (cdr (last #:a)) (cdr (cdr #:res)))
|
|
;; #:res)))
|
|
|
|
|
|
;; How this macroexpansion should work in general?
|
|
;; * We go over the cons-tree, keeping track of the depth level, which is
|
|
;; controlled by DIG's
|
|
;; * Once we find the INJECT with matching level, we remember the place, where
|
|
;; this happens
|
|
;; * We have two special cases:
|
|
;; * cons-tree is an atom
|
|
;; * cons-tree is just a single INJECT
|