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