tests/macroexpand.impure.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
  32
  33 ;;; CLHS 3.1.2.1.1 specifies that symbol macro expansion must also
  34 ;;; go through *MACROEXPAND-HOOK*. (2007-09-22, -TCR.)
  35
  36 (define-symbol-macro .foo. 'foobar)
  37
  38 ;;; An evaluated macroexpand-hook leads to infinite recursion.
  39 ;;; These tests used to be runnable only if *evaluator-mode* started out
  40 ;;; as :compile, but now we support running the test suite with any
  41 ;;; *evaluator-mode*, so must explicitly COMPILE the macroexpand hook.
  42 ;;; Notice that the lambda expressions being compiled are closures.
  43 ;;; This is allowed by sb-interpreter but not sb-eval.
  44
  45 (let* ((expanded-p nil)
  46        (*macroexpand-hook*
  47         (compile nil #'(lambda (fn form env)
  48                          (when (eq form '.foo.)
  49                            (setq expanded-p t))
  50                          (funcall fn form env)))))
  51   (multiple-value-bind (expansion flag) (macroexpand '.foo.)
  52     (assert (equal expansion '(quote foobar)))
  53     (assert flag)
  54     (assert expanded-p)))
  55
  56 #+(or sb-eval sb-fasteval)
  57 (let ((sb-ext:*evaluator-mode* :interpret))
  58   (let* ((expanded-p nil)
  59          (*macroexpand-hook*
  60           (compile nil #'(lambda (fn form env)
  61                            (when (eq form '.foo.)
  62                              (setq expanded-p t))
  63                            (funcall fn form env)))))
  64     (eval '.foo.)
  65     (assert expanded-p)))
  66
  67 (let* ((expanded-p nil)
  68        (*macroexpand-hook*
  69         (compile nil #'(lambda (fn form env)
  70                          (when (eq form '/foo/)
  71                            (setq expanded-p t))
  72                          (funcall fn form env)))))
  73   (compile nil '(lambda ()
  74                  (symbol-macrolet ((/foo/ 'foobar))
  75                    (macrolet ((expand (symbol &environment env)
  76                                 (macroexpand symbol env)))
  77                      (expand /foo/)))))
  78   (assert expanded-p))
  79
  80 ;; Check that DEFINE-SYMBOL-MACRO on a variable whose global :KIND
  81 ;; was :ALIEN gets a sane error message instead of ECASE failure.
  82 (sb-alien:define-alien-variable ("posix_argv" foo-argv) (* (* char)))
  83 (handler-case (define-symbol-macro foo-argv (silly))
  84   (error (e)
  85     (assert (string= "Symbol FOO-ARGV is already defined as an alien variable."
  86                      (write-to-string e :escape nil))))
  87   (:no-error () (error "Expected an error")))
  88
  89 (with-test (:name :binding*-expander)
  90 (assert (equal (macroexpand-1
  91                 '(sb-int:binding* (((foo x bar zz) (f) :exit-if-null)
  92                                    ((baz y) (g bar)))
  93                   (declare (integer x foo) (special foo y))
  94                   (declare (special zz bar l) (real q foo))
  95                   (thing)))
  96                '(MULTIPLE-VALUE-BIND (FOO X BAR ZZ) (F)
  97                  (DECLARE
  98                   (INTEGER X FOO) (SPECIAL FOO) (SPECIAL ZZ BAR) (REAL FOO))
  99                  (WHEN FOO (MULTIPLE-VALUE-BIND (BAZ Y) (G BAR)
 100                              (DECLARE (SPECIAL Y))
 101                              (DECLARE (SPECIAL L) (REAL Q)) (THING))))))
 102
 103 (assert (equal (macroexpand-1
 104                 '(sb-int:binding* (((x y) (f))
 105                                    (x (g y x)))
 106                   (declare (integer x))
 107                   (foo)))
 108                '(MULTIPLE-VALUE-BIND (X Y) (F)
 109                  (LET* ((X (G Y X)))
 110                    (DECLARE (INTEGER X))
 111                    (FOO)))))
 112
 113 ;; The conversion of a trailing sequence of individual bindings
 114 ;; into one LET* failed to remove declarations that were already
 115 ;; injected pertinent to ealier bound variables.
 116 (assert (equal-mod-gensyms
 117          (macroexpand-1
 118           '(sb-int:binding* (((v1 v2 nil) (foo))
 119                              (a (f v1))
 120                              (b (g v2)))
 121             (declare (special fred) (optimize speed)
 122                      (optimize (debug 3)))
 123             (declare (integer v1 v2))
 124             (body)))
 125          '(multiple-value-bind (v1 v2 #1=#:g538) (foo)
 126            (declare (integer v1 v2))
 127            (declare (ignorable #1#))
 128            (let* ((a (f v1)) (b (g v2)))
 129              (declare (special fred) (optimize speed) (optimize (debug 3)))
 130              (body)))))
 131
 132 ;; :EXIT-IF-NULL was inserting declarations into the WHEN expression.
 133 (assert (equal-mod-gensyms
 134          (macroexpand-1
 135           '(sb-int:binding* (((a1 a2) (f))
 136                              (b (g))
 137                              ((c1 nil c2) (h) :exit-if-null)
 138                              ((d1 d1) (f))
 139                              (nil (e) :exit-if-null))
 140             (declare (special fff c2) (integer d1))
 141             (declare (fixnum a2)
 142                      (special *x* *y* c1))
 143             (declare (cons b) (type integer *y* a1))
 144             (a-body-form)
 145             (another-body-form)))
 146          '(multiple-value-bind (a1 a2) (f)
 147            (declare (fixnum a2) (type integer a1))
 148            (let* ((b (g)))
 149              (declare (cons b))
 150              (multiple-value-bind (c1 #2=#:dummy-1 c2) (h)
 151                (declare (special c2) (special c1))
 152                (declare (ignorable #2#))
 153                (when c1
 154                  (multiple-value-bind (d1 d1) (f)
 155                    (declare (integer d1))
 156                    (let* ((#3=#:dummy-2 (e)))
 157                      (declare (ignorable #3#))
 158                      (declare (special fff))
 159                      (declare (special *y* *x*))
 160                      (declare (type integer *y*))
 161                      (when #3#
 162                        (a-body-form) (another-body-form))))))))))
 163
 164 ) ; end BINDING*-EXPANDER test
 165
 166 (eval-when (:compile-toplevel :load-toplevel :execute)
 167   (import '(sb-int:&more sb-int:parse-lambda-list)))
 168
 169 (with-test (:name :parse-lambda-list)
 170   ;; 3.4.1 - ordinary lambda list
 171   (assert-error (parse-lambda-list '(foo &body bar)))
 172   (assert-error (parse-lambda-list '(foo &whole bar)))
 173   (assert-error (parse-lambda-list '(foo &environment bar)))
 174   ;; &more expects exactly two following symbols
 175   (assert-error (parse-lambda-list '(foo &more)))
 176   (assert-error (parse-lambda-list '(foo &more c)))
 177   (assert-error (parse-lambda-list '(foo &more ctxt ct junk)))
 178   ;; &more and &rest are mutually exclusive
 179   (assert-error (parse-lambda-list '(foo &rest foo &more ctxt n)))
 180   (assert-error (parse-lambda-list '(foo &more ctxt n &rest foo)))
 181
 182   ;; 3.4.2 - generic function lambda lists
 183   (macroexpand-1 '(defgeneric foo (a b &key size &allow-other-keys)))
 184   (assert-error (macroexpand-1 '(defgeneric foo (a b &aux x)))
 185                 sb-pcl::generic-function-lambda-list-error)
 186   ;; 3.4.3 - FIXME: add tests
 187
 188   ;; 3.4.4 - doesn't use PARSE-LAMBDA-LIST yet
 189   ;; 3.4.5 - same
 190
 191   ;; 3.4.6 - BOA lambda list is a function lambda list,
 192   ;; but the expander silently disregarded the internal &MORE keyword,
 193   ;; which has no place in DEFSTRUCT.
 194   (assert-error
 195    (macroexpand-1 '(defstruct (s (:constructor
 196                                   make-s (a b &more ctxt n)))
 197                     a b ctxt n)))
 198
 199   ;; 3.4.7 - DEFSETF disallows &AUX
 200   (assert-error (macroexpand-1
 201                  '(defsetf foof (a b &optional k &aux) (v1 v2) (forms))))
 202
 203   ;; 3.4.8 - DEFTYPE is exactly like DEFMACRO
 204   ;;         except for the implied default-default of '*
 205
 206   ;; 3.4.9 - DEFINE-MODIFY-MACRO allows only &OPTIONAL and &REST
 207   (assert-error (macroexpand-1
 208                  '(define-modify-macro foof (a b &optional k &key) foo)))
 209   (assert-error (macroexpand-1
 210                  '(define-modify-macro foof (a b &optional k &body) foo)))
 211
 212   ;; 3.4.10 - DEFINE-METHOD-COMBINATION. Not even sure what this does.
 213
 214   )
 215
 216 (defstruct foo (a 0 :type fixnum))
 217 (defstruct bar (a 0 :type fixnum))
 218 (declaim (notinline (setf bar-a)))
 219 ;; This macro definition is technically violating the dynamic-extent
 220 ;; nature of environment objects (as per X3J13), but of course ours don't.
 221 (defmacro capture-env (&environment e &rest r)
 222   (declare (ignore r))
 223   e)
 224 (with-test (:name :macroexpand-of-setf-structure-access)
 225   (assert (equal (macroexpand-1 '(setf (foo-a x) 3))
 226                  `(sb-kernel:%instance-set (the foo x)
 227                                            ,sb-vm:instance-data-start
 228                                            (the fixnum 3))))
 229
 230   ;; Lexical definition of (SETF FOO-A) inhibits source-transform.
 231   ;; This is not required behavior - SETF of structure slots
 232   ;; do not necessarily go through a function named (SETF your-slot),
 233   ;; but it's this implementation's behavior, so should be asserted.
 234   (flet (((setf foo-a) (new obj) (declare (ignore obj)) new))
 235     (assert (equal-mod-gensyms
 236              (macroexpand-1 '(setf (foo-a x) 3) (capture-env))
 237              '(let* ((#1=#:x x) (new 3)) (funcall #'(setf foo-a) new #1#)))))
 238
 239   ;; Same, not required behavior - NOTINLINE inhibits transform.
 240   (assert (equal-mod-gensyms
 241            (macroexpand-1 '(setf (bar-a x) 3))
 242            '(let* ((#2=#:x x) (new 3)) (funcall #'(setf bar-a) new #2#)))))
 243 \f
 244 ;;; WITH-CURRENT-SOURCE-FORM tests
 245
 246 (defmacro warnings-in-subforms (a b)
 247   (with-current-source-form (a)
 248     (warn "a warning"))
 249   (with-current-source-form (b)
 250     (warn "a warning"))
 251   `(progn ,a ,b))
 252
 253 (with-test (:name (with-current-source-form :smoke))
 254   (labels ((call-capturing-source-paths (thunk)
 255              (let ((source-paths '()))
 256                (handler-bind
 257                    ((condition (lambda (condition)
 258                                  (let ((context (sb-c::find-error-context nil)))
 259                                    (push (sb-c::compiler-error-context-original-source-path
 260                                           context)
 261                                          source-paths))
 262                                  (muffle-warning condition))))
 263                  (funcall thunk))
 264                (nreverse source-paths)))
 265            (compile-capturing-source-paths (form)
 266              (call-capturing-source-paths
 267               (lambda () (compile nil form)))))
 268
 269     (assert (equal (compile-capturing-source-paths
 270                     '(lambda () (warnings-in-subforms 1 2)))
 271                    '((2 0) (2 0))))
 272     (assert (equal (compile-capturing-source-paths
 273                     '(lambda () (warnings-in-subforms (progn 1) (progn 2))))
 274                    '((1 2 0) (2 2 0))))
 275     (assert (equal (compile-capturing-source-paths
 276                     '(lambda ()
 277                       (warnings-in-subforms
 278                        (warnings-in-subforms (progn 1) (progn 2))
 279                        (progn 3))))
 280                    '((1 2 0) (2 2 0) (1 1 2 0) (2 1 2 0))))))