tests/backq.pure.lisp

   1 ;;;; tests of backquote readmacro
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (with-test (:name :backq-smoke-test)
  15   (assert (equalp (macroexpand '`#(() a #(#() nil x) #()))
  16                   ''#(NIL A #(#() NIL X) #()))))
  17
  18 (defparameter *qq* '(*rr* *ss*))
  19 (defparameter *rr* '(3 5))
  20 (defparameter *ss* '(4 6))
  21
  22 (defun *rr* (x)
  23   (reduce #'* x))
  24
  25 (defparameter *x* '(a b))
  26 (defparameter *y* '(c))
  27 (defparameter *p* '(append *x* *y*))
  28 (defparameter *q* '((append *x* *y*) (list 'sqrt 9)))
  29 (defparameter *r* '(append *x* *y*))
  30 (defparameter *s* '((append *x* *y*)))
  31
  32 (defun test-double-backquote (expression value)
  33   #+nil(format t "~&Testing: ~A... " expression)
  34   (assert (equal (eval (eval (read-from-string expression)))
  35                  value))
  36   #+nil(progn (format t "Ok. Look at PPRINTed version: ")
  37               (pprint (read-from-string expression))))
  38
  39 (defparameter *backquote-tests*
  40   '(("``(,,*QQ*)" . (24))
  41     ("``(,@,*QQ*)" . 24)
  42     ("``(,,@*QQ*)" . ((3 5) (4 6)))
  43     ("``(FOO ,,*P*)" . (foo (a b c)))
  44     ("``(FOO ,,@*Q*)" . (foo (a b c) (sqrt 9)))
  45     ("``(FOO ,',*R*)" . (foo (append *x* *y*)))
  46     ("``(FOO ,',@*S*)" . (foo (append *x* *y*)))
  47     ("``(FOO ,@,*P*)" . (foo a b c))
  48     ("``(FOO ,@',*R*)" . (foo append *x* *y*))
  49     ;; The following expression produces different result under LW.
  50     ("``(FOO . ,,@*Q*)" . (foo a b c sqrt 9))
  51     ;; These three did not work.
  52     ("``(FOO ,@',@*S*)" . (foo append *x* *y*))
  53     ("``(FOO ,@,@*Q*)" . (foo a b c sqrt 9))
  54     ("``(,@,@*QQ*)" . (3 5 4 6))))
  55
  56 (mapc (lambda (test)
  57         (test-double-backquote (car test) (cdr test)))
  58       *backquote-tests*)
  59
  60 (let ((string "`(foobar a b ,c ,'(e f g) d ,@'(e f g) (h i j) ,@foo)"))
  61   (assert (equalp (print (read-from-string string) (make-broadcast-stream))
  62                   (read-from-string string))))
  63
  64 (let ((a '`(1 ,@a ,@b ,.c ,.d)))
  65   (let ((*print-circle* t))
  66     (assert (equalp (read-from-string (write-to-string a)) a))))
  67
  68 (let ((s '``(,,@(list 1 2 3) 10)))
  69   (assert (equal (eval (eval s)) '(1 2 3 10))))
  70
  71 (with-test (:name :sharp-dot-resets-backquote-depth)
  72   (assert (equalp `#.(write-to-string (read-from-string "#(1 2 3)"))
  73                   "#(1 2 3)"))
  74   (assert (eq :error
  75               (handler-case (read-from-string "`(foo bar #.(max 5 ,*print-base*))")
  76                 (reader-error () :error)))))
  77
  78 (with-test (:name :triple-backquote)
  79   (flet  ((expect (expect val)
  80             (assert (string= (write-to-string val) expect))))
  81     (let ((plet/fast 'val1)
  82           (expr '```(,',',plet/fast ,',kernel ,@body)))
  83       (declare (special plet/fast))
  84       (expect "```(,',',PLET/FAST ,',KERNEL ,@BODY)" expr)
  85       (expect "``(,','VAL1 ,',KERNEL ,@BODY)" (eval expr))
  86       (let ((kernel 'val2))
  87         (declare (special kernel))
  88         (expect "`(,'VAL1 ,'VAL2 ,@BODY)" (eval (eval expr)))
  89         (let ((body '((fn) (otherfn))))
  90           (declare (special body))
  91           (expect "(VAL1 VAL2 (FN) (OTHERFN))" (eval (eval (eval expr)))))))))
  92
  93 (defmacro broken-macro (more-bindings)
  94   `(macrolet ((with-bindings (&body body)
  95                 `(let ((thing1 :something) ,',@more-bindings) ,@body)))
  96      (with-bindings (thing))))
  97
  98 ;; In the above macro (WITH-BINDINGS (THING)) can be rendered unevaluable
  99 ;; due to syntax error via improper format of MORE-BINDINGS.
 100 ;; Regardless, the pprinter should faithfully indicate how BROKEN-MACRO expands.
 101 ;; All of these tests except for the baseline "accidentally working" case
 102 ;; either crashed the pprinter or displayed incorrectly.
 103 (with-test (:name :bug-1063414-unprintable-nested-backquote)
 104   (flet  ((expect (expect form)
 105             (assert (string= (write-to-string (macroexpand-1 form))
 106                              expect))))
 107
 108     ;; this example's expansion is correct but only by accident
 109     (expect "(MACROLET ((WITH-BINDINGS (&BODY BODY)
 110              `(LET ((THING1 :SOMETHING) ,'(VAR VAL))
 111                 ,@BODY)))
 112   (WITH-BINDINGS (THING)))" '(broken-macro ((var val))))
 113
 114     ;; this example should correctly print QUOTE with no operand
 115     (expect "(MACROLET ((WITH-BINDINGS (&BODY BODY)
 116              `(LET ((THING1 :SOMETHING) ,(QUOTE))
 117                 ,@BODY)))
 118   (WITH-BINDINGS (THING)))" '(broken-macro nil))
 119
 120     ;; ... or two operands
 121     (expect "(MACROLET ((WITH-BINDINGS (&BODY BODY)
 122              `(LET ((THING1 :SOMETHING) ,(QUOTE (VAR :SOME-FORM) (VAR2 2)))
 123                 ,@BODY)))
 124   (WITH-BINDINGS (THING)))" '(broken-macro ((var :some-form) (var2 2))))
 125
 126     ;; ... or an attempt to bind the symbol NIL
 127     (expect "(MACROLET ((WITH-BINDINGS (&BODY BODY)
 128              `(LET ((THING1 :SOMETHING) ,'NIL)
 129                 ,@BODY)))
 130   (WITH-BINDINGS (THING)))" '(broken-macro (nil)))
 131
 132     ;; ... or even a meaningless dotted-list QUOTE form
 133     (expect "(MACROLET ((WITH-BINDINGS (&BODY BODY)
 134              `(LET ((THING1 :SOMETHING) ,(QUOTE . FROB))
 135                 ,@BODY)))
 136   (WITH-BINDINGS (THING)))" '(broken-macro frob))))
 137
 138 (with-test (:name :preserving-inner-backquotes)
 139   (flet  ((expect (expect val)
 140             (assert (string= (write-to-string val) expect))))
 141
 142     ;; Continuing with *BACKQUOTE-TESTS*, instead of checking for the value
 143     ;; after twice evaluating, check for expected printed form after one eval.
 144     (expect "`(,(*RR* *SS*))" ``(,,*QQ*))
 145     (expect "`(,@(*RR* *SS*))" ``(,@,*QQ*))
 146     (expect "`(,*RR* ,*SS*)" ``(,,@*QQ*))
 147
 148     ;; Three tests inspired by tests from CLISP, but our expected answers are,
 149     ;; I think, better because inner backquotes are preserved.
 150     (expect "(FOO `(BAR ,@'((BAZ 'A A) (BAZ 'B B) (BAZ 'C C) (BAZ 'D D))))"
 151             (let ((list '(a b c d)))
 152               `(foo `(bar ,@',(mapcar (lambda (sym) `(baz ',sym ,sym))
 153                                       list)))))
 154
 155     (expect "```,,,X" ````,,,,'x)
 156
 157     ;; In this one the leftmost backquote's comma is the second from the left.
 158     ;; That subform is "`,3" which is just 3. The inner quasiquote remains.
 159     (expect "`,3" ``,,`,3)))
 160
 161 (with-test (:name :preserving-backquotes-difficult)
 162   (assert (string= (write-to-string
 163                     (let ((c 'cee) (d 'dee) (g 'gee) (h 'hooray))
 164                       `(`(a ,b ,',c ,,d) . `(e ,f ,',g ,,h))))
 165                    "(`(A ,B ,'CEE ,DEE) . `(E ,F ,'GEE ,HOORAY))"))
 166   (assert (string= (write-to-string
 167                     (let ((c 'cee) (d 'dee) (g 'gee) (h 'hooray))
 168                       `(foo `(a ,b ,',c ,,d) . `(e ,f ,',g ,,h))))
 169                    "(FOO `(A ,B ,'CEE ,DEE) . `(E ,F ,'GEE ,HOORAY))")))
 170
 171 (with-test (:name :backquote-permissible-circularity)
 172   (flet  ((expect (expect val)
 173             (assert (string= (write-to-string val) expect))))
 174     (let ((*print-circle* t))
 175       ;; this should be agnostic of the circular form after the comma
 176       (expect "`(FOO BAR ,(HI '#1=(BAR FOO #1# . #1#)))"
 177               '`(FOO BAR ,(HI '#1=(BAR FOO #1# . #1#)))))))
 178
 179 (with-test (:name :read-backq-missing-expression)
 180   (assert (string= (handler-case (read-from-string "`(foo ,@)")
 181                      (sb-int:simple-reader-error (c)
 182                        (simple-condition-format-control c)))
 183                    "Trailing ~A in backquoted expression.")))
 184 (with-test (:name :read-backq-vector-illegal)
 185   (assert (eql (search "Improper list"
 186                        (handler-case
 187                            (read-from-string "`((a  #(foo bar . ,(cons 1 2))))")
 188                          (sb-int:simple-reader-error (c)
 189                            (simple-condition-format-control c))))
 190                0)))
 191
 192 (with-test (:name :backq-vector)
 193   (assert-error (eval (read-from-string "`#(,@#())")))
 194   (assert-error (eval (read-from-string "`#(,@`#())")))
 195   (assert (equalp `#(,@(list 1 2 3)) #(1 2 3)))
 196   (assert (equalp `#(0 ,@(list 1 2 3)) #(0 1 2 3)))
 197   (assert (equalp `#(,@(list 1 2 3) ,4) #(1 2 3 4))))
 198
 199 (with-test (:name :backq-standard-list-constructors)
 200   (assert (equal (macroexpand '`(,.(list 1 2 3) 4))
 201                  '(nconc (list 1 2 3) '(4))))
 202   (assert (equal (funcall (compiler-macro-function 'sb-int:quasiquote)
 203                           '`(,.(list 1 2 3) 4) nil)
 204                  '(nconc (list 1 2 3) '(4))))
 205   (assert (equal (macroexpand '`(,@(list 1 2 3) 4))
 206                  '(append (list 1 2 3) '(4))))
 207   (assert (equal (funcall (compiler-macro-function 'sb-int:quasiquote)
 208                           '`(,@(list 1 2 3) 4) nil)
 209                  '(sb-impl::|Append| (list 1 2 3) '(4)))))
 210
 211 (import 'sb-int:quasiquote)
 212
 213 (test-util:with-test (:name :backquote-more-weirdness)
 214   ;; No expectation on any other Lisp.
 215   (flet  ((expect (expect val)
 216             (assert (string= (write-to-string val) expect))))
 217     ;; There is one quasiquote and one comma
 218     (expect "`(QUASIQUOTE QUASIQUOTE CADR ,FOO)"
 219             '`(quasiquote quasiquote cadr ,foo))
 220     ;; There are three quasiquotes
 221     (expect "```(CADR ,FOO)"
 222             '`(quasiquote (quasiquote (cadr ,foo))))))