Merge commit '47f60d0996ed57d3a3c00b25ddbd8fea04096f90' as 'third_party/lisp/quasiquote_2' r/450

8 files changed, 895 insertions, 0 deletions

diff --git a/third_party/lisp/quasiquote_2/README.md b/third_party/lisp/quasiquote_2/README.md
new file mode 100644
index 0000000000..2d590a0564
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/README.md
@@ -0,0 +1,258 @@
+quasiquote-2.0
+==============
+
+Why should it be hard to write macros that write other macros?
+Well, it shouldn't!
+
+quasiquote-2.0 defines slightly different rules for quasiquotation,
+that make writing macro-writing macros very smooth experience.
+
+NOTE: quasiquote-2.0 does horrible things to shared structure!!!
+(it does a lot of COPY-TREE's, so shared-ness is destroyed).
+So, it's indeed a tool to construct code (where it does not matter much if the
+structure is shared or not) and not the data (or, at least, not the data with shared structure)
+
+
+```lisp
+(quasiquote-2.0:enable-quasiquote-2.0)
+
+(defmacro define-my-macro (name args &body body)
+  `(defmacro ,name ,args
+     `(sample-thing-to-expand-to
+        ,,@body))) ; note the difference from usual way
+
+(define-my-macro foo (x y)
+  ,x ; now here injections of quotation constructs work
+  ,y)
+
+(define-my-macro bar (&body body)
+  ,@body) ; splicing is also easy
+```
+
+The "injections" in macros FOO and BAR work as naively expected, as if I had written
+```lisp
+(defmacro foo (x y)
+  `(sample-thing-to-expand-to ,x ,y))
+
+(defmacro bar (&body body)
+  `(sample-thing-to-expand-to ,@body))
+
+(macroexpand-1 '(foo a b))
+
+  '(SAMPLE-THING-TO-EXPAND-TO A B)
+
+(macroexpand-1 '(bar a b c))
+
+  '(SAMPLE-THING-TO-EXPAND-TO A B C)
+```
+
+
+So, how is this effect achieved?
+
+
+DIG, INJECT and SPLICE
+-------------------------
+
+The transformations of backquote occur at macroexpansion-time and not at read-time.
+It is totally possible not to use any special reader syntax, but just
+underlying macros directly!
+
+At the core is a macro DIG, which expands to the code that generates the
+expression according to the rules, which are roughly these:
+  * each DIG increases "depth" by one (hence the name)
+  * each INJECT or SPLICE decreases "depth" by one
+  * if depth is 0, evaluation is turned on
+  * if depth if not zero (even if it's negative!) evaluation is off
+  * SPLICE splices the form, similarly to ordinary `,@`, INJECT simply injects, same as `,`
+
+```lisp
+;; The example using macros, without special reader syntax
+
+(dig ; depth is 1 here
+  (a b
+     (dig ; depth is 2 here
+       ((inject c) ; this inject is not evaluated, because depth is nonzero
+        (inject (d ;depth becomes 1 here again
+                (inject e) ; and this inject is evaluated, because depth becomes zero
+                ))
+        (inject 2 f) ; this inject with level specification is evaluated, because it
+                     ; decreases depth by 2
+        ))))
+
+
+;; the same example using ENABLE-QUASIQUOTE-2.0 syntax is written as
+`(a b `(,c ,(d ,e) ,,f)) ; note double comma acts different than usually
+```
+
+
+The ENABLE-QUASIQUOTE-2.0 macro just installs reader that reads
+`FORM as (DIG FORM), ,FORM as (INJECT FORM) and ,@FORM as (SPLICE FORM).
+You can just as well type DIG's, INJECT's and SPLICE's directly, 
+(in particular, when writing utility functions that generate macro-generating code)
+or roll your own convenient reader syntax (pull requests are welcome).
+
+So, these two lines (with ENABLE-QUASIQUOTE-2.0) read the same
+```lisp
+`(a (,b `,,c) d)
+
+(dig (a ((inject b) (dig (inject 2 c))) d))
+```
+
+You may notice the (INJECT 2 ...) form appearing, which is described below.
+
+
+At "level 1", i.e. when only \` , and ,@ are used, and not, say \`\` ,, ,', ,,@ ,',@
+this behaves exactly as usual quasiquotation.
+
+
+The optional N argument
+--------------
+
+All quasiquote-2.0 operators accept optional "depth" argument,
+which goes before the form for human readability.
+
+Namely, (DIG N FORM) increases depth by N instead of one and
+(INJECT N FORM) decreases depth by N instead of one.
+
+```lisp
+(DIG 2 (INJECT 2 A))
+
+; gives the same result as
+
+(DIG (INJECT A))
+```
+
+
+In fact, with ENABLE-QUASIQUOTE-2.0, say, ,,,,,FORM (5 quotes) reads as (INJECT 5 FORM)
+and ,,,,,@FORM as (SPLICE 5 FORM)
+
+
+More examples
+-------------
+
+For fairly complicated example, which uses ,,,@ and OINJECT (see below),
+ see DEFINE-BINOP-DEFINER macro
+in CG-LLVM (https://github.com/mabragor/cg-llvm/src/basics.lisp),
+desire to write which was the initial impulse for this project.
+
+
+For macro, that is not a macro-writing macro, yet benefits from
+ability to inject using `,` and `,@`, consider JOINING-WITH-COMMA-SPACE macro
+(also from CG-LLVM)
+
+```lisp
+(defmacro joining-with-comma-space (&body body)
+  ;; joinl just joins strings in the list with specified string
+  `(joinl ", " (mapcar #'emit-text-repr
+		       (remove-if-not #'identity  `(,,@body)))))
+
+;; the macro can be then used uniformly over strings and lists of strings
+(defun foo (x y &rest z)
+  (joining-with-comma-space ,x ,y ,@z))
+
+(foo "a" "b" "c" "d")
+  ;; produces
+  "a, b, c, d"
+```
+
+
+ODIG and OINJECT and OSPLICE
+----------------------------
+
+Sometimes you don't want DIG's macroexpansion to look further into the structure of
+some INJECT or SPLICE or DIG in its subform,
+if the depth does not match. In these cases you need "opaque" versions of
+DIG, INJECT and SPLICE, named, respectively, ODIG, OINJECT and OSPLICE.
+
+```lisp
+;; here injection of B would occur
+(defun foo (b)
+  (dig (dig (inject (a (inject b))))))
+
+;; and here not, because macroexpansion does not look into OINJECT form
+(defun bar (b)
+  (dig (dig (oinject (a (inject b))))))
+
+(foo 1)
+
+  '(DIG (INJECT (A 1)))
+
+(bar 1)
+
+  '(DIG (OINJECT (A (INJECT B))))
+```
+
+MACRO-INJECT and MACRO-SPLICE
+-----------------------------
+
+Sometimes you just want to abstract-out some common injection patterns...
+That is, you want macros, that expand into common injection patterns.
+However, you want this only sometimes, and only in special circumstances.
+So it won't do, if INJECT and SPLICE just expanded something, whenever it
+turned out to be macro. For that, use MACRO-INJECT and MACRO-SPLICE.
+
+```lisp
+;; with quasiquote-2.0 syntax turned on
+(defmacro inject-n-times (form n)
+  (make-list n :initial-element `(inject ,form)))
+
+(let (x 0)
+  `(dig (a (macro-inject (inject-n-times (incf x) 3)))))
+;; yields
+'(a (1 2 3))
+
+;;and same with MACRO-SPLICE
+(let (x 0)
+  `(dig (a (macro-splice (inject-n-times (incf x) 3)))))
+;; yields
+'(a 1 2 3)
+```
+
+OMACRO-INJECT and OMACRO-SPLICE are, as usual, opaque variants of MACRO-INJECT and MACRO-SPLICE.
+
+Both MACRO-INJECT and MACRO-SPLICE expand their subform exactly once (using MACROEXPAND-1),
+before plugging it into list.
+If you want to expand as much as it's possible, use MACRO-INJECT-ALL and MACRO-SPLICE-ALL,
+which expand using MACROEXPAND before injecting/splicing, respectively.
+That implies, that while subform of MACRO-INJECT and MACRO-SPLICE is checked to be
+macro-form, the subform of MACRO-INJECT-ALL is not.
+
+
+Terse syntax of the ENABLE-QUASIQUOTE-2.0
+-----------------------------------------
+
+Of course, typing all those MACRO-INJECT-ALL, or OMACRO-SPLICE-ALL or whatever explicitly
+every time you want this special things is kind of clumsy. For that, default reader
+of quasiquote-2.0 provides extended syntax
+
+```lisp
+',,,,!oma@x
+
+;; reads as
+'(OMACRO-SPLICE-ALL 4 X)
+```
+
+That is, the regexp of the syntax is
+[,]+![o][m][a][@]<whatever>
+
+As usual, number of commas determine the anti-depth of the injector, exclamation mark
+turns on the syntax, if `o` is present, opaque version of injector will be used,
+if `m` is present, macro-expanding version of injector will be used and if
+`a` is present, macro-all version of injector will be used.
+
+Note: it's possible to write ,!ax, which will read as (INJECT-ALL X), but
+this will not correspond to the actual macro name.
+
+Note: it was necessary to introduce special escape-char for extended syntax,
+since usual idioms like `,args` would otherwise be completely screwed.
+
+
+TODO
+----
+
+* WITH-QUASIQUOTE-2.0 read-macro-token for local enabling of ` and , overloading
+* wrappers for convenient definition of custom overloading schemes
+* some syntax for opaque operations
+
+P.S. Name "quasiquote-2.0" comes from "patronus 2.0" spell from www.hpmor.com
+     and has nothing to do with being "the 2.0" version of quasiquote.
\ No newline at end of file
diff --git a/third_party/lisp/quasiquote_2/macros.lisp b/third_party/lisp/quasiquote_2/macros.lisp
new file mode 100644
index 0000000000..6ebeb47d08
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/macros.lisp
@@ -0,0 +1,15 @@
+
+(in-package #:quasiquote-2.0)
+
+(defmacro define-dig-like-macro (name)
+  `(defmacro ,name (n-or-form &optional (form nil form-p) &environment env)
+     (if (not form-p)
+	 `(,',name 1 ,n-or-form)
+	 (let ((*env* env))
+	   (transform-dig-form `(,',name ,n-or-form ,form))))))
+
+
+(define-dig-like-macro dig)
+(define-dig-like-macro odig)
+
+
diff --git a/third_party/lisp/quasiquote_2/package.lisp b/third_party/lisp/quasiquote_2/package.lisp
new file mode 100644
index 0000000000..9b140ef84c
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/package.lisp
@@ -0,0 +1,11 @@
+;;;; package.lisp
+
+(defpackage #:quasiquote-2.0
+  (:use #:cl #:iterate)
+  (:export #:%codewalk-dig-form #:transform-dig-form
+	   #:dig #:inject #:splice #:odig #:oinject #:osplice
+	   #:macro-inject #:omacro-inject #:macro-splice #:omacro-splice
+	   #:macro-inject-all #:omacro-inject-all #:macro-splice-all #:omacro-splice-all
+	   #:enable-quasiquote-2.0 #:disable-quasiquote-2.0))
+
+
diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.asd b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd
new file mode 100644
index 0000000000..3acfd32b80
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd
@@ -0,0 +1,30 @@
+;;;; quasiquote-2.0.asd
+
+(defpackage :quasiquote-2.0-system
+  (:use :cl :asdf))
+
+(in-package quasiquote-2.0-system)
+
+(asdf:defsystem #:quasiquote-2.0
+  :serial t
+  :description "Writing macros that write macros. Effortless."
+  :author "Alexandr Popolitov <popolit@gmail.com>"
+  :license "MIT"
+  :version "0.3"
+  :depends-on (#:iterate)
+  :components ((:file "package")
+               (:file "quasiquote-2.0")
+	       (:file "macros")
+	       (:file "readers")))
+
+(defsystem :quasiquote-2.0-tests
+  :description "Tests for QUASIQUOTE-2.0"
+  :licence "MIT"
+  :depends-on (:quasiquote-2.0 :fiveam)
+  :components ((:file "tests")
+	       (:file "tests-macro")
+	       ))
+
+(defmethod perform ((op test-op) (sys (eql (find-system :quasiquote-2.0))))
+  (load-system :quasiquote-2.0)
+  (funcall (intern "RUN-TESTS" :quasiquote-2.0)))
diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp
new file mode 100644
index 0000000000..9ce0425d56
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp
@@ -0,0 +1,340 @@
+;;;; 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)
+
+;; (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)))
+
+(defparameter *void-elt* nil)
+(defparameter *void-filter-needed* nil)
+
+(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
diff --git a/third_party/lisp/quasiquote_2/readers.lisp b/third_party/lisp/quasiquote_2/readers.lisp
new file mode 100644
index 0000000000..7c4c5a30c9
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/readers.lisp
@@ -0,0 +1,77 @@
+
+
+(in-package #:quasiquote-2.0)
+
+(defun read-n-chars (stream char)
+  (let (new-char
+	(n 0))
+    (loop
+       (setf new-char (read-char stream nil :eof t))
+       (if (not (char= new-char char))
+	   (progn (unread-char new-char stream)
+		  (return n))
+	   (incf n)))))
+
+(defmacro define-dig-reader (name symbol)
+  `(defun ,name (stream char)
+     (let ((depth (1+ (read-n-chars stream char))))
+       (if (equal 1 depth)
+	   (list ',symbol (read stream t nil t))
+	   (list ',symbol
+		 depth
+		 (read stream t nil t))))))
+
+(define-dig-reader dig-reader dig)
+(define-dig-reader odig-reader odig)
+
+(defun expect-char (char stream)
+  (let ((new-char (read-char stream t nil t)))
+    (if (char= char new-char)
+	t
+	(unread-char new-char stream))))
+
+(defun guess-injector-name (opaque-p macro-p all-p splicing-p)
+  (intern (concatenate 'string
+		       (if opaque-p "O" "")
+		       (if macro-p "MACRO-" "")
+		       (if splicing-p "SPLICE" "INJECT")
+		       (if all-p "-ALL" ""))
+	  "QUASIQUOTE-2.0"))
+
+(defun inject-reader (stream char)
+  (let ((anti-depth (1+ (read-n-chars stream char)))
+	(extended-syntax (expect-char #\! stream)))
+    (let ((injector-name (if (not extended-syntax)
+			     (guess-injector-name nil nil nil (expect-char #\@ stream))
+			     (guess-injector-name (expect-char #\o stream)
+						  (expect-char #\m stream)
+						  (expect-char #\a stream)
+						  (expect-char #\@ stream)))))
+      `(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth))
+		       ,(read stream t nil t)))))
+
+
+
+(defvar *previous-readtables* nil)
+
+(defun %enable-quasiquote-2.0 ()
+  (push *readtable*
+        *previous-readtables*)
+  (setq *readtable* (copy-readtable))
+  (set-macro-character #\` #'dig-reader)
+  (set-macro-character #\, #'inject-reader)
+  (values))
+
+(defun %disable-quasiquote-2.0 ()
+  (if *previous-readtables*
+      (setf *readtable* (pop *previous-readtables*))
+      (setf *readtable* (copy-readtable nil)))
+  (values))
+
+(defmacro enable-quasiquote-2.0 ()
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%enable-quasiquote-2.0)))
+(defmacro disable-quasiquote-2.0 ()
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%disable-quasiquote-2.0)))
+  
diff --git a/third_party/lisp/quasiquote_2/tests-macro.lisp b/third_party/lisp/quasiquote_2/tests-macro.lisp
new file mode 100644
index 0000000000..df6c43e21d
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/tests-macro.lisp
@@ -0,0 +1,21 @@
+
+(in-package #:quasiquote-2.0-tests)
+
+(in-suite quasiquote-2.0)
+
+(enable-quasiquote-2.0)
+
+(defmacro define-sample-macro (name args &body body)
+  `(defmacro ,name ,args
+     `(sample-thing-to-macroexpand-to
+       ,,@body)))
+
+(define-sample-macro sample-macro-1 (x y)
+  ,x ,y)
+
+(define-sample-macro sample-macro-2 (&body body)
+  ,@body)
+
+(test macro-defined-macroexpansions
+  (is (equal '(sample-thing-to-macroexpand-to a b) (macroexpand-1 '(sample-macro-1 a b))))
+  (is (equal '(sample-thing-to-macroexpand-to a b c) (macroexpand-1 '(sample-macro-2 a b c)))))
\ No newline at end of file
diff --git a/third_party/lisp/quasiquote_2/tests.lisp b/third_party/lisp/quasiquote_2/tests.lisp
new file mode 100644
index 0000000000..6c8ab08cc1
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/tests.lisp
@@ -0,0 +1,143 @@
+(in-package :cl-user)
+
+(defpackage :quasiquote-2.0-tests
+  (:use :cl :quasiquote-2.0 :fiveam)
+  (:export #:run-tests))
+
+(in-package :quasiquote-2.0-tests)
+
+(def-suite quasiquote-2.0)
+(in-suite quasiquote-2.0)
+
+(defun run-tests ()
+  (let ((results (run 'quasiquote-2.0)))
+    (fiveam:explain! results)
+    (unless (fiveam:results-status results)
+      (error "Tests failed."))))
+
+(test basic
+  (is (equal '(nil :just-quote-it!) (multiple-value-list (%codewalk-dig-form '(dig nil)))))
+  (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig (inject a))))))
+  (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig 2 (inject 2 a))))))
+  (is (equal '(((((inject b) c (inject d)) car cdr car) (((inject d)) car cdr cdr cdr car)) nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (a (inject b) c (inject d)))))))
+  (is (equal '(nil nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject d))))))))
+  (is (equal '(((((inject 2 d)) car cdr cdr cdr car cdr car)) nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject 2 d)))))))))
+  
+(test transform
+  (is (equal '(quote a) (transform-dig-form '(dig a))))
+  (is (equal '(quote a) (transform-dig-form '(dig 2 a))))
+  (is (equal 'a (transform-dig-form '(dig (inject a)))))
+  (is (equal 'a (transform-dig-form '(dig 2 (inject 2 a))))))
+
+(defun foo (b d)
+  (dig (a (inject b) c (inject d))))
+
+(defun foo1-transparent (x)
+  (declare (ignorable x))
+  (dig (dig (a (inject (b (inject x) c))))))
+
+(defun foo1-opaque (x)
+  (declare (ignorable x))
+  (dig (dig (a (oinject (b (inject x) c))))))
+
+(defun foo-recursive (x y)
+  (dig (a (inject (list x (dig (c (inject y))))))))
+  
+
+(test foos
+  (is (equal '(a 1 c 2) (foo 1 2)))
+  (is (equal '(a 100 c 200) (foo 100 200))))
+
+(test opaque-vs-transparent
+  (is (equal '(quote a) (transform-dig-form '(odig a))))
+  (is (equal '(quote a) (transform-dig-form '(odig 2 a))))
+  (is (equal 'a (transform-dig-form '(odig (inject a)))))
+  (is (equal 'a (transform-dig-form '(odig 2 (inject 2 a)))))
+  (is (equal '(odig (inject 2 a)) (eval (transform-dig-form '(dig (odig (inject 2 a)))))))
+  (is (equal '(dig (a (inject (b 3 c)))) (foo1-transparent 3)))
+  (is (equal '(dig (a (oinject (b (inject x) c)))) (foo1-opaque 3))))
+
+(test recursive-compile-time
+  (is (equal '(a (1 (c 2))) (foo-recursive 1 2))))
+	     
+
+(test splicing
+  (is (equal '(a b c d) (eval (transform-dig-form '(dig (a (splice '(b c)) d))))))
+  (is (equal '(b c d) (eval (transform-dig-form '(dig ((splice '(b c)) d))))))
+  (is (equal '(a b c) (eval (transform-dig-form '(dig (a (splice '(b c))))))))
+  (is (equal '(a b) (eval (transform-dig-form '(dig (a (splice nil) b))))))
+  (is (equal '(b) (eval (transform-dig-form '(dig ((splice nil) b))))))
+  (is (equal '(a) (eval (transform-dig-form '(dig (a (splice nil)))))))
+  (is (equal '() (eval (transform-dig-form '(dig ((splice nil)))))))
+  (is (equal '(a b) (eval (transform-dig-form '(dig ((splice '(a b)))))))))
+
+
+(test are-they-macro
+  (is (not (equal '(dig (a b)) (macroexpand-1 '(dig (a b))))))
+  (is (not (equal '(odig (a b)) (macroexpand-1 '(odig (a b)))))))
+
+
+(defmacro triple-var (x)
+  `((inject ,x) (inject ,x) (inject ,x)))
+
+(test correct-order-of-effects
+  (is (equal '(a 1 2 3) (let ((x 0))
+			  (dig (a (inject (incf x)) (inject (incf x)) (inject (incf x)))))))
+  (is (equal '(a (((1))) 2)
+	     (let ((x 0))
+	       (dig (a ((((inject (incf x))))) (inject (incf x))))))))
+
+(test macro-injects
+  (is (equal '(a (3 3 3)) (let ((x 3))
+			    (dig (a (macro-inject (triple-var x)))))))
+  (is (equal '(a (1 2 3)) (let ((x 0))
+			    (dig (a (macro-inject (triple-var (incf x))))))))
+  (macrolet ((frob (form n)
+	       (mapcar (lambda (x)
+			 `(inject ,x))
+		       (make-list n :initial-element form)))
+	     (frob1 (form)
+	       `(frob ,form 4)))
+    (is (equal '(a (1 2 3 4 5))
+	       (let ((x 0))
+		 (dig (a (macro-inject (frob (incf x) 5)))))))
+    (is (equal '(a 1 2 3 4 5)
+	       (let ((x 0))
+		 (dig (a (macro-splice (frob (incf x) 5)))))))
+    (is (equal '(a)
+	       (let ((x 0))
+		 (declare (ignorable x))
+		 (dig (a (macro-splice (frob (incf x) 0)))))))
+    (is (equal '(a frob (incf x) 4)
+	       (let ((x 0))
+		 (declare (ignorable x))
+		 (dig (a (macro-splice (frob1 (incf x))))))))
+    (is (equal '(a 1 2 3 4)
+	       (let ((x 0))
+		 (dig (a (macro-splice-all (frob1 (incf x))))))))))
+    
+	       
+(quasiquote-2.0:enable-quasiquote-2.0)
+
+(test reader
+  (is (equal '(inject x) ',x))
+  (is (equal '(inject 3 x) ',,,x))
+  (is (equal '(splice x) ',@x))
+  (is (equal '(splice 3 x) ',,,@x))
+  (is (equal '(omacro-splice-all 4 x) ',,,,!oma@x))
+  (is (equal '(inject 4 oma@x) ',,,,oma@x)))
+
+(test macro-splices
+  (macrolet ((splicer (x)
+	       ``(splice ,x)))
+    (is (equal '(a 1 2 3) (let ((x '(1 2 3)))
+			    `(a ,!m(splicer x)))))))
+
+(test repeated-splices
+  (is (equal '(a) `(a ,@nil ,@nil ,@nil ,@nil)))
+  (is (equal '(a b c d e f g) `(a ,@(list 'b 'c) ,@(list 'd 'e) ,@nil ,@(list 'f 'g)))))
+
+  
\ No newline at end of file