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