tvl-depot/third_party/lisp/quasiquote_2/quasiquote-2.0.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