├── version.text ├── fare-quasiquote-optima.asd ├── fare-quasiquote-readtable.asd ├── fare-quasiquote-extras.asd ├── fare-quasiquote-test.asd ├── fare-quasiquote.asd ├── quasiquote-readtable.lisp ├── packages.lisp ├── pp-quasiquote.lisp ├── quasiquote.lisp ├── README.md └── quasiquote-test.lisp /version.text: -------------------------------------------------------------------------------- 1 | 1.0.1 2 | -------------------------------------------------------------------------------- /fare-quasiquote-optima.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | #-asdf3 (error "fare-quasiquote requires ASDF 3") 3 | 4 | (defsystem "fare-quasiquote-optima" 5 | :description "fare-quasiquote extension for optima" 6 | :version (:read-file-line "version.text") 7 | :license "MIT" 8 | :author "Francois-Rene Rideau" 9 | :depends-on ("trivia.quasiquote")) 10 | -------------------------------------------------------------------------------- /fare-quasiquote-readtable.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | #-asdf3 (error "fare-quasiquote requires ASDF 3") 3 | 4 | (defsystem "fare-quasiquote-readtable" 5 | :description "Using fare-quasiquote with named-readtable" 6 | :version (:read-file-line "version.text") 7 | :license "MIT" 8 | :author "Francois-Rene Rideau" 9 | :depends-on ("named-readtables" "fare-quasiquote") 10 | :components ((:file "quasiquote-readtable"))) 11 | -------------------------------------------------------------------------------- /fare-quasiquote-extras.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | #-asdf3 (error "fare-quasiquote requires ASDF 3") 3 | 4 | (defsystem "fare-quasiquote-extras" 5 | :description "fare-quasiquote plus extras" 6 | :version (:read-file-line "version.text") 7 | :license "MIT" 8 | :author "Francois-Rene Rideau" 9 | ;; NB: not including deprecated fare-matcher anymore 10 | :depends-on ("fare-quasiquote-optima" "fare-quasiquote-readtable")) 11 | -------------------------------------------------------------------------------- /fare-quasiquote-test.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | 3 | (defsystem "fare-quasiquote-test" 4 | :description "Tests for fare-quasiquote" 5 | :version (:read-file-line "version.text") 6 | :license "MIT" 7 | :author "Francois-Rene Rideau" 8 | :depends-on ("fare-quasiquote-extras" "hu.dwim.stefil") 9 | :components ((:file "quasiquote-test")) 10 | :perform (test-op (o c) 11 | (format! t "~&Testing fare-quasiquote") 12 | (symbol-call :fare-quasiquote/test :fare-quasiquote-test))) 13 | -------------------------------------------------------------------------------- /fare-quasiquote.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Lisp -*- 2 | #-asdf3 (error "fare-quasiquote requires ASDF 3") 3 | 4 | (defsystem "fare-quasiquote" 5 | :description "Portable, matchable implementation of quasiquote" 6 | :long-description "fare-quasiquote implements 7 | a portable quasiquote that you can control." 8 | :license "MIT" 9 | :author "Francois-Rene Rideau" 10 | :version (:read-file-line "version.text") 11 | :depends-on ((:version "fare-utils" "1.0.0")) 12 | :components 13 | ((:file "packages") 14 | (:file "quasiquote" :depends-on ("packages")) 15 | (:file "pp-quasiquote" :depends-on ("quasiquote"))) 16 | :in-order-to ((test-op (test-op "fare-quasiquote-test")))) 17 | -------------------------------------------------------------------------------- /quasiquote-readtable.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- 2 | ;;; named-readtables support for fare-quasiquote 3 | ;;; Copyright (c) 2011-2014 Fahree Wreido 4 | ;;; See README 5 | 6 | #+xcvb (module (:depends-on ("quasiquote" (:asdf "named-readtables")))) 7 | 8 | (in-package :fare-quasiquote) 9 | 10 | (eval-now 11 | (named-readtables:defreadtable :fare-quasiquote-mixin 12 | (:macro-char #\` #'read-read-time-backquote) 13 | (:macro-char #\, #'read-comma) 14 | (:macro-char #\# :dispatch) 15 | (:dispatch-macro-char #\# #\( #'read-hash-paren) 16 | (:dispatch-macro-char #\# #\. #'read-hash-dot)) 17 | (named-readtables:defreadtable :fare-quasiquote 18 | (:fuze :standard :fare-quasiquote-mixin))) 19 | 20 | #| ;; To use it: 21 | 22 | (named-readtables:in-readtable :fare-quasiquote) 23 | 24 | |# 25 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module ()) 2 | 3 | (in-package #:cl) 4 | 5 | (defpackage #:fare-quasiquote 6 | (:use #:uiop #:fare-utils #:common-lisp) 7 | (:shadow #:list #:list* #:cons #:append #:nconc #:quote) 8 | (:shadow #:kwote #:quotep #:n-vector #:make-vector) 9 | (:documentation 10 | "Quasiquote implementation with and for pattern-matching") 11 | (:export #:quasiquote-expand #:quasiquote #:unquote #:unquote-splicing 12 | #:enable-quasiquote #:*fq-readtable* 13 | #:enable-qq-pp #:*fq-pprint-dispatch* 14 | #:call-with-quasiquote-reader 15 | #:call-with-unquote-reader 16 | #:call-with-unquote-splicing-reader 17 | #:call-with-unquote-nsplicing-reader)) 18 | 19 | (uiop:define-package #:fare-quasiquote-extras 20 | (:documentation "Package for package inferred systems to depend on.") 21 | (:use-reexport #:fare-quasiquote)) 22 | -------------------------------------------------------------------------------- /pp-quasiquote.lisp: -------------------------------------------------------------------------------- 1 | ;;;; pretty-printing of backquote expansions 2 | 3 | #+xcvb (module (:depends-on ("quasiquote"))) 4 | 5 | ;;;; This software is originally derived from the CMU CL system via SBCL. 6 | ;;;; CMU CL was written at Carnegie Mellon University and released into 7 | ;;;; the public domain. The software is in the public domain and is 8 | ;;;; provided with absolutely no warranty. 9 | 10 | (in-package :fare-quasiquote) 11 | 12 | (defun pprint-starts-with-dot-or-at-p (form) 13 | (and 14 | (symbolp form) 15 | (let ((output (with-output-to-string (s) 16 | (write form :stream s 17 | :level (min 1 (or *print-level* 1)) 18 | :length (min 1 (or *print-length* 1)))))) 19 | (and (plusp (length output)) 20 | (or (char= (char output 0) #\.) 21 | (char= (char output 0) #\@)))))) 22 | 23 | (defstruct (x-unquote (:constructor make-x-unquote)) form) ;; represent the escape 24 | (defmethod print-object ((x x-unquote) stream) 25 | (princ ". " stream) (write (make-unquote (x-unquote-form x)) :stream stream)) 26 | 27 | (defstruct (x-n-vector (:constructor make-x-n-vector)) n contents) ;; represent the escape 28 | (defmethod print-object ((x x-n-vector) stream) 29 | (write-char #\# stream) 30 | (when (x-n-vector-n x) (write (x-n-vector-n x) :stream stream)) 31 | (let* ((c (x-n-vector-contents x)) 32 | (u (if (quasiquote-form-p c) 33 | (quasiquote-unexpand c) 34 | (list (make-unquote-splicing c))))) 35 | (write u :stream stream))) 36 | 37 | (defun quasiquote-unexpand (x) 38 | (assert (quasiquote-form-p x)) 39 | (quasiquote-unexpand-0 (car x) (cdr x))) 40 | 41 | (defun quasiquote-unexpand-last (x) 42 | (quasiquote-unexpand-1 43 | #-quasiquote-strict-append 'unquote-splicing #+quasiquote-strict-append 'x-unquote 44 | (car (last x)))) 45 | 46 | (defun quasiquote-unexpand-0 (top x) 47 | (ecase top 48 | ((quote) 49 | (assert (length=n-p x 1)) 50 | (car x)) 51 | ((make-vector n-vector) 52 | (let ((form (cons top x))) 53 | (assert (valid-k-n-vector-p form)) 54 | (make-x-n-vector :n (k-n-vector-n form) :contents (k-n-vector-contents form)))) 55 | ((list) 56 | (mapcar #'(lambda (el) (quasiquote-unexpand-1 'unquote el)) x)) 57 | ((list* cons) 58 | ;;(apply 'list* (mapcar #'(lambda (el) (quasiquote-unexpand-1 'unquote el)) x)) 59 | (nconc (mapcar #'(lambda (el) (quasiquote-unexpand-1 'unquote el)) (butlast x)) 60 | (quasiquote-unexpand-last x))) 61 | ((append) 62 | (append (apply 'append 63 | (mapcar (lambda (el) (quasiquote-unexpand-1 'unquote-splicing el)) (butlast x))) 64 | (quasiquote-unexpand-last x))) 65 | ((nconc) 66 | (append (apply 'append 67 | (mapcar (lambda (el) (quasiquote-unexpand-1 'unquote-nsplicing el)) (butlast x))) 68 | (quasiquote-unexpand-last x))))) 69 | 70 | (defun quasiquote-unexpand-2 (top form) 71 | (ecase top 72 | ((unquote) 73 | (make-unquote form)) 74 | ((x-unquote) 75 | (list (make-x-unquote :form form))) 76 | ((unquote-splicing) 77 | (list (make-unquote-splicing form))) 78 | ((unquote-nsplicing) 79 | (list (make-unquote-nsplicing form))))) 80 | 81 | (defun quasiquote-unexpand-1 (top x) 82 | (cond 83 | ((literalp x) 84 | (ecase top 85 | ((nil) (kwote x)) 86 | ((unquote x-unquote) x) 87 | ((unquote-splicing unquote-nsplicing) (list x)))) 88 | ((atom x) 89 | (quasiquote-unexpand-2 top x)) 90 | ((not (null (cdr (last x)))) 91 | (error "found illegal dotted quasiquote form: ~S" x)) 92 | ((and (member top '(unquote x-unquote)) 93 | (member (car x) '(list list* cons append nconc quote make-vector n-vector))) 94 | (quasiquote-unexpand x)) 95 | ((and (member top '(unquote-splicing unquote-nsplicing)) 96 | (or (null x) (member (car x) '(list list* cons append nconc quote)))) 97 | (quasiquote-unexpand x)) 98 | (t 99 | (quasiquote-unexpand-2 top x)))) 100 | 101 | (defun pprint-quasiquote (stream form &rest noise) 102 | (declare (ignore noise)) 103 | (princ #\` stream) 104 | (write (quasiquote-unexpand form) :stream stream)) 105 | 106 | 107 | (defun pprint-unquasiquote (stream form &rest noise) 108 | (declare (ignore noise)) 109 | (block nil 110 | (flet ((punt () 111 | ;; Given an invalid form. Instead of erroring out, revert to standard *p-p-d* (ugly). 112 | ;; Unhappily, there is no "call next method" here. 113 | (let ((*print-pprint-dispatch* (with-standard-io-syntax *print-pprint-dispatch*))) 114 | (write form :stream stream) 115 | (return)))) 116 | (cond 117 | ((quasiquotep form) 118 | (write (macroexpand-1 form) :stream stream) 119 | (return)) 120 | ((unquotep form) 121 | (let ((x (second form))) 122 | (when (or (quasiquote-form-p x) (literalp x)) 123 | (write (quasiquote-unexpand x) :stream stream) 124 | (return))) 125 | (write-char #\, stream) 126 | (when (pprint-starts-with-dot-or-at-p (cadr form)) (write-char #\space stream))) 127 | ((unquote-splicing-p form) 128 | (write-string ",@" stream)) 129 | ((unquote-nsplicing-p form) 130 | (write-string ",." stream)) 131 | (t (punt))) 132 | (write (cadr form) :stream stream))) 133 | nil) 134 | 135 | (defun enable-qq-pp (&key (priority 0) (table *print-pprint-dispatch*)) 136 | ;; Printing the read-time forms 137 | (set-pprint-dispatch '(cl:cons (eql list)) 'pprint-quasiquote priority table) 138 | (set-pprint-dispatch '(cl:cons (eql list*)) 'pprint-quasiquote priority table) 139 | (set-pprint-dispatch '(cl:cons (eql cons)) 'pprint-quasiquote priority table) 140 | (set-pprint-dispatch '(cl:cons (eql append)) 'pprint-quasiquote priority table) 141 | (set-pprint-dispatch '(cl:cons (eql nconc)) 'pprint-quasiquote priority table) 142 | (set-pprint-dispatch '(cl:cons (eql make-vector)) 'pprint-quasiquote priority table) 143 | (set-pprint-dispatch '(cl:cons (eql n-vector)) 'pprint-quasiquote priority table) 144 | (set-pprint-dispatch '(cl:cons (eql quote)) 'pprint-quasiquote priority table) 145 | ;; Printing the macro-expansion-time forms 146 | (set-pprint-dispatch '(cl:cons (eql quasiquote)) 'pprint-unquasiquote priority table) 147 | (set-pprint-dispatch '(cl:cons (eql unquote)) 'pprint-unquasiquote priority table) 148 | (set-pprint-dispatch '(cl:cons (eql unquote-splicing)) 'pprint-unquasiquote priority table) 149 | (set-pprint-dispatch '(cl:cons (eql unquote-nsplicing)) 'pprint-unquasiquote priority table) 150 | t) 151 | 152 | (defvar *fq-pprint-dispatch* 153 | (let ((table (copy-pprint-dispatch nil))) 154 | (enable-qq-pp :table table) 155 | table)) 156 | -------------------------------------------------------------------------------- /quasiquote.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- 2 | ;;; pattern-matching friendly implementation of Quasiquote 3 | ;;; Copyright (c) 2002-2014 Fahree Reedaw 4 | ;;; See README 5 | 6 | #+xcvb (module (:depends-on ("packages"))) 7 | 8 | (in-package :fare-quasiquote) 9 | 10 | (declaim (optimize (speed 1) (safety 3) (debug 3))) 11 | 12 | (eval-when (:compile-toplevel :load-toplevel :execute) 13 | ;;;; uncomment some of the lines below to disable according simplifications: 14 | ;;(pushnew :quasiquote-strict-append *features*) 15 | ;;(pushnew :quasiquote-passes-literals *features*) 16 | ;;(pushnew :quasiquote-at-macro-expansion-time *features*) 17 | ) 18 | 19 | (eval-when (:compile-toplevel :load-toplevel :execute) 20 | ;;; Functions that actually build data structures. 21 | ;; Note that we want our own tokens for decompilation reasons, 22 | ;; but as functions they must evaluate the usual way. 23 | (defsubst list (&rest r) r) ;; (apply #'cl:list r) 24 | (defsubst list* (&rest r) (apply #'cl:list* r)) 25 | (defsubst cons (x y) (cl:cons x y)) 26 | (defsubst append (&rest r) (apply #'cl:append r)) 27 | (defsubst nconc (&rest r) (apply #'cl:nconc r)) 28 | ;; These supporting functions don't have a standard name 29 | (defsubst make-vector (l) (coerce l 'simple-vector)) 30 | (defun n-vector (n contents) 31 | (if (null n) (make-vector contents) 32 | (let ((a (make-array n :element-type t))) 33 | (when (and (null contents) (> n 0)) 34 | (error "non-zero length vector with empty contents")) 35 | (loop for i below n with x 36 | do (unless (null contents) (setq x (pop contents))) 37 | do (setf (aref a i) x)) 38 | (when contents 39 | (error "provided contents larger than declared vector length")) 40 | a))) 41 | 42 | ;;; These functions build the forms that build the data structures. 43 | (make-single-arg-form quote kwote) 44 | (make-single-arg-form quasiquote) 45 | (make-single-arg-form unquote) 46 | (make-single-arg-form unquote-splicing) 47 | (make-single-arg-form unquote-nsplicing) 48 | (defun k-list (&rest r) (cons 'list r)) 49 | (defun k-list-p (x) (and (consp x) (eq (car x) 'list))) 50 | (defun k-list* (&rest r) (cons 'list* r)) 51 | (defun k-list*-p (x) (and (consp x) (eq (car x) 'list*))) 52 | (defun k-cons (x y) (list 'cons x y)) 53 | (defun k-cons-p (x) (and (consp x) (eq (car x) 'cons))) 54 | (defun k-append (&rest r) (cons 'append r)) 55 | (defun k-append-p (x) (and (consp x) (eq (car x) 'append))) 56 | (defun k-nconc (&rest r) (cons 'nconc r)) 57 | (defun k-nconc-p (x) (and (consp x) (eq (car x) 'nconc))) 58 | 59 | (defun k-literal (literal) 60 | #+quasiquote-passes-literals literal 61 | #-quasiquote-passes-literals (kwote literal)) 62 | 63 | ;;; These macros expand into suitable forms 64 | (defmacro quote (x) (list 'cl:quote x)) 65 | (defmacro quasiquote (x) (quasiquote-expand x)) 66 | (defmacro unquote (x) 67 | (declare (ignore x)) 68 | (error "unquote only allowed within quasiquote")) 69 | (defmacro unquote-splicing (x) 70 | (declare (ignore x)) 71 | (error "unquote-splicing disallowed outside quasiquote")) 72 | (defmacro unquote-nsplicing (x) 73 | (declare (ignore x)) 74 | (error "unquote-nsplicing disallowed outside quasiquote")) 75 | 76 | (defun quasiquote-form-p (x) 77 | (or (quotep x) (k-list-p x) (k-list*-p x) (k-cons-p x) (k-append-p x) (k-nconc-p x) (k-n-vector-p x))) 78 | 79 | (defun k-n-vector (n l) 80 | (cond 81 | ((null l) 82 | (k-literal (vector))) 83 | ((quotep l) 84 | (k-literal (n-vector n (single-arg l)))) 85 | (n 86 | (list 'n-vector n l)) 87 | (t 88 | (list 'make-vector l)))) 89 | 90 | (defun k-n-vector-p (x) (and (consp x) (member (first x) '(make-vector n-vector)))) 91 | 92 | (defun valid-k-n-vector-p (x) 93 | (or (and (length=n-p x 3) (eq (first x) 'n-vector) 94 | (typep (second x) `(or null (integer 0 ,array-rank-limit))) 95 | #+quasiquote-strict-append 96 | (quasiquote-form-p (third x))) 97 | (and (length=n-p x 2) (eq (first x) 'make-vector) 98 | #+quasiquote-strict-append 99 | (quasiquote-form-p (second x))))) 100 | 101 | (defun k-n-vector-n (x) 102 | (and (valid-k-n-vector-p x) (eq (first x) 'n-vector) (second x))) 103 | 104 | (defun k-n-vector-contents (x) 105 | (and (valid-k-n-vector-p x) 106 | (ecase (first x) ((make-vector) (second x)) ((n-vector) (third x))))) 107 | 108 | (defun properly-ended-list-p (x) 109 | (and (listp x) (null (cdr (last x))))) 110 | 111 | (defparameter *quasiquote-level* 0 112 | "current depth of quasiquote nesting") 113 | 114 | (defun unquote-xsplicing-p (x) 115 | (or (unquote-splicing-p x) (unquote-nsplicing-p x))) 116 | 117 | (defun quasiquote-expand (x) 118 | (let ((*quasiquote-level* 0)) 119 | (multiple-value-bind (top arg) 120 | (quasiquote-expand-0 x) 121 | (when (eq top 'unquote-splicing) 122 | (error ",@ after backquote in ~S" x)) 123 | (when (eq top 'unquote-nsplicing) 124 | (error ",. after backquote in ~S" x)) 125 | (quasiquote-expand-1 top arg)))) 126 | 127 | (defun quasiquote-expand-0 (x) 128 | "Given an expression x under a backquote, return two values: 129 | 1- a token identifying the context: nil quote :literal list list* append nconc 130 | 2- a form 131 | When combining backquoted expressions, tokens are used for simplifications." 132 | (cond 133 | ((null x) 134 | (values nil nil)) 135 | ((literalp x) 136 | (values #+quasiquote-passes-literals :literal #-quasiquote-passes-literals 'quote x)) 137 | ((or (symbolp x) (quotep x)) 138 | (values 'quote x)) 139 | ((unquote-splicing-p x) 140 | (values 'unquote-splicing (single-arg x))) 141 | ((unquote-nsplicing-p x) 142 | (values 'unquote-nsplicing (single-arg x))) 143 | ((unquotep x) 144 | (values 'unquote (single-arg x))) 145 | ((quasiquotep x) 146 | (quasiquote-expand-0 (quasiquote-expand (single-arg x)))) 147 | ((k-n-vector-p x) 148 | (values (car x) (cdr x))) 149 | ((consp x) 150 | (multiple-value-bind (atop a) (quasiquote-expand-0 (car x)) 151 | (multiple-value-bind (dtop d) (quasiquote-expand-0 (cdr x)) 152 | (when (eq dtop 'unquote-splicing) 153 | (error ",@ after dot")) 154 | (when (eq dtop 'unquote-nsplicing) 155 | (error ",. after dot")) 156 | (cond 157 | ((eq atop 'unquote-splicing) 158 | (cond 159 | #-quasiquote-strict-append 160 | ((null dtop) 161 | (if (unquote-xsplicing-p a) 162 | (values 'append (list a)) 163 | (expand-unquote a))) 164 | (t 165 | (values 'append 166 | (cond ((eq dtop 'append) 167 | (cons a d)) 168 | (t (list a (quasiquote-expand-1 dtop d)))))))) 169 | ((eq atop 'unquote-nsplicing) 170 | (cond 171 | #-quasiquote-strict-append 172 | ((null dtop) 173 | (if (unquote-nsplicing-p a) 174 | (values 'nconc (list a)) 175 | (expand-unquote a))) 176 | (t 177 | (values 'nconc 178 | (cond ((eq dtop 'nconc) 179 | (cons a d)) 180 | (t (list a (quasiquote-expand-1 dtop d)))))))) 181 | ((null dtop) 182 | (if (member atop '(quote :literal nil)) 183 | (values 'quote (list a)) 184 | (values 'list (list (quasiquote-expand-1 atop a))))) 185 | ((member dtop '(quote :literal)) 186 | (cond 187 | ((member atop '(quote :literal nil)) 188 | (values 'quote (cons a d))) 189 | ;; This should be done more cautiously. 190 | ;; Can we detect the case "has no (recursive) quasiquote escapes"? 191 | ;; Or is 'quote already that? 192 | #| 193 | ((and (consp d) (null (cdr (last d)))) 194 | (values 'list (list* (quasiquote-expand-1 atop a) 195 | (mapcar 'kwote d)))) |# 196 | (t 197 | (values 'list* (list (quasiquote-expand-1 atop a) 198 | (quasiquote-expand-1 dtop d)))))) 199 | (t (let ((qa (quasiquote-expand-1 atop a))) 200 | (if (member dtop '(list list*)) 201 | (values dtop (cons qa d)) 202 | (values 'list* 203 | (list qa (quasiquote-expand-1 dtop d)))))))))) 204 | (t 205 | (error "unrecognized object in quasiquote")))) 206 | 207 | (defun expand-unquote (x) 208 | (cond 209 | ((null x) 210 | (values nil nil)) 211 | ((literalp x) 212 | (values #+quasiquote-passes-literals :literal #-quasiquote-passes-literals 'quote x)) 213 | ((symbolp x) 214 | (values 'unquote x)) 215 | ((not (consp x)) 216 | (error "unrecognized object in unquote")) 217 | ((and (quotep x) 218 | (not (unquote-xsplicing-p (single-arg x)))) 219 | (values 'quote (single-arg x))) 220 | ((member (car x) '(list list* append nconc)) 221 | (values (car x) (cdr x))) 222 | ((eq (car x) 'cons) 223 | (values 'list* (cdr x))) 224 | (t (values 'unquote x)))) 225 | 226 | (defun quasiquote-expand-1 (top x) 227 | "Given a top token and an expression, give the quasiquoting 228 | of the result of the top operation applied to the expression" 229 | (cond 230 | ((member top '(unquote :literal nil)) 231 | x) 232 | ((eq top 'quote) 233 | (kwote x)) 234 | ((member top '(cons list*)) 235 | (cond 236 | #-quasiquote-strict-append 237 | ((length=n-p x 1) x) 238 | ((let ((last (last x))) 239 | (when (or (null last) (and (consp last) (quotep (car last)) 240 | (properly-ended-list-p (single-arg (car last))))) 241 | (quasiquote-expand-1 'list (append (butlast x) 242 | (mapcar 'kwote (and last (single-arg (car last))))))))) 243 | ((length=n-p x 2) 244 | (apply 'k-cons x)) 245 | ((unquote-xsplicing-p (car (last x))) 246 | (k-append 247 | (quasiquote-expand-1 'list (butlast x)) 248 | (car (last x)))) 249 | (t 250 | (apply 'k-list* x)))) 251 | (t 252 | (cons (ecase top 253 | ((list cons append nconc make-vector n-vector) top)) 254 | x)))) 255 | 256 | ;; Note: it would be a *very bad* idea to use quasiquote:quote 257 | ;; in the expansion of the macro-character #\' 258 | 259 | (defun call-with-quasiquote-reader (thunk) 260 | (let ((*quasiquote-level* (1+ *quasiquote-level*))) 261 | (make-quasiquote (funcall thunk)))) 262 | 263 | (defun call-with-unquote-reader (thunk) 264 | (let ((*quasiquote-level* (1- *quasiquote-level*))) 265 | (unless (>= *quasiquote-level* 0) (error "unquote outside quasiquote")) 266 | (make-unquote (funcall thunk)))) 267 | 268 | (defun call-with-unquote-splicing-reader (thunk) 269 | (let ((*quasiquote-level* (1- *quasiquote-level*))) 270 | (unless (>= *quasiquote-level* 0) (error "unquote-splicing outside quasiquote")) 271 | (make-unquote-splicing (funcall thunk)))) 272 | 273 | (defun call-with-unquote-nsplicing-reader (thunk) 274 | (let ((*quasiquote-level* (1- *quasiquote-level*))) 275 | (unless (>= *quasiquote-level* 0) (error "unquote-nsplicing outside quasiquote")) 276 | (make-unquote-nsplicing (funcall thunk)))) 277 | 278 | (defun read-quasiquote (stream) 279 | (call-with-quasiquote-reader (lambda () (read stream t nil t)))) 280 | 281 | (defun read-unquote (stream) 282 | (call-with-unquote-reader (lambda () (read stream t nil t)))) 283 | 284 | (defun read-unquote-splicing (stream) 285 | (call-with-unquote-splicing-reader (lambda () (read stream t nil t)))) 286 | 287 | (defun read-unquote-nsplicing (stream) 288 | (call-with-unquote-nsplicing-reader (lambda () (read stream t nil t)))) 289 | 290 | (defun read-vector (stream n) 291 | ;; http://www.lisp.org/HyperSpec/Body/sec_2-4-8-3.html 292 | (if (= *quasiquote-level* 0) 293 | (n-vector n (read-delimited-list #\) stream t)) 294 | (make-unquote 295 | (k-n-vector n (quasiquote-expand 296 | (progn (unread-char #\( stream) 297 | (read-preserving-whitespace stream t nil t))))))) 298 | 299 | (defun read-read-time-backquote (stream char) 300 | (declare (ignore char)) 301 | (values (macroexpand-1 (read-quasiquote stream)))) 302 | (defun read-macroexpand-time-backquote (stream char) 303 | (declare (ignore char)) 304 | (read-quasiquote stream)) 305 | (defun read-backquote (stream char) 306 | #-quasiquote-at-macro-expansion-time (read-read-time-backquote stream char) 307 | #+quasiquote-at-macro-expansion-time (read-macroexpand-time-backquote stream char)) 308 | (defun backquote-reader (expansion-time) 309 | (ecase expansion-time 310 | ((read) #'read-read-time-backquote) 311 | ((macroexpand) #'read-macroexpand-time-backquote) 312 | ((nil) #'read-backquote))) 313 | (defun read-comma (stream char) 314 | (declare (ignore char)) 315 | (case (peek-char nil stream t nil t) 316 | ((#\@) 317 | (read-char stream t nil t) 318 | (read-unquote-splicing stream)) 319 | ((#\.) 320 | (read-char stream t nil t) 321 | (read-unquote-nsplicing stream)) 322 | (otherwise (read-unquote stream)))) 323 | (defun read-hash-paren (stream subchar arg) 324 | (declare (ignore subchar)) 325 | (read-vector stream arg)) 326 | 327 | (defvar *hash-dot-reader* (get-dispatch-macro-character #\# #\.)) 328 | 329 | (defun read-hash-dot (stream subchar arg) 330 | (let ((*quasiquote-level* 0)) 331 | (funcall *hash-dot-reader* stream subchar arg))) 332 | 333 | (defun enable-quasiquote (&key expansion-time (table *readtable*)) 334 | ;; Note that it is *NOT* OK to enable-quasiquote in the initial readtable, 335 | ;; as this violates the build contract (see ASDF 3.1 documentation about readtables). 336 | ;; Please only use it in your own private readtable, 337 | ;; and/or use system fare-quasiquote-readtable and use 338 | ;; (named-readtables:in-readtable :fare-quasiquote) 339 | (set-macro-character #\` (backquote-reader expansion-time) nil table) 340 | (set-macro-character #\, #'read-comma nil table) 341 | (set-dispatch-macro-character #\# #\( #'read-hash-paren table) 342 | (set-dispatch-macro-character #\# #\. #'read-hash-dot table) 343 | t) 344 | 345 | (defvar *fq-readtable* (let ((x (copy-readtable nil))) (enable-quasiquote :table x) x)) 346 | 347 | );eval-when 348 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | fare-quasiquote — a pattern-matching friendly implementation of Quasiquote 2 | ========================================================================== 3 | 4 | Copyright ⓒ 2002-2020 Fahree Reedaw 5 | 6 | 7 | Purpose 8 | ------- 9 | 10 | The main purpose of this n+2nd reimplementation of quasiquote, is enable 11 | matching of quasiquoted patterns, using [trivia](https://github.com/guicho271828/trivia). 12 | 13 | Now, developing this implementation was also a challenge in understanding the 14 | ins and outs of quasiquotation, and in exploring the way it interacts with 15 | extended support for constant-building syntactic constructs. And this, at least 16 | to me was as much fun as it was an intellectual challenge. 17 | 18 | 19 | How to use it 20 | ------------- 21 | 22 | The recommended way to use `fare-quasiquote` is to have your `defsystem` 23 | depend on `fare-quasiquote-extras`, and at the start your file, use: 24 | 25 | ``` 26 | (named-readtables:in-readtable :fare-quasiquote) 27 | ``` 28 | 29 | Then you can match expressions using `trivia:match`, such as: 30 | 31 | ``` 32 | (trivia:match '(1 (2 3) 4 5) 33 | (`(a (b ,c) ,@d) (list a b c d))) 34 | 35 | ; => (1 2 3 (4 5)) 36 | ``` 37 | 38 | You can also at the SLIME REPL use: 39 | 40 | ``` 41 | (asdf:load-system "fare-quasiquote-extras") 42 | (named-readtables:in-readtable :fare-quasiquote) 43 | ``` 44 | 45 | However, beware to not leak `fare-quasiquote` into systems you load 46 | that do not `:depends-on ("fare-quasiquote")`; 47 | and so until ASDF is fixed to do that for you (hopefully some day in the ASDF 3.x series), 48 | before you call `(asdf:load-system ...)`, you need to restore 49 | the default `*readtable*` with, e.g.: 50 | 51 | ``` 52 | (named-readtables:in-readtable :standard) 53 | ``` 54 | 55 | 56 | Discussion 57 | ---------- 58 | 59 | The `fare-quasiquote` system is a reimplementation of quasiquote with two 60 | advantages: 61 | 62 | * first it has all the bugs straightened out, including dark corner cases (some 63 | implementations still get the simple ``` ``(foo ,@,@bar)``` wrong); 64 | 65 | * second, it expands into a stable format that allows for pattern matching, by 66 | privileging `list` before `cons` before `list*` before `append` before `nconc` 67 | (and by the way, you should never, ever, use `nconc`). 68 | 69 | When using `trivia.quasiquote`, expressions parsed by `fare-quasiquote` can 70 | be used as pattern matching patterns with `trivia`. 71 | `trivia`'s predecessors [optima](https://github.com/m2ym/optima) and 72 | [fare-matcher](https://cliki.net/fare-matcher) used to be supported, 73 | but both have long been deprecated. 74 | 75 | We recommend you use `named-readtables` to enable at the beginning and end of 76 | your Lisp files, or around their compilation (e.g. using ASDF around-compile 77 | hooks). Note however that it is important not to let such `readtables` leak into 78 | the compilation of files that do not depend on `fare-quasiquote`. 79 | 80 | Note that since pattern matchers like `trivia` do not support 81 | backtracking (unlike say an embedded logic programming language), 82 | they cannot match `append` patterns, and those quasiquote templates that expand into 83 | something using `append` can't be used as patterns to match. This means that the 84 | use of `,@` or `,.` is restricted to the end of a list when used as a pattern. 85 | 86 | `fare-quasiquote` was originally written to work with `fare-matcher`, and legacy 87 | support for `fare-matcher` is available in `fare-quasiquote-matcher`, now 88 | distributed with `fare-matcher` itself. 89 | But `fare-matcher` was deprecated in favor of `optima`, 90 | that that was deprecated in favor of `trivia`. 91 | Use `trivia.quasiquote` to match patterns written using `fare-quasiquote`. 92 | 93 | 94 | References 95 | ---------- 96 | 97 | Essential documents consulted while implementing this file: 98 | 99 | * [Alan Bawden's PEPM 99 paper: Quasiquotation in Lisp](https://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.22.1290) 100 | * [The CLtL2 Appendix C: Backquote](https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node367.html) 101 | * [The CLHS section 2.4.6: Backquote](http://www.lispworks.com/documentation/HyperSpec/Body/02_df.htm) 102 | * [Slate reference manual section 2.6.2 on quoting and unquoting](http://slate.tunes.org/doc/progman/node12.html#SECTION00046200000000000000) 103 | * [Factor handbook on *fried quotations*](https://docs.factorcode.org/content/article-fry.html) 104 | * Common Lisp backquote implementation, written in Common Lisp. (public domain) 105 | Author: Guy L. Steele Jr. Date: 27 December 1985. To be used with 2010 patch 106 | by Alex Plotnick regarding the simplification pass. 107 | * SBCL backquote implementation (derived from CMUCL, used the October 2010 108 | version). 109 | 110 | If you for whatever reason ever feel like reimplementing backquote, you should 111 | probably leverage the many tests in my test file 112 | [quasiquote-test.lisp](quasiquote-test.lisp) --- in addition to my own test 113 | cases, I notably included the tests from SBCL; they include regression tests for 114 | many actual bugs in subtle cases that you might otherwise miss. 115 | 116 | 117 | Read-time vs Macro-expansion-time 118 | --------------------------------- 119 | 120 | In conformance with the CLHS, `fare-quasiquote` expands its patterns at 121 | read-time, at least unless you enable a feature 122 | `#+quasiquote-at-macro-expansion-time`. 123 | 124 | In both cases, `fare-quasiquote` handles unquoting in `#()` and `#n()` syntax by 125 | re-defining the syntax for hash-left-paren as well as for backquote. 126 | 127 | If you enable feature `#+quasiquote-at-macro-expansion-time`, `fare-quasiquote` 128 | will expands its patterns at macro-expansion time, using the same convention as 129 | Scheme, with symbols quasiquote, unquote, unquote-splicing and unquote-nsplicing 130 | defined in package `fare-quasiquote` (but not exported from it). 131 | 132 | 133 | Known Issues 134 | ------------ 135 | 136 | * Either at read-time or at macro-expansion-time, the implementation of 137 | quasiquote is fragile in case the user explicitly uses its internal syntax 138 | marker inside the expression being quasiquoted. Such expressions may lead to 139 | confusion between the body of expressions being quasiquoted and the internal 140 | quasiquote infrastructure. If you use these kinds of tricks, you're on your 141 | own. In `fare-quasiquote`, the syntax markers are the `quasiquote`, `unquote`, 142 | `unquote-splicing` and `unquote-nsplicing` symbols present in the 143 | `fare-quasiquote` package and not exported. Any objects that would be used as 144 | markers instead of these interned symbols would lead to the same "bug" if 145 | somehow used inside quasiquoted expressions; at least, non-interned symbols or 146 | gensyms would allow to avoid this bug in expressions being `read`. The 147 | "perfect" solution would be to use objects `gensym`ed at the moment a given 148 | `quasiquote` is read, and kept in a lexical variable to prevent introspective 149 | cheat by `#.` syntax. Then, after simplifying expressions, we could pass the 150 | read expression through functions that would `subst`itute proper symbols for 151 | the markers, from the `fare-quasiquote` package if pretty-printing is to be 152 | supported, or otherwise from the CL package. Note that this would have to be 153 | interleaved with support for working inside vectors and other syntax. This is 154 | all very tricky and until further notice is left as an exercise to the 155 | intrepid reader. Thus, while the behaviour of our implementation isn't 156 | strictly correct, we don't go through the hassle of modifying it into 157 | something much less readable just for the sake of preventing code that would 158 | deliberately confuse the quasiquote engine. Now, if we imagine that some code 159 | were dynamically generated based on system introspection, that could contain 160 | some of our magic markers, then this code would have to be made safe for 161 | interaction with `quasiquote`; this might (or might not?) require making 162 | `quasiquote` 100% fool-proof. 163 | 164 | * This implementation allows for simplifying quasiquoting of literals and other 165 | self-evaluating objects into the object itself, instead of a `` `(quote ,object)`` 166 | expression, if you enable the `#+quasiquote-passes-literals` feature. This is 167 | the behaviour of the simplifier in CMUCL and SBCL, but some people have 168 | expressed concerns that it might not be strictly allowed in letter or spirit 169 | by the Common Lisp standards, and it can make the pretty-printer trickier. 170 | 171 | * This version works inside simple vectors, so as to support unquoting inside 172 | the `#(...)` syntax as the standard mandates. To do that, it replaces the 173 | hash-left-paren reader-macro as well as the backquote reader-macro. Note that 174 | this does not work in `#1A(...)` syntax. This phenomenon has been documented 175 | before in the [following message](http://groups.google.com/groups?q=author:kaz%40ashi.footprints.net&hl=en&lr=&ie=UTF-8&oe=UTF-8&safe=off&selm=cf333042.0303141409.bbf02e9%40posting.google.com&rnum=4). 176 | 177 | * Interestingly, I haven't seen the following problem stated, to know which is 178 | correct of `` `#5(1 ,@'(2 3))``. In other words, does the read argument to ` 179 | #()` mean something at read-time or at vector-creation-time? Of course, in the 180 | original intended usage, outside of any quasiquoting, read-time and 181 | vector-creation-time are one and the same. But what when quasiquote breaks up 182 | that identity? Our answer is that it means something at vector-creation-time. 183 | 184 | * The CLHS section 2.4.6 says that `(x1 x2 ... xn . atom)` is same as `(append 185 | [x1] [x2] [x3] ... [xn] (quote atom))` --- mind that the atom is preserved. 186 | This means that you can't conformantly simplify `` `(a b ,@c)`` to `` `(a b . 187 | ,c)`` unless you know that `c` is a proper list (if it isn't, that's an 188 | error). Yet, the CLHS itself suggests the simplification, and all 189 | implementations tested agree that a final `(quote nil)` can be elided: 190 | 191 | ``` 192 | for l in sbcl ccl clisp cmucl ecl abcl \ 193 | scl allegro lispworks gcl xcl ; do 194 | cl -l $l -i \ 195 | '(format t "'$l': ~S~%" `(,@`(a b) ,@`c)))' \ 196 | 2>&1 | grep "^$l:" # LW, GCL are verbose 197 | done 198 | ``` 199 | 200 | yet at the same time, SBCL still complains about `` `(,@1)``. 201 | `fare-quasiquote` follows the consensus, unless `#+quasiquote-strict-append` 202 | is enabled. 203 | 204 | * The current implementation of fare-quasiquote tends to simplify away things 205 | like `` `,c`` to `c` and, without `#+quasiquote-strict-append`, also `` 206 | `(,@c)`` to `c`. These simplifications probably need to be somehow prevented 207 | by default. Maybe with various kinds of (identity) wrappers to indicate 208 | quoting-unquoting? 209 | 210 | 211 | Meta Unquote Protocol (not implemented) 212 | --------------------------------------- 213 | 214 | The CLHS specifies that quasiquoting works with simple-vector, but not with 215 | other arrays (multi-dimensional or not simple), and not with arbitrary 216 | structures. However, a fully general quasiquote facility would support 217 | quasiquoting within arbitrary syntax, using a MUP: Meta Unquote Protocol. 218 | 219 | The MUP would allow to extend the quasiquote mechanism with support for new 220 | constant-building syntactic constructs as such constructs are defined. Maybe we 221 | will end up with a full-fledge declarative infrastructure for a 222 | Parser-Preprocessor-Pretty-Printer, like `camlp4` only more declarative. 223 | 224 | The MUP would have an abstract API for arbitrary readers; existing syntax for 225 | vectors would implemented using the MUP. For compliance reasons, further MUP 226 | extensions would be disabled by default, but could be made available with a 227 | suitable function call, e.g. for `#A`, `#S`, `#P`, etc. 228 | 229 | The MUP might also implement tagged (and multiple-valued?) quasiquotes, unquotes 230 | and quotes. 231 | 232 | Note that copying and modifying read-tables is expensive, that dynamically 233 | modifying and restoring read-tables might interfere with `#.` syntax, and that 234 | caching modified read-tables will interfere with any subsequent modification of 235 | a cached read-table, comparison not being possible. This means that if we wanted 236 | the MUP to adapt to existing extensions without modifying existing code, we 237 | would have to intercept the definition of syntax reading functions before they 238 | are fed to either `set-macro-character` or `set-dispatch-macro-character`, or 239 | intercept the entire reader protocol. Spooky. Now, this also requires that the 240 | current depth of quasiquoting be consulted any time any of the MUP-enabled 241 | constructors is read. 242 | 243 | The principle of the MUP is that: 244 | 245 | * structure readers that don't want to support unquote MUST be wrapped into 246 | something that dynamically binds `*quasiquote-level*` to 0. 247 | 248 | * structure readers `#c(args)` that do want to support unquote MUST accumulate 249 | formal arguments to a structure constructor into a list `args`, then, if 250 | `*quasiquote-level*` is 0, behave like ``#.(apply `c `args)`` otherwise, 251 | behave like `` `,(apply `c `args)`` where `c` is the name of the constructor 252 | for given structure, and `args` is whichever arguments have been deduced from 253 | the syntax, which may include as many levels of unquotations as 254 | `*quasiquote-level*` says. Note that in a strong sense, `#.` is like `,` 255 | assuming an infinite tower of read-time evaluators à la 3-LISP. 256 | 257 | Note that the above is obscured because we're trying to discuss the behaviour of 258 | quasiquote-containing programs without having a meta-level quasiquoting facility 259 | that could distinguish between what is constant or variable at the meta-level 260 | independently from what is constant or variable at the base level: `c` and 261 | `args` would be better specified through a special meta-level unquotation, the 262 | above expressions being in a corresponding special quasiquotation. A feature 263 | that would allow for clear separation of levels of meta-language would be a 264 | tagged quasiquote feature, as in [Slate](http://slate-language.org/). 265 | 266 | The idea of making circular data-structures work within quasiquotation makes my 267 | head ache with overarching pain. You're crazier than I am if you do it and do it 268 | right. 269 | 270 | PS: If you're able to follow this discussion, you impress me. Come join the 271 | TUNES project! 272 | -------------------------------------------------------------------------------- /quasiquote-test.lisp: -------------------------------------------------------------------------------- 1 | #+xcvb (module (:depends-on ("packages"))) 2 | 3 | (uiop:define-package :fare-quasiquote/test 4 | (:mix :fare-quasiquote :hu.dwim.stefil :common-lisp :optima :optima.extra) 5 | (:shadowing-import-from :fare-quasiquote 6 | #:quasiquote #:unquote #:unquote-splicing #:unquote-nsplicing 7 | #:list #:append #:nconc #:list* #:cons #:quote #:vector 8 | #:kwote #:quotep #:n-vector #:make-vector 9 | #:quasiquote-expand #:quasiquote-expand-0 #:quasiquote-expand-1 #:expand-unquote 10 | #:quasiquote-unexpand #:quasiquote-unexpand-0 #:quasiquote-unexpand-1 #:quasiquote-unexpand-2)) 11 | 12 | (in-package :fare-quasiquote/test) 13 | 14 | (defsuite* (fare-quasiquote-test :in root-suite :documentation "All fare-quasiquote tests")) 15 | 16 | ;; This version of princ allows one to see 17 | ;; inside of your implementation's version of quasiquoted expressions... 18 | 19 | (defun rprinc (x) 20 | "hand-made princ that allows to see inside quasiquotes 21 | (results are implementation-dependent)" 22 | (labels 23 | ((rprinc-list (x) 24 | (princ "(") 25 | (rprinc-list-contents x) 26 | (princ ")")) 27 | (rprinc-list-contents (x) 28 | (rprinc (car x)) 29 | (rprinc-cdr (cdr x))) 30 | (rprinc-cdr (x) 31 | (if x (if (consp x) 32 | (progn 33 | (princ " ") 34 | (rprinc-list-contents x)) 35 | (progn 36 | (princ " . ") 37 | (rprinc x)))))) 38 | (cond 39 | ((consp x) (rprinc-list x)) 40 | (t (princ x))) 41 | x)) 42 | 43 | ;; You can test the quasiquote implementation like this: 44 | 45 | (defmacro with-qq-syntax ((&key) &body body) 46 | `(call-with-qq-syntax #'(lambda () ,@body))) 47 | (defun call-with-qq-syntax (thunk) 48 | (with-standard-io-syntax 49 | (let ((*package* (find-package :fare-quasiquote/test)) 50 | (*readtable* *fq-readtable*) 51 | (*print-pprint-dispatch* *fq-pprint-dispatch*) 52 | (*print-pretty* t) 53 | (*print-readably* nil) 54 | (*print-case* :downcase)) 55 | (funcall thunk)))) 56 | 57 | (defun rq (s) (with-qq-syntax () (read-from-string s))) 58 | (defun pq (x) (with-qq-syntax () (write-to-string x))) 59 | (defun prq (x) (with-qq-syntax () (write-to-string (read-from-string x)))) 60 | (defun qq (x) (let* ((y (rq x)) (v (eval y)) (z (pq y))) 61 | `(q ,x ,y ,v ,@(unless (equal x z) (list z))))) 62 | 63 | (eval-when (:compile-toplevel :load-toplevel :execute) 64 | (defparameter *letter-feature* 65 | '((#\r (:not :quasiquote-at-macro-expansion-time)) 66 | (#\m :quasiquote-at-macro-expansion-time) 67 | (#\q (:not :quasiquote-passes-literals)) 68 | (#\l :quasiquote-passes-literals) 69 | (#\a (:not :quasiquote-strict-append)) 70 | (#\s :quasiquote-strict-append))) 71 | 72 | (defun f? (x) 73 | (or (eq x t) 74 | (loop :for c :across (string-downcase x) 75 | :for f = (cadr (assoc c *letter-feature*)) 76 | :always (uiop:featurep f)))) 77 | 78 | (defun u (x) 79 | (match x 80 | ((list 't v) v) 81 | ((type cl:cons) 82 | (loop :for (f v) :in x :when (f? f) :return v)) 83 | (otherwise x)))) 84 | 85 | (defmacro q (x y v &optional (z x)) 86 | `(progn 87 | (is (equalp (rq ,(u x)) ',(u y))) 88 | (is (equalp ,(u y) ',(u v))) 89 | (is (equal (prq ,x) ',(or (u z) (u x)))))) 90 | 91 | (defmacro qx (&rest tests) 92 | `(progn 93 | ,@(loop :for (x y v z) :in tests 94 | :collect `(q ,x ,y ,v ,z)))) 95 | 96 | ;;; Test values 97 | (defparameter a '(vector 0)) 98 | (defparameter b 11) 99 | (defparameter c (list 22 33)) 100 | (defparameter d (list 44 55)) 101 | (defmacro q-if-match (pat val then &optional else) ;; avoid pprint rules for if* on SBCL 102 | `(if-match ,pat ,val ,then ,else)) 103 | (defparameter *k '((cl:list :x x) (cl:list :y y))) 104 | 105 | (deftest test-quasiquote () 106 | (qx 107 | ("`a" 108 | ((r (quote a)) (m (quasiquote a))) 109 | (t a)) 110 | ("``a" 111 | ((r (quote (quote a))) 112 | (m (quasiquote (quasiquote a)))) 113 | (t (quote a))) 114 | ("`(a ,b)" 115 | ((r (list (quote a) b)) 116 | (m (quasiquote (a (unquote b))))) 117 | (t (a 11))) 118 | ("``(a ,b)" 119 | ((r (quote (list (quote a) b))) 120 | (m (quasiquote (quasiquote (a (unquote b)))))) 121 | (t (list (quote a) b))) 122 | ("`(a ,@c)" 123 | ((ra (cons (quote a) c)) 124 | (rs (cons (quote a) (append c nil))) 125 | (m (quasiquote (a (unquote-splicing c))))) 126 | (t (a 22 33))) 127 | ("`(,@c)" 128 | ((ra c) 129 | (rs (append c nil)) 130 | (m (quasiquote ((unquote-splicing c))))) 131 | (t (22 33)) 132 | ((a "c"))) 133 | ("`,`a" 134 | ((r (quote a)) 135 | (m (quasiquote (unquote (quasiquote a))))) 136 | (t a) 137 | (t "`a")) 138 | ("`(a . ,b)" 139 | ((r (cons (quote a) b)) 140 | (m (quasiquote (a unquote b)))) 141 | (t (a . 11)) 142 | ((a "`(a ,@b)"))) 143 | ("`(a ,b ,@c)" 144 | ((ra (list* (quote a) b c)) 145 | (rs (list* (quote a) b (append c nil))) 146 | (m (quasiquote (a (unquote b) (unquote-splicing c))))) 147 | (t (a 11 22 33))) 148 | ("(q-if-match `(a ,x . ,y) '(a b c d) (vector x y))" 149 | ((r (q-if-match (list* (quote a) x y) '(a b c d) (vector x y))) 150 | (m (q-if-match (quasiquote (a (unquote x) unquote y)) '(a b c d) (vector x y)))) 151 | #(b (c d)) 152 | ((a "(q-if-match `(a ,x ,@y) '(a b c d) (vector x y))"))) 153 | ("(q-if-match `#(a ,x . ,y) #(a b c d) (vector x y))" 154 | ((r (q-if-match (make-vector (list* (quote a) x y)) #(a b c d) (vector x y))) 155 | (m (q-if-match (quasiquote (unquote (make-vector (list* (quote a) x y)))) #(a b c d) (vector x y)))) 156 | #(b (c d)) 157 | ((a "(q-if-match `#(a ,x ,@y) #(a b c d) (vector x y))"))) 158 | ("(q-if-match `#(a ,x ,y d) #(a b c d) (vector x y))" 159 | ((r (q-if-match (make-vector (list (quote a) x y (quote d))) #(a b c d) (vector x y))) 160 | (m (q-if-match (quasiquote (unquote (make-vector (list (quote a) x y (quote d))))) 161 | #(a b c d) (vector x y)))) 162 | #(b c)) 163 | ("`(1 2 3)" 164 | ((r (quote (1 2 3))) 165 | (m (quasiquote (1 2 3)))) 166 | (t (1 2 3))) 167 | ("`(a ,@c . 4)" 168 | ((r (cons (quote a) (append c (quote 4)))) 169 | (m (quasiquote (a (unquote-splicing c) . 4)))) 170 | (t (a 22 33 . 4))) 171 | ("`(a ,b ,@c . ,d)" 172 | ((r (list* (quote a) b (append c d))) 173 | (m (quasiquote (a (unquote b) (unquote-splicing c) unquote d)))) 174 | (t (a 11 22 33 44 55)) 175 | ((a "`(a ,b ,@c ,@d)"))) 176 | ("`(,@c . ,d)" 177 | ((r (append c d)) 178 | (m (quasiquote ((unquote-splicing c) unquote d)))) 179 | (t (22 33 44 55)) 180 | ((a "`(,@c ,@d)"))) 181 | ("```(,,a ,',',b)" 182 | ;; The pretty-printer in 0.9.0 and earlier, had a bug inherited from SBCL, 183 | ;; and couldn't pretty-print this form back to its value. 184 | ((r (list (quote list) (quote (quote list)) (quote a) 185 | (list (quote list) (quote (quote common-lisp:quote)) (list (quote common-lisp:quote) b)))) 186 | (m (quasiquote (quasiquote (quasiquote ((unquote (unquote a)) (unquote '(unquote '(unquote b))))))))) 187 | (t (list (quote list) a (list (quote common-lisp:quote) '11)))) 188 | ("`#(a ,b)" 189 | ((r (make-vector (list (quote a) b))) 190 | (m (quasiquote (unquote (make-vector (list (quote a) b)))))) 191 | #(a 11)) 192 | ("`#3(a ,b)" 193 | ((r (n-vector 3 (list (quote a) b))) 194 | (m (quasiquote (unquote (n-vector 3 (list (quote a) b)))))) 195 | #(a 11 11)) 196 | ("`#5(a ,@c)" 197 | ((rs (n-vector 5 (cons (quote a) (append c nil)))) 198 | (ra (n-vector 5 (cons (quote a) c))) 199 | (ms (quasiquote (unquote (n-vector 5 (cons (quote a) (append c nil)))))) 200 | (ma (quasiquote (unquote (n-vector 5 (cons (quote a) c)))))) 201 | #(a 22 33 33 33)) 202 | ("`(foobar a b ,c ,'(e f g) d ,@'(e f g) (h i j) ,@c)" 203 | ((rs (list* (quote foobar) (quote a) (quote b) c '(e f g) (quote d) 204 | (append '(e f g) (cons (quote (h i j)) (append c nil))))) 205 | (ra (list* (quote foobar) (quote a) (quote b) c '(e f g) (quote d) 206 | (append '(e f g) (cons (quote (h i j)) c)))) 207 | (m (quasiquote (foobar a b (unquote c) (unquote '(e f g)) d 208 | (unquote-splicing '(e f g)) (h i j) (unquote-splicing c))))) 209 | (t (foobar a b (22 33) (e f g) d e f g (h i j) 22 33))) 210 | ("``(, @c)" 211 | ((r (quote (list @c))) 212 | (m (quasiquote (quasiquote ((unquote @c)))))) 213 | (t (list @c))) 214 | ("``(, .c)" 215 | ((r (quote (list .c))) 216 | (m (quasiquote (quasiquote ((unquote .c)))))) 217 | (t (list .c))) 218 | ("`(1 ,b)" 219 | ((rq (list (quote 1) b)) 220 | (rl (list 1 b)) 221 | (m (quasiquote (1 (unquote b))))) 222 | (t (1 11))) 223 | ;; From the SBCL test suite 224 | ("(list 'foo b)" (t (list 'foo b)) (t (foo 11)) "`(,'foo ,b)")) 225 | (let ((c (list 2 3))) 226 | (q "`(x ,b ,@a ,.c ,.d)" 227 | ((ra (list* (quote x) b (append a (nconc c d)))) 228 | (rs (list* (quote x) b (append a (nconc c d nil)))) 229 | (m (quasiquote (x (unquote b) (unquote-splicing a) (unquote-nsplicing c) (unquote-nsplicing d))))) 230 | (t (x 11 vector 0 2 3 44 55)) 231 | ((a "`(x ,b ,@a ,.c ,@d)"))) 232 | ;; NCONC is evil. Use at your own risk! 233 | (is (equal c '(2 3 44 55)))) 234 | (signals error (rq "`(foo bar #.(max 5 ,*print-base*))")) 235 | ;; From the exscribe tests 236 | (is (equal (pq (eval (rq "``(f ,@,@*k)"))) "`(f ,@(common-lisp:list :x x) ,@(common-lisp:list :y y))")) 237 | ;; From James M. Lawrence 238 | (loop for x in '("(x)" "`(,x)" "``(,,x)" "```(,,,x)") do 239 | (is (equal (prq x) x))) 240 | (is (equal (prq "`#.#(1 2 3)") "`#(1 2 3)")) ;; #. must reset the quasiquote level. 241 | (signals error (rq "`(foo bar #.(max 5 ,*print-base*))")) 242 | t) 243 | 244 | ;;; Double-quasiquote test from the SBCL test suite backq.impure.lisp 245 | (defparameter *qq* '(*rr* *ss*)) 246 | (defparameter *rr* '(3 5)) 247 | (defparameter *ss* '(4 6)) 248 | (defun *rr* (x) (reduce #'* x)) 249 | (defparameter *x* '(a b)) 250 | (defparameter *y* '(c)) 251 | (defparameter *p* '(append *x* *y*)) 252 | (defparameter *q* '((append *x* *y*) (list 'sqrt 9))) 253 | (defparameter *r* '(append *x* *y*)) 254 | (defparameter *s* '((append *x* *y*))) 255 | 256 | (defparameter *double-quasiquote-tests* 257 | '(("``(,,*qq*)" . (24)) 258 | ;;("``(,@,*qq*)" . 24) Invalid 259 | ("``(,,@*qq*)" . ((3 5) (4 6))) 260 | ("``(foo ,,*p*)" . (foo (a b c))) 261 | ;;("``(foo ,,@*q*)" . (foo (a b c) (sqrt 9))) 262 | ("``(foo ,',*r*)" . (foo (append *x* *y*))) 263 | ("``(foo ,',@*s*)" . (foo (append *x* *y*))) 264 | ("``(foo ,@,*p*)" . (foo a b c)) 265 | ("``(foo ,@',*r*)" . (foo append *x* *y*)) 266 | ;; the following expression produces different result under LW. 267 | ;;("``(foo . ,,@*q*)" . (foo a b c sqrt 9)) 268 | ;; these three did not work. 269 | ("``(foo ,@',@*s*)" . (foo append *x* *y*)) 270 | ("``(foo ,@,@*q*)" . (foo a b c sqrt 9)) 271 | ("``(,@,@*qq*)" . (3 5 4 6)) 272 | ("``(,,@(list 1 2 3) 10)" . (1 2 3 10)))) 273 | 274 | (deftest test-double-quasiquote () 275 | (loop :for (expression . value) :in *double-quasiquote-tests* :do 276 | (is (equal (eval (eval (rq expression))) value))) 277 | t) 278 | 279 | ;;; This test is from dougk's 2014 patch to sbcl's backquote 280 | #-(or quasiquote-strict-append quasiquote-passes-literals quasiquote-at-macro-expansion-time) 281 | (deftest test-nested-backquote-readable-bogosity () 282 | (eval (rq "(defmacro broken-macro (more-bindings) 283 | `(macrolet ((with-bindings (&body body) 284 | `(let ((thing1 :something) ,',@more-bindings) ,@body))) 285 | (with-bindings (thing))))")) 286 | (flet ((e (s x) 287 | (eval `(is (equalp (rq ,s) (macroexpand-1 ',x)))))) 288 | ;; this example's expansion is correct but only by accident 289 | (e "(macrolet ((with-bindings (&body body) 290 | `(let ((thing1 :something) ,'(var val)) ,@body))) 291 | (with-bindings (thing)))" 292 | '(broken-macro ((var val)))) 293 | ;; this example shows that we correctly display an invalid 294 | ;; QUOTE special-form that has no operand 295 | (e "(macrolet ((with-bindings (&body body) 296 | `(let ((thing1 :something) ,(cl:quote)) ,@body))) 297 | (with-bindings (thing)))" 298 | '(broken-macro nil)) 299 | ;; ... or two operands 300 | (e "(macrolet ((with-bindings (&body body) 301 | `(let ((thing1 :something) ,(cl:quote (var :some-form) (var2 2))) ,@body))) 302 | (with-bindings (thing)))" 303 | '(broken-macro ((var :some-form) (var2 2)))) 304 | ;; ... or an attempt to bind the symbol nil 305 | (e "(macrolet ((with-bindings (&body body) 306 | `(let ((thing1 :something) ,'nil) ,@body))) 307 | (with-bindings (thing)))" 308 | '(broken-macro (nil))) 309 | ;; ... or even a meaningless dotted-list quote form 310 | (e "(macrolet ((with-bindings (&body body) 311 | `(let ((thing1 :something) ,(cl:quote . frob)) ,@body))) 312 | (with-bindings (thing)))" 313 | '(broken-macro frob)))) 314 | 315 | (deftest preserving-inner-backquotes () 316 | (flet ((e (s v) 317 | (eval `(is (equal (pq (eval (rq ,v))) ,s))))) 318 | 319 | ;; Continuing with *BACKQUOTE-TESTS*, instead of checking for the value 320 | ;; after twice evaluating, check for expected printed form after one eval. 321 | (e "`(,(*rr* *ss*))" "``(,,*qq*)") 322 | #+quasiquote-strict-append 323 | (e "`(,@(*rr* *ss*))" "``(,@,*qq*))") 324 | #-quasiquote-strict-append 325 | (e "(*rr* *ss*)" "``(,@,*qq*))") 326 | (e "`(,*rr* ,*ss*)" "``(,,@*qq*)") 327 | ;; could do the rest but pprinting is pretty simple now, so ... nah 328 | 329 | ;; Three tests inspired by tests from CLISP, but our answers are, I think, 330 | ;; better because we preserve inner quasiquotation. This is permissible 331 | ;; since a backquoted expression containing #\` nested to depth N has 332 | ;; no concrete form expressible as literals until N evaluations. 333 | ;; This is made clear if not in the normative part of CLHS, 334 | ;; then certainly in the appendix to CLtL2. 335 | 336 | (defvar x '(a b c)) 337 | 338 | (e "(foo `(bar ,@'((baz 'a a) (baz 'b b) (baz 'c c) (baz 'd d))))" 339 | "(let ((list '(a b c d))) 340 | `(foo `(bar ,@',(mapcar (lambda (sym) `(baz ',sym ,sym)) 341 | list))))") 342 | (e "x" "````,,,,'x") ;; NB: SBCL preserves "```,,,x" 343 | 344 | ;; In this one the leftmost backquote's comma is the second from the left. 345 | ;; That subform is "`,3" which is just 3. The inner quasiquote remains. 346 | (e "3" "``,,`,3"))) ;; NB: SBCL preserves "`,3" 347 | 348 | #| ;; We fail these tests that SBCL is proud of passing. 349 | (deftest preserving-backquotes-difficult () 350 | (is (equal (prq "(let ((c 'cee) (d 'dee) (g 'gee) (h 'hooray)) 351 | `(`(a ,b ,',c ,,d) . `(e ,f ,',g ,,h))))") 352 | "(`(a ,b ,'cee ,dee) . `(e ,f ,'gee ,hooray))")) 353 | (is (equal (prq "(let ((c 'cee) (d 'dee) (g 'gee) (h 'hooray)) 354 | `(foo `(a ,b ,',c ,,d) . `(e ,f ,',g ,,h))))") 355 | "(foo `(a ,b ,'cee ,dee) . `(e ,f ,'gee ,hooray))"))) |# 356 | 357 | (deftest pprint-backquote-magic () 358 | (is (equal (prq "`(, .foo)") "`(, .foo)")) 359 | (is (equal (prq "`(, @foo)") "`(, @foo)")) 360 | (is (equal (prq "`(, ?foo)") "`(,?foo)")) 361 | (is (equal (prq "`(x ., @foo)") 362 | #-quasiquote-strict-append "`(x ,@@foo)" 363 | #+quasiquote-strict-append "`(x . , @foo)"))) 364 | 365 | ;;; unquoted lambda lists should not leak the UNQUOTE implementation. 366 | (deftest pprint-leaking-backq-comma () 367 | (is (equal (prq "`(foo ,x)") "`(foo ,x)")) 368 | (is (equal (prq "`(foo ,@x)") "`(foo ,@x)")) 369 | (is (equal (prq "`(foo ,.x)") 370 | #-quasiquote-strict-append "`(foo ,@x)" 371 | #+quasiquote-strict-append "`(foo ,.x)")) 372 | (is (equal (prq "`(foo (,x))") "`(foo (,x))"))) 373 | 374 | ;;;; One more test from the SBCL test suite: 375 | ;;; more backquote printing brokenness, fixed quasi-randomly by CSR. 376 | ;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time, 377 | ;;; these assertions, like the ones above, are fragile. Likewise, it 378 | ;;; is very possible that at some point READABLY printing backquote 379 | ;;; expressions will have to change to printing the low-level conses, 380 | ;;; since the magical symbols are accessible though (car '`(,foo)) and 381 | ;;; friends. HATE HATE HATE. -- CSR, 2004-06-10 382 | (deftest pprint-more-backquote-brokenness () 383 | (flet ((e (input) 384 | (is (equalp input (prq input))))) 385 | (map () #'e 386 | '("``(foo ,@',@bar)" 387 | "``(,,foo ,',foo foo)" 388 | "``(((,,foo) ,',foo) foo)" 389 | "`#()" 390 | "`#(,bar)" 391 | "`#(,(bar))" 392 | ;; "`#(,@bar)" ; invalid 393 | "`#(,@(bar))" 394 | "`#(a ,b c)" 395 | #+quasiquote-strict-append "`#(a ,b . ,c)" 396 | "`#(,@a ,b c)" 397 | #+quasiquote-strict-append 398 | "`(,a . #(foo #() #(,bar) ,bar))" 399 | "(xlet ((foo (x))) `(xlet (,foo) (xsetq ,foo (y)) (baz ,foo)))")))) 400 | 401 | #| 402 | ;; To test this system in all configurations: 403 | 404 | cl-launch \ 405 | "(asdf:test-system :fare-quasiquote :force '(fare-quasiquote fare-quasiquote-test))" 406 | 407 | cl-launch \ 408 | "(progn 409 | (pushnew :quasiquote-at-macro-expansion-time *features*) 410 | (asdf:test-system :fare-quasiquote :force '(fare-quasiquote fare-quasiquote-test)))" 411 | 412 | cl-launch \ 413 | "(progn 414 | (pushnew :quasiquote-passes-literals *features*) 415 | (asdf:test-system :fare-quasiquote :force '(fare-quasiquote fare-quasiquote-test)))" 416 | 417 | cl-launch \ 418 | "(progn 419 | (pushnew :quasiquote-at-macro-expansion-time *features*) 420 | (pushnew :quasiquote-passes-literals *features*) 421 | (asdf:test-system :fare-quasiquote :force '(fare-quasiquote fare-quasiquote-test)))" 422 | |# 423 | --------------------------------------------------------------------------------