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