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 (assert (equal (macroexpand-1
  80                 '(sb-int:binding* (((foo x bar zz) (f) :exit-if-null)
  81                                    ((baz y) (g bar)))
  82                   (declare (integer x foo) (special foo y))
  83                   (declare (special zz bar l) (real q foo))
  84                   (thing)))
  85                '(MULTIPLE-VALUE-BIND (FOO X BAR ZZ) (F)
  86                  (DECLARE
  87                   (INTEGER X FOO) (SPECIAL FOO) (SPECIAL ZZ BAR) (REAL FOO))
  88                  (WHEN FOO (MULTIPLE-VALUE-BIND (BAZ Y) (G BAR)
  89                              (DECLARE (SPECIAL Y))
  90                              (DECLARE (SPECIAL L) (REAL Q)) (THING))))))
  91
  92 (assert (equal (macroexpand-1
  93                 '(sb-int:binding* (((x y) (f))
  94                                    (x (g y x)))
  95                   (declare (integer x))
  96                   (foo)))
  97                '(MULTIPLE-VALUE-BIND (X Y) (F)
  98                  (LET* ((X (G Y X)))
  99                    (DECLARE (INTEGER X))
 100                    (FOO)))))