mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Vincent Ambo 2020-01-22 21:38:16 +00:00
commit ce989529ba
8 changed files with 895 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

258
third_party/lisp/quasiquote_2/README.md vendored Normal file
View file

@ -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.

15
third_party/lisp/quasiquote_2/macros.lisp vendored Normal file
View file

@ -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)

11
third_party/lisp/quasiquote_2/package.lisp vendored Normal file
View file

@ -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))

30
third_party/lisp/quasiquote_2/quasiquote-2.0.asd vendored Normal file
View file

@ -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)))

340
third_party/lisp/quasiquote_2/quasiquote-2.0.lisp vendored Normal file
View file

@ -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

77
third_party/lisp/quasiquote_2/readers.lisp vendored Normal file
View file

@ -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)))

21
third_party/lisp/quasiquote_2/tests-macro.lisp vendored Normal file
View file

@ -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)))))

143
third_party/lisp/quasiquote_2/tests.lisp vendored Normal file
View file

@ -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)))))