tests/defglobal.impure.lisp

   1 ;;;; DEFGLOBAL and related tests
   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 (proclaim '(special *foo*))
  15
  16 (defun eval* (form)
  17   (let ((*evaluator-mode* :interpret))
  18     (eval form)))
  19
  20 (defun unbound-marker ()
  21   (sb-c::%primitive sb-c:make-other-immediate-type 0 sb-vm:unbound-marker-widetag))
  22
  23 (defun assert-foo-not-checked (fun)
  24   (let* ((marker (unbound-marker))
  25          (*foo* marker))
  26     (assert (eq marker (funcall fun)))))
  27
  28 (defun assert-foo-checked (fun)
  29   (let* ((marker (unbound-marker))
  30          (*foo* marker))
  31     (assert (eq :error
  32                 (handler-case
  33                     (funcall fun)
  34                   (unbound-variable (e)
  35                     (assert (eq '*foo* (cell-error-name e)))
  36                     :error))))))
  37
  38 (with-test (:name :unbound-cannot-be-always-bound)
  39   (assert (eq :error
  40               (handler-case
  41                   (proclaim '(sb-ext:always-bound *foo*))
  42                 (error () :error)))))
  43
  44 (set '*foo* t)
  45 (proclaim '(sb-ext:always-bound *foo*))
  46
  47 (defun foo-safe ()
  48   (declare (optimize (safety 3)))
  49   *foo*)
  50
  51 (with-test (:name :always-bound-elides-boundness-checking)
  52   (assert-foo-not-checked #'foo-safe))
  53
  54 (with-test (:name :cannot-unbind-always-bound)
  55   (assert (eq :oops
  56               (handler-case
  57                   (makunbound '*foo*)
  58                 (error () :oops)))))
  59
  60 (defun can-globalize-p (x)
  61   (handler-case
  62       (progn (proclaim `(sb-ext:global ,x)) t)
  63     (error () nil)))
  64
  65 (with-test (:name :cannot-proclaim-special-global)
  66   (assert (not (can-globalize-p '*foo*))))
  67
  68 (define-symbol-macro sm 42)
  69 (with-test (:name :cannot-proclaim-symbol-macro-global)
  70   (assert (not (can-globalize-p 'sm))))
  71
  72 (defconstant con 13)
  73 (with-test (:name :cannot-proclaim-constant-global)
  74   (assert (not (can-globalize-p 'con))))
  75
  76 (with-test (:name :proclaim-global)
  77   (assert (can-globalize-p '.bar.)))
  78
  79 (defun bar1 () .bar.)
  80 (with-test (:name :global-does-not-imply-always-bound)
  81   (assert (eq '.bar.
  82               (handler-case
  83                   (bar1)
  84                 (unbound-variable (e)
  85                   (cell-error-name e))))))
  86
  87 (with-test (:name :set-global)
  88   (setf .bar. 7)
  89   (assert (= 7 (bar1)))
  90   (setf .bar. 123)
  91   (assert (= 123 (bar1))))
  92
  93 (with-test (:name :cannot-bind-globals)
  94   (assert (eq :nope
  95               (handler-case
  96                   (eval* '(let ((.bar. 6)) .bar.))
  97                 (error () :nope))))
  98   (assert (eq :nope
  99              (handler-case
 100                  (funcall (compile nil `(lambda ()
 101                                           (let ((.bar. 5)) .bar.))))
 102                (error () :nope)))))
 103
 104 (with-test (:name :cannot-define-globals-as-symmacs)
 105   (assert (eq :nope
 106               (handler-case
 107                   (eval* '(define-symbol-macro .bar. 0))
 108                 (error () :nope))))
 109   (assert (eq :nope
 110             (handler-case
 111                 (eval* `(symbol-macrolet ((.bar. 11)) .bar.))
 112               (error () :nope))))
 113   (assert (eq :nope
 114               (handler-case
 115                   (funcall (compile nil `(lambda ()
 116                                            (symbol-macrolet ((.bar. 11)) .bar.))))
 117                 (error () :nope)))))
 118
 119 ;;; Cannot proclaim or declare a global as special
 120 (with-test (:name :cannot-declare-global-special)
 121   (assert (eq :nope
 122               (handler-case (proclaim '(special .bar. 666))
 123                 (error () :nope))))
 124   (assert (eq :nope
 125               (handler-case
 126                   (funcall (compile nil `(lambda ()
 127                                            (declare (special .bar.))
 128                                            .bar.)))
 129                 (error () :nope))))
 130   (assert (eq :nope
 131               (handler-case (eval `(locally (declare (special .bar.)) .bar.))
 132                 (error () :nope)))))
 133
 134 ;;; Dead globals get bound checks
 135 (declaim (global this-is-unbound))
 136 (with-test (:name :dead-unbound-global)
 137   (assert (eq :error
 138               (handler-case
 139                   (funcall (compile nil
 140                                     '(lambda ()
 141                                       this-is-unbound
 142                                       42)))
 143                 (unbound-variable ()
 144                   :error)))))
 145
 146 (defun compile-form (form)
 147   (let* ((lisp "defglobal-impure-tmp.lisp"))
 148     (unwind-protect
 149          (progn
 150            (with-open-file (f lisp :direction :output)
 151              (prin1 form f))
 152            (multiple-value-bind (fasl warn fail) (compile-file lisp)
 153              (declare (ignore warn))
 154              (when fail
 155                (error "compiling ~S failed" form))
 156              fasl))
 157       (ignore-errors (delete-file lisp)))))
 158
 159 (defvar *counter*)
 160 (with-test (:name :defconstant-evals)
 161   (let* ((*counter* 0)
 162          (fasl (compile-form `(defglobal .counter-1. (incf *counter*)))))
 163     (assert (= 1 *counter*))
 164     (assert (= 1 (symbol-value '.counter-1.)))
 165     (assert (eq :global (sb-int:info :variable :kind '.counter-1.)))
 166     (unwind-protect
 167          (load fasl)
 168       (ignore-errors (delete-file fasl)))
 169     (assert (= 1 *counter*))
 170     (assert (= 1 (symbol-value '.counter-1.))))
 171
 172   (set '.counter-2. :bound)
 173   (let* ((*counter* 0)
 174          (fasl (compile-form `(defglobal .counter-2. (incf *counter*)))))
 175     (assert (= 0 *counter*))
 176     (assert (eq :bound (symbol-value '.counter-2.)))
 177     (assert (eq :global (sb-int:info :variable :kind '.counter-2.)))
 178     (unwind-protect
 179          (load fasl)
 180       (ignore-errors (delete-file fasl)))
 181     (assert (= 0 *counter*))
 182     (assert (eq :bound (symbol-value '.counter-2.))))
 183
 184   ;; This is a *really* dirty trick...
 185   (let* ((*counter* 0)
 186          (fasl (let ((.counter-3. :nasty))
 187                  (declare (special .counter-3.))
 188                  (compile-form `(defglobal .counter-3. (incf *counter*))))))
 189     (assert (= 0 *counter*))
 190     (assert (not (boundp '.counter-3.)))
 191     (assert (eq :global (sb-int:info :variable :kind '.counter-3.)))
 192     (unwind-protect
 193          (load fasl)
 194       (ignore-errors (delete-file fasl)))
 195     (assert (= 1 *counter*))
 196     (assert (= 1 (symbol-value '.counter-3.)))))
 197
 198 (with-test (:name :defglobal-refers-to-defglobal)
 199   (let ((fasl (compile-form `(progn
 200                                (defglobal **global-1** :fii)
 201                                (defglobal **global-2** **global-1**)))))
 202     (load fasl)
 203     (assert (eq (symbol-value '**global-1**) (symbol-value '**global-2**)))
 204     (assert (eq :fii (symbol-value '**global-1**)))))