diff --git a/fare-quasiquote.asd b/fare-quasiquote.asd index b201fa8f6d52971891f63caf07c1c751c450cce1..5a2cfc7afad4d84c0f7dfb11d328b07ec8eb9c51 100644 --- a/fare-quasiquote.asd +++ b/fare-quasiquote.asd @@ -5,7 +5,7 @@ :long-description "fare-quasiquote implements a portable quasiquote that you can control." :license "MIT" - :version "0.9.2" + :version "0.9.3" :depends-on (:fare-utils) :components ((:file "packages") diff --git a/pp-quasiquote.lisp b/pp-quasiquote.lisp index c5c8f01d055421acd05aab581b0c88b11fffb60b..8d70f8d99ab614db4ea6644a95be898a92278c9c 100644 --- a/pp-quasiquote.lisp +++ b/pp-quasiquote.lisp @@ -2,7 +2,7 @@ #+xcvb (module (:depends-on ("quasiquote"))) -;;;; This software is derived from the CMU CL system via SBCL. +;;;; This software is originally derived from the CMU CL system via SBCL. ;;;; CMU CL was written at Carnegie Mellon University and released into ;;;; the public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. @@ -20,50 +20,6 @@ (or (char= (char output 0) #\.) (char= (char output 0) #\@)))))) -#| -(defvar *pprint-qq-context* nil) - -(defun pprint-qq-form (x stream) - (write-char #\` stream) - (ppqq nil x stream)) - -(defun ppqq-context (context form stream) - (ecase context - ((nil) nil) - ((unquote) - (write-char #\, stream) - (when (pprint-starts-with-dot-or-at-p form) (write-char #\space stream)) - nil) - ((unquote-splicing) - (write-string ",@" stream) - nil) - ((unquote-nsplicing) - (write-string ",." stream) - nil) - ((list list* cons append nconc vector n-vector make-vector quote) - ;;(write-char #\` stream) - context))) - -(defun quasiquote-form-p (x) - (and (consp x) - (member (car x) '(list list* cons append nconc make-vector n-vector quote - unquote unquote-splicing unquote-nsplicing)) - (car x))) - -(defun ppqq (context x stream) - (let ((qp (quasiquote-form-p x))) - (cond - ((null qp) - (ppqq-context context x stream) - (write x stream)) - (t - (let ((forms (cdr x))) - (case qp - (t - (ppqq-context context x stream) - (ppqq qp form stream)))))))) -|# - (defun quasiquote-unexpand (x) (assert (and (consp x) (member (car x) '(list list* cons append nconc make-vector n-vector quote)))) (make-quasiquote (quasiquote-unexpand-00 x))) @@ -133,7 +89,7 @@ (write-char #\` stream)) ((unquote) (write-char #\, stream) - (when (pprint-starts-with-dot-or-at-p form) (write-char #\space stream))) + (when (pprint-starts-with-dot-or-at-p (cadr form)) (write-char #\space stream))) ((unquote-splicing) (write-string ",@" stream)) ((unquote-nsplicing) diff --git a/quasiquote-test.lisp b/quasiquote-test.lisp index 613a6f6976326af6d5b145870e5631834892f5b5..49b7233547dce43457d7788923b612a6d2b9d5c3 100644 --- a/quasiquote-test.lisp +++ b/quasiquote-test.lisp @@ -54,13 +54,8 @@ (defun rq (s) (with-qq-syntax () (read-from-string s))) (defun pq (x) (with-qq-syntax () (write-to-string x))) -(defun qq (x) (pq (rq x))) - -(defparameter b 11) -(defparameter c (list 22 33)) -(defparameter d (list 44 55)) -(defmacro q-if-match (pat val then &optional else) ;; avoid pprint rules for if* on SBCL - `(if-match ,pat ,val ,then ,else)) +(defun qq (x) (let* ((y (rq x)) (v (eval y)) (z (pq y))) + `(q ,x ,y ,v ,@(unless (equal x z) (list z))))) (defmacro q (x y v &optional (z x)) `(progn @@ -68,6 +63,14 @@ (is (equalp ,y ',v)) ,(unless (eq z t) `(is (equal (pq ',y) ,z))))) +;;; Test values +(defparameter a '(vector 0)) +(defparameter b 11) +(defparameter c (list 22 33)) +(defparameter d (list 44 55)) +(defmacro q-if-match (pat val then &optional else) ;; avoid pprint rules for if* on SBCL + `(if-match ,pat ,val ,then ,else)) + (deftest test-quasiquote () (q "`a" (quote a) a) (q "``a" (quote (quote a)) (quote a)) @@ -92,4 +95,49 @@ (q "`#(a ,b)" (make-vector (list (quote a) b)) #(a 11)) (q "`#3(a ,b)" (n-vector 3 (list (quote a) b)) #(a 11 11)) (q "`#5(a ,@c)" (n-vector 5 (cons (quote a) c)) #(a 22 33 33 33)) + (q "`(foobar a b ,c ,'(e f g) d ,@'(e f g) (h i j) ,@b)" + (list* (quote foobar) (quote a) (quote b) c '(e f g) (quote d) + (append '(e f g) (cons (quote (h i j)) b))) + (foobar a b (22 33) (e f g) d e f g (h i j) . 11)) + (let ((c (list 2 3))) + (q "`(1 ,b ,@a ,.c ,.d)" (list* (quote 1) b (append a (nconc c d))) (1 11 vector 0 2 3 44 55)) + ;; NCONC is evil. Use at your own risk! + (is (equal c '(2 3 44 55)))) + (q "``(, @c)" (quote (list @c)) (list @c)) + (q "``(, .c)" (quote (list .c)) (list .c)) + t) + +;;; Double-quasiquote test from the SBCL test suite backq.impure.lisp +(defparameter *qq* '(*rr* *ss*)) +(defparameter *rr* '(3 5)) +(defparameter *ss* '(4 6)) +(defun *rr* (x) (reduce #'* x)) +(defparameter *x* '(a b)) +(defparameter *y* '(c)) +(defparameter *p* '(append *x* *y*)) +(defparameter *q* '((append *x* *y*) (list 'sqrt 9))) +(defparameter *r* '(append *x* *y*)) +(defparameter *s* '((append *x* *y*))) + +(defparameter *double-quasiquote-tests* + '(("``(,,*qq*)" . (24)) + ("``(,@,*qq*)" . 24) + ("``(,,@*qq*)" . ((3 5) (4 6))) + ("``(foo ,,*p*)" . (foo (a b c))) + ("``(foo ,,@*q*)" . (foo (a b c) (sqrt 9))) + ("``(foo ,',*r*)" . (foo (append *x* *y*))) + ("``(foo ,',@*s*)" . (foo (append *x* *y*))) + ("``(foo ,@,*p*)" . (foo a b c)) + ("``(foo ,@',*r*)" . (foo append *x* *y*)) + ;; the following expression produces different result under LW. + ("``(foo . ,,@*q*)" . (foo a b c sqrt 9)) + ;; these three did not work. + ("``(foo ,@',@*s*)" . (foo append *x* *y*)) + ("``(foo ,@,@*q*)" . (foo a b c sqrt 9)) + ("``(,@,@*qq*)" . (3 5 4 6)) + ("`(,,@(list 1 2 3)" . (1 2 3 10)))) + +(deftest test-double-quasiquote () + (loop :for (expression . value) :in *double-quasiquote-tests* :do + (is (equal (eval (eval (rq expression))) value))) t)