Newer
Older
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; fare-matcher friendly implementation of Quasiquote
;;; Copyright (c) 2002-2011 Fahree Reedaw <fare@tunes.org>
Francois-Rene Rideau
committed
;;; See README.quasiquote
#+xcvb (module (:depends-on ("packages" "matcher")))
(in-package :fare-quasiquote)
Francois-Rene Rideau
committed
(declaim (optimize (speed 1) (safety 3) (debug 3)))
(eval-when (:compile-toplevel :load-toplevel :execute)
Francois-Rene Rideau
committed
;;;; uncomment some of the lines below to disable according simplifications:
;;(pushnew :quasiquote-quotes-literals *features*)
;;(pushnew :quasiquote-at-macro-expansion-time *features*)
Francois-Rene Rideau
committed
;; the below instruction enables pattern-matching for the simplifier.
(copy-function-matcher
list cl:list
list* cl:list*
cons cl:cons
quote cl:quote
vector cl:vector)
(defvar *quasiquote-tokens*
'(unquote unquote-splicing unquote-splicing
list list* append nconc cons vector n-vector knil))
(make-single-arg-form quote kwote)
(make-single-arg-form quasiquote)
(make-single-arg-form unquote)
(make-single-arg-form unquote-splicing)
Francois-Rene Rideau
committed
(make-single-arg-form unquote-nsplicing)
(defun make-vector-form (&rest x) (list* 'vector x))
(defun vector-form-p (x)
Francois-Rene Rideau
committed
(and (listp x) #|(alexandria:proper-list-p x)|# (eq (car x) 'vector)))
(defmacro quote (x) (list 'cl:quote x))
(defmacro quasiquote (x) (quasiquote-expand x))
(defmacro unquote (x)
(declare (ignore x))
(error "unquote only allowed within quasiquote"))
(defmacro unquote-splicing (x)
(declare (ignore x))
(error "unquote-splicing disallowed outside quasiquote"))
Francois-Rene Rideau
committed
(defmacro unquote-nsplicing (x)
(declare (ignore x))
(error "unquote-nsplicing disallowed outside quasiquote"))
(define-symbol-matcher knil
'#'(lambda (form)
(or (null form)
(and (quotep form) (null (single-arg form)))
(m%fail))))
(defparameter knil
#+quasiquote-quotes-literals (kwote nil)
#-quasiquote-quotes-literals nil)
(defparameter *quasiquote-level* 0
"current depth of quasiquote nesting")
Francois-Rene Rideau
committed
(defparameter *simplify* t
"should we simplify backquoted expressions")
Francois-Rene Rideau
committed
(defun unquote-xsplicing-p (x)
(or (unquote-splicing-p x) (unquote-nsplicing-p x)))
Francois-Rene Rideau
committed
(defun quasiquote-expand (x)
(let ((*quasiquote-level* 0))
(multiple-value-bind (top arg)
(quasiquote-expand-0 x)
(when (eq top 'unquote-splicing)
(error ",@ after backquote in ~S" x))
(when (eq top 'unquote-nsplicing)
(error ",. after backquote in ~S" x))
(quasiquote-expand-1 top arg))))
(defun quasiquote-expand-0 (x)
"Given an expression x under a backquote, return two values:
1- a token identifying a topmost function to apply on
2- an argument
When combining backquoted expressions, tokens are used for simplifications."
(cond
Francois-Rene Rideau
committed
((null x)
(values nil nil))
((literalp x)
(values #+quasiquote-quotes-literals 'quote #-quasiquote-quotes-literals :literal x))
((or (symbolp x) (quotep x))
(values 'quote x))
((unquote-splicing-p x)
(values 'unquote-splicing (single-arg x)))
((unquote-nsplicing-p x)
(values 'unquote-nsplicing (single-arg x)))
((unquotep x)
(values 'unquote (single-arg x)))
((vector-form-p x)
(multiple-value-bind (top contents) (quasiquote-expand-0 (cdr x))
(values 'vector (quasiquote-expand-1 top contents))))
;;#+quasiquote-at-macro-expansion-time
((simple-vector-p x)
Francois-Rene Rideau
committed
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
(values 'vector (quasiquote-expand (coerce x 'cl:list))))
((quasiquotep x)
;; shouldn't be happening unless #+quasiquote-at-macro-expansion-time
(quasiquote-expand-0 (quasiquote-expand (single-arg x))))
((consp x)
(multiple-value-bind (atop a) (quasiquote-expand-0 (car x))
(multiple-value-bind (dtop d) (quasiquote-expand-0 (cdr x))
(when (eq dtop 'unquote-splicing)
(error ",@ after dot"))
(when (eq dtop 'unquote-nsplicing)
(error ",. after dot"))
(cond
((eq atop 'unquote-splicing)
(if (null dtop)
(if (unquote-xsplicing-p a)
(values 'append (list a))
(expand-unquote a))
(values 'append
(cond ((eq dtop 'append)
(cons a d))
(t (list a (quasiquote-expand-1 dtop d)))))))
((eq atop 'unquote-nsplicing)
(if (null dtop)
(if (unquote-xsplicing-p a)
(values 'nconc (list a))
(expand-unquote a))
(values 'nconc
(cond ((eq dtop 'nconc)
(cons a d))
(t (list a (quasiquote-expand-1 dtop d)))))))
((null dtop)
(if (member atop '(quote :literal nil))
(values 'quote (list a))
(values 'list (list (quasiquote-expand-1 atop a)))))
((member dtop '(quote :literal))
(if (member atop '(quote :literal nil))
(values 'quote (cons a d))
(values 'list* (list (quasiquote-expand-1 atop a)
(quasiquote-expand-1 dtop d)))))
(t (let ((qa (quasiquote-expand-1 atop a)))
(if (member dtop '(list list*))
(values dtop (cons qa d))
(values 'list*
(list qa (quasiquote-expand-1 dtop d))))))))))
(t
(error "unrecognized object in quasiquote"))))
(defun expand-unquote (x)
(cond
Francois-Rene Rideau
committed
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
((null x)
(values nil nil))
((literalp x)
(values :literal x))
((symbolp x)
(values 'unquote x))
((simple-vector-p x) ;; XXX - test this.
(values 'vector (quasiquote-expand (coerce x 'cl:list))))
((not (consp x))
(error "unrecognized object in unquote"))
((and (quotep x)
(not (unquote-xsplicing-p (single-arg x))))
(values 'quote (single-arg x)))
((member (car x) '(append list list* nconc))
(values (car x) (cdr x)))
((eq (car x) 'cons)
(values 'list* (cdr x)))
(t (values 'unquote x))))
(defun quasiquote-expand-1 (top x)
"Given a top token and an expression, give the quasiquoting
of the result of the top operation applied to the expression"
(cond
((member top '(unquote :literal nil))
x)
((eq top 'quote)
(kwote x))
((eq top 'list*)
(cond ((and (null (cddr x))
(not (unquote-xsplicing-p (car x)))
(not (unquote-xsplicing-p (cadr x))))
(k-cons (car x) (cadr x)))
((unquote-xsplicing-p (car (last x)))
(k-append
(apply 'k-list (butlast x))
(car (last x))))
(t
(apply 'k-list* x))))
((eq top 'vector)
(k-vector x))
(t
(cons (ecase top
((list) 'list)
((append) 'append)
((nconc) 'nconc))
x))))
; we want our own tokens, but they must evaluate the usual way.
(defsubst list (&rest r) (apply #'cl:list r))
(defsubst append (&rest r) (apply #'cl:append r))
(defsubst list* (&rest r) (apply #'cl:list* r))
Francois-Rene Rideau
committed
(defsubst nconc (&rest r) (apply #'cl:nconc r))
(defsubst cons (x y) (cl:cons x y))
(defsubst vector (&rest r) (apply #'cl:vector r))
Francois-Rene Rideau
committed
(defsubst make-vector (l) (coerce l 'simple-vector))
(defsubst clobberable (x) x) ;; marks x as being unique and clobberable by nconc
(defun k-vector (l) (list 'make-vector l))
(defun k-list (&rest r) (cons 'list r))
(defun k-append (&rest r) (cons 'append r))
(defun k-list* (&rest r) (cons 'list* r))
(defun k-cons (x y) (list 'cons x y))
(defun insert (x) x)
(defun list-extender (c)
(case c
((cons list*) 'list*)
((list) 'list)
(t (error "not a list constructor ~A" c))))
(defun self-evaluating-p (x)
(or (literalp x)
Francois-Rene Rideau
committed
(not (or (symbolp x) (combinationp x)
#|#+quasiquote-at-macro-expansion-time|# (simple-vector-p x)
))))
(defun constant-form-p (x)
(or #-quasiquote-quotes-literals (self-evaluating-p x)
(quotep x)))
(defun all-constant-forms-p (l)
(every #'constant-form-p l))
(defun unfold-constant-form (x)
(if (quotep x) (single-arg x) x))
(defun unfold-constant-forms (l)
(mapcar #'unfold-constant-form l))
(defun protect-constant-form (x)
(if (self-evaluating-p x) x (kwote x)))
(defun protect-constant-forms (l)
(mapcar #'protect-constant-form l))
Francois-Rene Rideau
committed
(define-macro-matcher quasiquote
#'(lambda (x) (pattern-matcher (quasiquote-expand x))))
Francois-Rene Rideau
committed
;; Note: it would be a *very bad* idea to use quasiquote:quote
;; in the expansion of the macro-character #\'
Francois-Rene Rideau
committed
(defun call-with-quasiquote-reader (thunk)
(let ((*quasiquote-level* (1+ *quasiquote-level*)))
(make-quasiquote (funcall thunk))))
Francois-Rene Rideau
committed
(defun call-with-unquote-reader (thunk)
(let ((*quasiquote-level* (1- *quasiquote-level*)))
(unless (>= *quasiquote-level* 0) (error "unquote outside quasiquote"))
(make-unquote (funcall thunk))))
(defun call-with-unquote-splicing-reader (thunk)
(let ((*quasiquote-level* (1- *quasiquote-level*)))
(unless (>= *quasiquote-level* 0) (error "unquote-splicing outside quasiquote"))
(make-unquote-splicing (funcall thunk))))
(defun call-with-unquote-nsplicing-reader (thunk)
(let ((*quasiquote-level* (1- *quasiquote-level*)))
(unless (>= *quasiquote-level* 0) (error "unquote-nsplicing outside quasiquote"))
(make-unquote-nsplicing (funcall thunk))))
(defun read-quasiquote (stream)
Francois-Rene Rideau
committed
(call-with-quasiquote-reader (lambda () (read stream t nil t))))
(defun read-unquote (stream)
Francois-Rene Rideau
committed
(call-with-unquote-reader (lambda () (read stream t nil t))))
(defun read-unquote-splicing (stream)
Francois-Rene Rideau
committed
(call-with-unquote-splicing-reader (lambda () (read stream t nil t))))
(defun read-unquote-nsplicing (stream)
(call-with-unquote-nsplicing-reader (lambda () (read stream t nil t))))
(defun n-vector (n contents)
Francois-Rene Rideau
committed
(if (null n) (coerce contents 'simple-vector)
(let ((a (make-array n :element-type t)))
(when (and (null contents) (> n 0))
(error "non-zero length vector with empty contents"))
(loop for i below n with x
do (unless (null contents) (setq x (pop contents)))
do (setf (aref a i) x))
(when contents
(error "provided contents larger than declared vector length"))
a)))
(defun read-vector (stream n)
Francois-Rene Rideau
committed
;; http://www.lisp.org/HyperSpec/Body/sec_2-4-8-3.html
(let ((contents (read-delimited-list #\) stream t)))
(if (> *quasiquote-level* 0)
(make-unquote (list 'n-vector n (quasiquote-expand contents)))
(n-vector n contents))))
(defun read-read-time-backquote (stream char)
(declare (ignore char))
(values (macroexpand-1 (read-quasiquote stream))))
(defun read-macroexpand-time-backquote (stream char)
(declare (ignore char))
(read-quasiquote stream))
(defun read-backquote (stream char)
#-quasiquote-at-macro-expansion-time (read-read-time-backquote stream char)
#+quasiquote-at-macro-expansion-time (read-macroexpand-time-backquote stream char))
(defun backquote-reader (expansion-time)
Francois-Rene Rideau
committed
(ecase expansion-time
((read) #'read-read-time-backquote)
((macroexpand) #'read-macroexpand-time-backquote)
((nil) #'read-backquote)))
(defun read-comma (stream char)
(declare (ignore char))
(case (peek-char nil stream t nil t)
((#\@)
(read-char stream t nil t)
(read-unquote-splicing stream))
((#\.)
(read-char stream t nil t)
(read-unquote-nsplicing stream))
(otherwise (read-unquote stream))))
(defun read-hash-paren (stream subchar arg)
(declare (ignore subchar))
(read-vector stream arg))
(defun enable-quasiquote (&key expansion-time (readtable *readtable*))
(set-macro-character #\` (backquote-reader expansion-time) nil readtable)
(set-macro-character #\, #'read-comma nil readtable)
Francois-Rene Rideau
committed
(when (eq expansion-time 'read)
(set-dispatch-macro-character #\# #\( #'read-hash-paren readtable))
Francois-Rene Rideau
committed
t)
;;(trace quasiquote-expand quasiquote-expand-0 quasiquote-expand-1 expand-unquote)