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