tests/eval.impure.lisp

   1 ;;;; various tests of EVAL with 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 ;;;; Note: this stuff gets loaded in (by LOAD) and is therefore
  15 ;;;; evaluated by EVAL, rather than compiled and then loaded; this is
  16 ;;;; why this idiom (a sequence of top-level forms) works as a test of
  17 ;;;; EVAL.
  18
  19 (cl:in-package :cl-user)
  20
  21 (load "assertoid.lisp")
  22 (use-package "ASSERTOID")
  23
  24 ;;; Until sbcl-0.7.9.x, EVAL was not correctly treating LOCALLY,
  25 ;;; MACROLET and SYMBOL-MACROLET, which should preserve top-levelness
  26 ;;; of their body forms:
  27
  28 ;;; LOCALLY
  29 (locally (defstruct locally-struct a (b t)))
  30
  31 (let ((x (make-locally-struct :a 1)))
  32   (assert (eql (locally-struct-a x) 1))
  33   (assert (eql (locally-struct-b x) t)))
  34
  35 (locally
  36   (defmacro locally-macro (x) `(+ ,x 1))
  37   (assert (= (locally-macro 3) 4)))
  38
  39 (locally (declare (special x))
  40   (defun locally-special-test ()
  41     x)
  42   (defun locally-special-test-aux ()
  43     (let ((x 1))
  44       (declare (special x))
  45       (locally-special-test)))
  46   (assert (= (locally-special-test-aux) 1)))
  47
  48 ;;; MACROLET
  49 (macrolet ()
  50   (defstruct macrolet-struct a (b t)))
  51
  52 (let ((x (make-macrolet-struct :a 1)))
  53   (assert (eql (macrolet-struct-a x) 1))
  54   (assert (eql (macrolet-struct-b x) t)))
  55
  56 (macrolet ()
  57   (defmacro macrolet-macro (x) `(+ ,x 1))
  58   (assert (= (macrolet-macro 3) 4)))
  59
  60 (locally (declare (special x))
  61   (defun macrolet-special-test ()
  62     x)
  63   (defun macrolet-special-test-aux ()
  64     (let ((x 1))
  65       (declare (special x))
  66       (macrolet-special-test)))
  67   (assert (= (macrolet-special-test-aux) 1)))
  68
  69 (macrolet ((foo (x) `(macrolet-bar ,x)))
  70   (defmacro macrolet-bar (x) `(+ ,x 1))
  71   (assert (= (foo 1) 2)))
  72
  73 ;;; SYMBOL-MACROLET
  74 (symbol-macrolet ()
  75   (defstruct symbol-macrolet-struct a (b t)))
  76
  77 (let ((x (make-symbol-macrolet-struct :a 1)))
  78   (assert (eql (symbol-macrolet-struct-a x) 1))
  79   (assert (eql (symbol-macrolet-struct-b x) t)))
  80
  81 (symbol-macrolet ()
  82   (defmacro symbol-macrolet-macro (x) `(+ ,x 1))
  83   (assert (= (symbol-macrolet-macro 3) 4)))
  84
  85 (locally (declare (special x))
  86   (defun symbol-macrolet-special-test ()
  87     x)
  88   (defun symbol-macrolet-special-test-aux ()
  89     (let ((x 1))
  90       (declare (special x))
  91       (symbol-macrolet-special-test)))
  92   (assert (= (symbol-macrolet-special-test-aux) 1)))
  93
  94 (symbol-macrolet ((foo (symbol-macrolet-bar 1)))
  95   (defmacro symbol-macrolet-bar (x) `(+ ,x 1))
  96   (assert (= foo 2)))
  97
  98 ;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object
  99 ;;; must return T
 100 (assert (constantp (find-class 'symbol)))
 101 (assert (constantp #p""))
 102
 103 ;;; DEFPARAMETER must assign a dynamic variable
 104 (let ((var (gensym)))
 105   (assert (equal (eval `(list (let ((,var 1))
 106                                 (defparameter ,var 2)
 107                                 ,var)
 108                               ,var))
 109                  '(1 2))))
 110
 111 ;;; Bug 264: SYMBOL-MACROLET did not check for a bound SPECIAL
 112 ;;; declaration
 113 (assert (raises-error? (progv '(foo) '(1)
 114                          (eval '(symbol-macrolet ((foo 3))
 115                                  (declare (special foo))
 116                                  foo)))
 117                        error))
 118
 119 ;;; success
 120 (sb-ext:quit :unix-status 104)