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