tests/progv.pure.lisp

   1 (defvar *mysym*)
   2 (declaim (fixnum *mysym*))
   3
   4 (defun f-unsafe (list-of-syms list-of-vals thunk)
   5   (declare (optimize (safety 0)))
   6   (progv list-of-syms list-of-vals
   7     (funcall thunk)))
   8
   9 (compile 'f-unsafe)
  10
  11 (with-test (:name :unsafe-progv-no-typecheck)
  12   (f-unsafe '(*mysym*) '("hi")
  13    (lambda ()
  14      (assert (stringp (symbol-value (opaque-identity '*mysym*))))))
  15   (assert (logtest (sb-kernel:get-header-data '*mysym*)
  16                    sb-vm::+symbol-fast-bindable+)))
  17
  18 (defun f-safe (list-of-syms list-of-vals)
  19   (progv list-of-syms list-of-vals
  20     (opaque-identity 'foo)))
  21 (compile 'f-safe)
  22
  23 (with-test (:name :safe-progv)
  24   ;; first, a package operation should clear the fast-bindable bit
  25   (lock-package cl:*package*)
  26   (unlock-package cl:*package*)
  27   (assert (not (logtest (sb-kernel:get-header-data '*mysym*)
  28                         sb-vm::+symbol-fast-bindable+)))
  29   ;; second, whether fast bindable or not, there should be a type-error
  30   (assert-error (f-safe '(*mysym*) '("hi")))
  31   ;; however, now it's fast-bindable again
  32   (assert (logtest (sb-kernel:get-header-data '*mysym*)
  33                    sb-vm::+symbol-fast-bindable+))
  34   ;; and still gets a type-error
  35   (assert-error (f-safe '(*mysym*) '("hi"))))
  36
  37 (with-test (:name :full-call-to-set-symbol-value-does-not-imply-fast-bindable)
  38   (let ((s (opaque-identity 'flerb)))
  39     (set s 3)
  40     (assert (not (logtest (sb-kernel:get-header-data s) sb-vm::+symbol-fast-bindable+)))))