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 (let* ((expanded-p nil)
  39       (*macroexpand-hook* #'(lambda (fn form env)
  40                               (when (eq form '.foo.)
  41                                 (setq expanded-p t))
  42                               (funcall fn form env))))
  43   (multiple-value-bind (expansion flag) (macroexpand '.foo.)
  44     (assert (equal expansion '(quote foobar)))
  45     (assert flag)
  46     (assert expanded-p)))
  47
  48 #+sb-eval
  49 (let ((sb-ext::*evaluator-mode* :interpret))
  50   (let* ((expanded-p nil)
  51          (*macroexpand-hook* #'(lambda (fn form env)
  52                                  (when (eq form '.foo.)
  53                                    (setq expanded-p t))
  54                                  (funcall fn form env))))
  55     (eval '.foo.)
  56     (assert expanded-p)))
  57
  58 (let* ((expanded-p nil)
  59        (*macroexpand-hook* #'(lambda (fn form env)
  60                                (when (eq form '/foo/)
  61                                  (setq expanded-p t))
  62                                (funcall fn form env))))
  63   (compile nil '(lambda ()
  64                  (symbol-macrolet ((/foo/ 'foobar))
  65                    (macrolet ((expand (symbol &environment env)
  66                                 (macroexpand symbol env)))
  67                      (expand /foo/)))))
  68   (assert expanded-p))
  69
  70 ;; Check that DEFINE-SYMBOL-MACRO on a variable whose global :KIND
  71 ;; was :ALIEN gets a sane error message instead of ECASE failure.
  72 (sb-alien:define-alien-variable ("posix_argv" foo-argv) (* (* char)))
  73 (handler-case (define-symbol-macro foo-argv (silly))
  74   (error (e)
  75     (assert (string= "Symbol FOO-ARGV is already defined as an alien variable."
  76                      (write-to-string e :escape nil))))
  77   (:no-error () (error "Expected an error")))
  78
  79 (with-test (:name :binding*-expander)
  80 (assert (equal (macroexpand-1
  81                 '(sb-int:binding* (((foo x bar zz) (f) :exit-if-null)
  82                                    ((baz y) (g bar)))
  83                   (declare (integer x foo) (special foo y))
  84                   (declare (special zz bar l) (real q foo))
  85                   (thing)))
  86                '(MULTIPLE-VALUE-BIND (FOO X BAR ZZ) (F)
  87                  (DECLARE
  88                   (INTEGER X FOO) (SPECIAL FOO) (SPECIAL ZZ BAR) (REAL FOO))
  89                  (WHEN FOO (MULTIPLE-VALUE-BIND (BAZ Y) (G BAR)
  90                              (DECLARE (SPECIAL Y))
  91                              (DECLARE (SPECIAL L) (REAL Q)) (THING))))))
  92
  93 (assert (equal (macroexpand-1
  94                 '(sb-int:binding* (((x y) (f))
  95                                    (x (g y x)))
  96                   (declare (integer x))
  97                   (foo)))
  98                '(MULTIPLE-VALUE-BIND (X Y) (F)
  99                  (LET* ((X (G Y X)))
 100                    (DECLARE (INTEGER X))
 101                    (FOO)))))
 102
 103 ;; The conversion of a trailing sequence of individual bindings
 104 ;; into one LET* failed to remove declarations that were already
 105 ;; injected pertinent to ealier bound variables.
 106 (assert (equal-mod-gensyms
 107          (macroexpand-1
 108           '(sb-int:binding* (((v1 v2 nil) (foo))
 109                              (a (f v1))
 110                              (b (g v2)))
 111             (declare (special fred) (optimize speed)
 112                      (optimize (debug 3)))
 113             (declare (integer v1 v2))
 114             (body)))
 115          '(multiple-value-bind (v1 v2 #1=#:g538) (foo)
 116            (declare (integer v1 v2))
 117            (declare (ignorable #1#))
 118            (let* ((a (f v1)) (b (g v2)))
 119              (declare (special fred) (optimize speed) (optimize (debug 3)))
 120              (body)))))
 121
 122 ;; :EXIT-IF-NULL was inserting declarations into the WHEN expression.
 123 (assert (equal-mod-gensyms
 124          (macroexpand-1
 125           '(sb-int:binding* (((a1 a2) (f))
 126                              (b (g))
 127                              ((c1 nil c2) (h) :exit-if-null)
 128                              ((d1 d1) (f))
 129                              (nil (e) :exit-if-null))
 130             (declare (special fff c2) (integer d1))
 131             (declare (fixnum a2)
 132                      (special *x* *y* c1))
 133             (declare (cons b) (type integer *y* a1))
 134             (a-body-form)
 135             (another-body-form)))
 136          '(multiple-value-bind (a1 a2) (f)
 137            (declare (fixnum a2) (type integer a1))
 138            (let* ((b (g)))
 139              (declare (cons b))
 140              (multiple-value-bind (c1 #2=#:dummy-1 c2) (h)
 141                (declare (special c2) (special c1))
 142                (declare (ignorable #2#))
 143                (when c1
 144                  (multiple-value-bind (d1 d1) (f)
 145                    (declare (integer d1))
 146                    (let* ((#3=#:dummy-2 (e)))
 147                      (declare (ignorable #3#))
 148                      (declare (special fff))
 149                      (declare (special *y* *x*))
 150                      (declare (type integer *y*))
 151                      (when #3#
 152                        (a-body-form) (another-body-form))))))))))
 153
 154 ) ; end BINDING*-EXPANDER test
 155
 156 (eval-when (:compile-toplevel :load-toplevel :execute)
 157   (import '(sb-int:&more sb-int:parse-lambda-list)))
 158
 159 (with-test (:name :parse-lambda-list)
 160   ;; 3.4.1 - ordinary lambda list
 161   (assert-error (parse-lambda-list '(foo &body bar)))
 162   (assert-error (parse-lambda-list '(foo &whole bar)))
 163   (assert-error (parse-lambda-list '(foo &environment bar)))
 164   ;; &more expects exactly two following symbols
 165   (assert-error (parse-lambda-list '(foo &more)))
 166   (assert-error (parse-lambda-list '(foo &more c)))
 167   (assert-error (parse-lambda-list '(foo &more ctxt ct junk)))
 168   ;; &more and &rest are mutually exclusive
 169   (assert-error (parse-lambda-list '(foo &rest foo &more ctxt n)))
 170   (assert-error (parse-lambda-list '(foo &more ctxt n &rest foo)))
 171
 172   ;; 3.4.2 - generic function lambda lists
 173   (macroexpand-1 '(defgeneric foo (a b &key size &allow-other-keys)))
 174   (assert-error (macroexpand-1 '(defgeneric foo (a b &aux x)))
 175                 sb-pcl::generic-function-lambda-list-error)
 176   ;; 3.4.3 - FIXME: add tests
 177
 178   ;; 3.4.4 - doesn't use PARSE-LAMBDA-LIST yet
 179   ;; 3.4.5 - same
 180
 181   ;; 3.4.6 - BOA lambda list is a function lambda list,
 182   ;; but the expander silently disregarded the internal &MORE keyword,
 183   ;; which has no place in DEFSTRUCT.
 184   (assert-error
 185    (macroexpand-1 '(defstruct (s (:constructor
 186                                   make-s (a b &more ctxt n)))
 187                     a b ctxt n)))
 188
 189   ;; 3.4.7 - DEFSETF disallows &AUX
 190   (assert-error (macroexpand-1
 191                  '(defsetf foof (a b &optional k &aux) (v1 v2) (forms))))
 192
 193   ;; 3.4.8 - DEFTYPE is exactly like DEFMACRO
 194   ;;         except for the implied default-default of '*
 195
 196   ;; 3.4.9 - DEFINE-MODIFY-MACRO allows only &OPTIONAL and &REST
 197   (assert-error (macroexpand-1
 198                  '(define-modify-macro foof (a b &optional k &key) foo)))
 199   (assert-error (macroexpand-1
 200                  '(define-modify-macro foof (a b &optional k &body) foo)))
 201
 202   ;; 3.4.10 - DEFINE-METHOD-COMBINATION. Not even sure what this does.
 203
 204   )