tests/macroexpand.pure.lisp

   1 ;;;; This file is for macroexpander tests which have side effects
   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 ;;; From Matthew Swank on cll 2005-10-06
  15
  16 (defmacro defglobal* (name &optional value)
  17   (let ((internal (gensym)))
  18     `(progn
  19        (defparameter ,internal ,value)
  20        (define-symbol-macro ,name ,internal))))
  21
  22 (defglobal* glob)
  23
  24 (assert (= (let ((glob 4)) glob)))
  25 (assert (null glob))
  26 (assert (equal (let ((glob nil)) (setf glob (cons 'foo glob)) glob) '(foo)))
  27 (assert (null glob))
  28 (assert (equal (let ((glob nil)) (push 'foo glob) glob) '(foo)))
  29 (assert (null glob))
  30
  31 ;;; CLHS 3.1.2.1.1 specifies that symbol macro expansion must also
  32 ;;; go through *MACROEXPAND-HOOK*. (2007-09-22, -TCR.)
  33
  34 (define-symbol-macro .foo. 'foobar)
  35
  36 ;;; An evaluated macroexpand-hook leads to infinite recursion.
  37 ;;; These tests used to be runnable only if *evaluator-mode* started out
  38 ;;; as :compile, but now we support running the test suite with any
  39 ;;; *evaluator-mode*, so must explicitly COMPILE the macroexpand hook.
  40 ;;; Notice that the lambda expressions being compiled are closures.
  41 ;;; This is allowed by sb-interpreter. sb-eval gets an error
  42 ;;; "Unhandled INTERPRETER-ENVIRONMENT-TOO-COMPLEX-ERROR:
  43 ;;;  Lexical environment of #<INTERPRETED-FUNCTION NIL {1001850EBB}>
  44 ;;   is too complex to compile."
  45
  46 ;;; Like CHECKED-COMPILE, this disallows unexpected warnings.
  47 ;;; But unlike CHECKED-COMPILE, it allows the argument to be a function.
  48 (defun compilefun (fun)
  49   (multiple-value-bind (result warnp errorp)
  50       (compile nil fun)
  51     (assert (not warnp))
  52     (assert (not errorp))
  53     result))
  54
  55 (let* ((expanded-p nil)
  56        (*macroexpand-hook*
  57         (compilefun  #'(lambda (fn form env)
  58                          (when (eq form '.foo.)
  59                            (setq expanded-p t))
  60                          (funcall fn form env)))))
  61   (multiple-value-bind (expansion flag) (macroexpand '.foo.)
  62     (assert (equal expansion '(quote foobar)))
  63     (assert flag)
  64     (assert expanded-p)))
  65
  66 #+(or sb-eval sb-fasteval)
  67 (let ((sb-ext:*evaluator-mode* :interpret))
  68   (let* ((expanded-p nil)
  69          (*macroexpand-hook*
  70           (compilefun  #'(lambda (fn form env)
  71                            (when (eq form '.foo.)
  72                              (setq expanded-p t))
  73                            (funcall fn form env)))))
  74     (eval '.foo.)
  75     (assert expanded-p)))
  76
  77 (let* ((expanded-p nil)
  78        (*macroexpand-hook*
  79         (compilefun  #'(lambda (fn form env)
  80                          (when (eq form '/foo/)
  81                            (setq expanded-p t))
  82                          (funcall fn form env)))))
  83   (compile nil '(lambda ()
  84                  (symbol-macrolet ((/foo/ 'foobar))
  85                    (macrolet ((expand (symbol &environment env)
  86                                 (macroexpand symbol env)))
  87                      (expand /foo/)))))
  88   (assert expanded-p))
  89
  90 ;; Check that DEFINE-SYMBOL-MACRO on a variable whose global :KIND
  91 ;; was :ALIEN gets a sane error message instead of ECASE failure.
  92 (sb-alien:define-alien-variable ("posix_argv" foo-argv) (* (* char)))
  93 (handler-case (define-symbol-macro foo-argv (silly))
  94   (error (e)
  95     (assert (string= "Symbol FOO-ARGV is already defined as an alien variable."
  96                      (write-to-string e :escape nil))))
  97   (:no-error () (error "Expected an error")))
  98
  99 (with-test (:name :binding*-expander)
 100 (assert (equal (macroexpand-1
 101                 '(sb-int:binding* (((foo x bar zz) (f) :exit-if-null)
 102                                    ((baz y) (g bar)))
 103                   (declare (integer x foo) (special foo y))
 104                   (declare (special zz bar l) (real q foo))
 105                   (thing)))
 106                '(MULTIPLE-VALUE-BIND (FOO X BAR ZZ) (F)
 107                  (DECLARE
 108                   (INTEGER X FOO) (SPECIAL FOO) (SPECIAL ZZ BAR) (REAL FOO))
 109                  (WHEN FOO (MULTIPLE-VALUE-BIND (BAZ Y) (G BAR)
 110                              (DECLARE (SPECIAL Y))
 111                              (DECLARE (SPECIAL L) (REAL Q)) (THING))))))
 112
 113 (assert (equal (macroexpand-1
 114                 '(sb-int:binding* (((x y) (f))
 115                                    (x (g y x)))
 116                   (declare (integer x))
 117                   (foo)))
 118                '(MULTIPLE-VALUE-BIND (X Y) (F)
 119                  (LET* ((X (G Y X)))
 120                    (DECLARE (INTEGER X))
 121                    (FOO)))))
 122
 123 ;; The conversion of a trailing sequence of individual bindings
 124 ;; into one LET* failed to remove declarations that were already
 125 ;; injected pertinent to ealier bound variables.
 126 (assert (equal-mod-gensyms
 127          (macroexpand-1
 128           '(sb-int:binding* (((v1 v2 nil) (foo))
 129                              (a (f v1))
 130                              (b (g v2)))
 131             (declare (special fred) (optimize speed)
 132                      (optimize (debug 3)))
 133             (declare (integer v1 v2))
 134             (body)))
 135          '(multiple-value-bind (v1 v2 #1=#:g538) (foo)
 136            (declare (integer v1 v2))
 137            (declare (ignorable #1#))
 138            (let* ((a (f v1)) (b (g v2)))
 139              (declare (special fred) (optimize speed) (optimize (debug 3)))
 140              (body)))))
 141
 142 ;; :EXIT-IF-NULL was inserting declarations into the WHEN expression.
 143 (assert (equal-mod-gensyms
 144          (macroexpand-1
 145           '(sb-int:binding* (((a1 a2) (f))
 146                              (b (g))
 147                              ((c1 nil c2) (h) :exit-if-null)
 148                              ((d1 d1) (f))
 149                              (nil (e) :exit-if-null))
 150             (declare (special fff c2) (integer d1))
 151             (declare (fixnum a2)
 152                      (special *x* *y* c1))
 153             (declare (cons b) (type integer *y* a1))
 154             (a-body-form)
 155             (another-body-form)))
 156          '(multiple-value-bind (a1 a2) (f)
 157            (declare (fixnum a2) (type integer a1))
 158            (let* ((b (g)))
 159              (declare (cons b))
 160              (multiple-value-bind (c1 #2=#:dummy-1 c2) (h)
 161                (declare (special c2) (special c1))
 162                (declare (ignorable #2#))
 163                (when c1
 164                  (multiple-value-bind (d1 d1) (f)
 165                    (declare (integer d1))
 166                    (let* ((#3=#:dummy-2 (e)))
 167                      (declare (ignorable #3#))
 168                      (declare (special fff))
 169                      (declare (special *y* *x*))
 170                      (declare (type integer *y*))
 171                      (when #3#
 172                        (a-body-form) (another-body-form))))))))))
 173
 174 ) ; end BINDING*-EXPANDER test
 175
 176 (eval-when (:compile-toplevel :load-toplevel :execute)
 177   (import '(sb-int:&more sb-int:parse-lambda-list)))
 178
 179 (with-test (:name :parse-lambda-list)
 180   ;; 3.4.1 - ordinary lambda list
 181   (assert-error (parse-lambda-list '(foo &body bar)))
 182   (assert-error (parse-lambda-list '(foo &whole bar)))
 183   (assert-error (parse-lambda-list '(foo &environment bar)))
 184   ;; &more expects exactly two following symbols
 185   (assert-error (parse-lambda-list '(foo &more)))
 186   (assert-error (parse-lambda-list '(foo &more c)))
 187   (assert-error (parse-lambda-list '(foo &more ctxt ct junk)))
 188   ;; &more and &rest are mutually exclusive
 189   (assert-error (parse-lambda-list '(foo &rest foo &more ctxt n)))
 190   (assert-error (parse-lambda-list '(foo &more ctxt n &rest foo)))
 191
 192   ;; 3.4.2 - generic function lambda lists
 193   (macroexpand-1 '(defgeneric foo (a b &key size &allow-other-keys)))
 194   (assert-error (macroexpand-1 '(defgeneric foo (a b &aux x)))
 195                 sb-pcl::generic-function-lambda-list-error)
 196   ;; 3.4.3 - FIXME: add tests
 197
 198   ;; 3.4.4 - doesn't use PARSE-LAMBDA-LIST yet
 199   ;; 3.4.5 - same
 200
 201   ;; 3.4.6 - BOA lambda list is a function lambda list,
 202   ;; but the expander silently disregarded the internal &MORE keyword,
 203   ;; which has no place in DEFSTRUCT.
 204   (assert-error
 205    (macroexpand-1 '(defstruct (s (:constructor
 206                                   make-s (a b &more ctxt n)))
 207                     a b ctxt n)))
 208
 209   ;; 3.4.7 - DEFSETF disallows &AUX
 210   (assert-error (macroexpand-1
 211                  '(defsetf foof (a b &optional k &aux) (v1 v2) (forms))))
 212
 213   ;; 3.4.8 - DEFTYPE is exactly like DEFMACRO
 214   ;;         except for the implied default-default of '*
 215
 216   ;; 3.4.9 - DEFINE-MODIFY-MACRO allows only &OPTIONAL and &REST
 217   (assert-error (macroexpand-1
 218                  '(define-modify-macro foof (a b &optional k &key) foo)))
 219   (assert-error (macroexpand-1
 220                  '(define-modify-macro foof (a b &optional k &body) foo)))
 221
 222   ;; 3.4.10 - DEFINE-METHOD-COMBINATION. Not even sure what this does.
 223
 224   )
 225
 226 (defstruct foo (a 0 :type fixnum))
 227 (defstruct bar (a 0 :type fixnum))
 228 (declaim (notinline (setf bar-a)))
 229 ;; This macro definition is technically violating the dynamic-extent
 230 ;; nature of environment objects (as per X3J13), but of course ours don't.
 231 (defmacro capture-env (&environment e &rest r)
 232   (declare (ignore r))
 233   e)
 234 (with-test (:name :macroexpand-setf-instance-ref.1)
 235   (assert (equal-mod-gensyms
 236            (macroexpand-1 '(setf (foo-a x) 3))
 237            `(let ((#1=instance (the foo x))
 238                   (#2=val (sb-kernel:the* (fixnum :context (sb-kernel::struct-context foo . a)) 3)))
 239               (sb-kernel:%instance-set #1# #.sb-vm:instance-data-start #2#)
 240               #2#))))
 241 (with-test (:name :macroexpand-setf-instance-ref.2)
 242   ;; Lexical definition of (SETF FOO-A) inhibits source-transform.
 243   ;; This is not required behavior - SETF of structure slots
 244   ;; do not necessarily go through a function named (SETF your-slot),
 245   ;; but it's this implementation's behavior, so should be asserted.
 246   (flet (((setf foo-a) (new obj) (declare (ignore obj)) new))
 247     (assert (equal-mod-gensyms
 248              (macroexpand-1 '(setf (foo-a x) 3) (capture-env))
 249              '(let* ((#1=#:x x) (new 3)) (funcall #'(setf foo-a) new #1#)))))
 250
 251   ;; Same, not required behavior - NOTINLINE inhibits transform.
 252   (assert (equal-mod-gensyms
 253            (macroexpand-1 '(setf (bar-a x) 3))
 254            '(let* ((#2=#:x x) (new 3)) (funcall #'(setf bar-a) new #2#)))))
 255 \f
 256 ;;; WITH-CURRENT-SOURCE-FORM tests
 257
 258 (defmacro warnings-in-subforms (a b)
 259   (with-current-source-form (a)
 260     (warn "a warning"))
 261   (with-current-source-form (b)
 262     (warn "a warning"))
 263   `(progn ,a ,b))
 264
 265 (with-test (:name (with-current-source-form :smoke))
 266   (assert (equal (checked-compile-condition-source-paths
 267                   '(lambda () (warnings-in-subforms 1 2)))
 268                  '((2 0) (2 0))))
 269   (assert (equal (checked-compile-condition-source-paths
 270                   '(lambda () (warnings-in-subforms (progn 1) (progn 2))))
 271                  '((1 2 0) (2 2 0))))
 272   (assert (equal (checked-compile-condition-source-paths
 273                   '(lambda ()
 274                     (warnings-in-subforms
 275                      (warnings-in-subforms (progn 1) (progn 2))
 276                      (progn 3))))
 277                  '((1 2 0) (2 2 0) (1 1 2 0) (2 1 2 0)))))
 278
 279 (with-test (:name :symbol-case-clause-ordering)
 280   (let ((f (checked-compile
 281             '(lambda (x) (case x ((a z) 1) ((y b w) 2) ((b c) 3)))
 282             :allow-style-warnings t)))
 283     (assert (eql (funcall f 'b) 2))))
 284
 285 (deftype zook () '(member :a :b :c))
 286 ;; TYPECASE should become CASE when it can, even if the resulting CASE
 287 ;; will not expand using symbol-hash.
 288 (with-test (:name :typecase-to-case)
 289   ;; TYPECASE without a final T clause
 290   (assert (equal (macroexpand-1 '(typecase x ((eql z) 1) ((member 2 3) hi) (zook :z)))
 291                  '(case x ((z) 1) ((2 3) hi) ((:a :b :c) :z))))
 292   ;; with final T
 293   (assert (equal (macroexpand-1 '(typecase x ((eql z) 1) ((member 2 3) hi) (zook :z) (t 'def)))
 294                  '(case x ((z) 1) ((2 3) hi) ((:a :b :c) :z) (t 'def))))
 295   ;; with final OTHERWISE
 296   (assert (equal (macroexpand-1 '(typecase x
 297                                   ((eql z) 1) ((member 2 3) hi) (zook :z) (otherwise 'def)))
 298                  '(case x ((z) 1) ((2 3) hi) ((:a :b :c) :z) (t 'def))))
 299
 300   ;; ETYPECASE without final T
 301   (assert (equal (macroexpand-1 '(etypecase x ((eql z) 1) ((member 2 3) hi) (zook :z)))
 302                  '(ecase x ((z) 1) ((2 3) hi) ((:a :b :c) :z))))
 303   ;; and with
 304   (assert (equal (macroexpand-1 '(etypecase x ((eql z) 1) ((member 2 3) hi) (zook :z) (t 'def)))
 305                  '(case x ((z) 1) ((2 3) hi) ((:a :b :c) :z) (t 'def)))))
 306
 307 (with-test (:name :cypecase-never-err)
 308   (assert (eq (let ((x 1)) (ctypecase x (t 'a))) 'a)))
 309
 310 (with-test (:name :typecase-t-shadows-rest)
 311   (assert-signal (macroexpand-1 '(typecase x (atom 1) (t 2) (cons 3))) warning))
 312
 313 (with-test (:name :symbol-case-default-form)
 314   (let ((f (checked-compile
 315             '(lambda (x)
 316               (case x ((a b c) 1) ((d e f) 2) (t #*10101))))))
 317     (assert (equal (funcall f 30) #*10101))))
 318
 319 (with-test (:name :memq-as-case)
 320   (let* ((f (checked-compile
 321              '(lambda (x)
 322                (if (sb-int:memq x '(a b c d e f g h i j k l m n o p)) 1 2))))
 323          (code (sb-kernel:fun-code-header f))
 324          (constant
 325            (sb-kernel:code-header-ref
 326             code
 327             (+ sb-vm:code-constants-offset sb-vm:code-slots-per-simple-fun))))
 328     ;; should have a vector of symbols, not references to each symbol
 329     (assert (vectorp constant))
 330     (assert (eql (funcall f 'j) 1))
 331     (assert (eql (funcall f 42) 2)))
 332
 333   (let* ((f (checked-compile
 334              '(lambda (x)
 335                (or (member x '(a b c d e f g h i j k nil t l m n o p) :test 'eq)
 336                    -1))))
 337          (code (sb-kernel:fun-code-header f))
 338          (constant1
 339            (sb-kernel:code-header-ref
 340             code
 341             (+ sb-vm:code-constants-offset sb-vm:code-slots-per-simple-fun)))
 342          (constant2
 343            (sb-kernel:code-header-ref
 344             code
 345             (+ (1+ sb-vm:code-constants-offset) sb-vm:code-slots-per-simple-fun))))
 346     ;; These accesses are safe because if the transform happened,
 347     ;; there should be 2 constants, and if it didn't, then at least 2 constants.
 348     (assert (and (vectorp constant1) (vectorp constant2)))
 349     (assert (equal (funcall f 'o) '(o p)))
 350     (assert (eql (funcall f 42) -1))))
 351
 352 (defmacro macro-with-dotted-list (&rest args)
 353   args)
 354 (with-test (:name :macro-with-dotted-list)
 355   (let ((expansion (macroexpand '(macro-with-dotted-list . 1))))
 356     (assert (equal expansion 1))))
 357
 358 (with-test (:name :typecase)
 359   (declare (muffle-conditions style-warning))
 360   (assert
 361    (equal (loop for x in '(a 1 1.4 "c")
 362                 collect (typecase x
 363                           (t :good)
 364                           (otherwise :bad)))
 365           '(:good :good :good :good))))
 366
 367 (with-test (:name :typecase-nonfinal-otherwise-errs)
 368   (assert-error
 369    (macroexpand-1 '(typecase x (cons 1) (otherwise 2) (t 3)))))