Skip to content
Snippets Groups Projects
Commit 09f05d35 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

0.9.3: fix printing of (, @foo). Add tests from the SBCL test suite.

parent 8e230dbd
No related branches found
No related tags found
No related merge requests found
......@@ -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")
......
......@@ -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)
......
......@@ -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)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment