mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
41 lines
1.4 KiB
Common Lisp
41 lines
1.4 KiB
Common Lisp
(defvar *mysym*)
|
|
(declaim (fixnum *mysym*))
|
|
|
|
(defun f-unsafe (list-of-syms list-of-vals thunk)
|
|
(declare (optimize (safety 0)))
|
|
(progv list-of-syms list-of-vals
|
|
(funcall thunk)))
|
|
|
|
(compile 'f-unsafe)
|
|
|
|
(with-test (:name :unsafe-progv-no-typecheck)
|
|
(f-unsafe '(*mysym*) '("hi")
|
|
(lambda ()
|
|
(assert (stringp (symbol-value (opaque-identity '*mysym*))))))
|
|
(assert (logtest (sb-kernel:get-header-data '*mysym*)
|
|
sb-vm::+symbol-fast-bindable+)))
|
|
|
|
(defun f-safe (list-of-syms list-of-vals)
|
|
(progv list-of-syms list-of-vals
|
|
(opaque-identity 'foo)))
|
|
(compile 'f-safe)
|
|
|
|
(with-test (:name :safe-progv)
|
|
;; first, a package operation should clear the fast-bindable bit
|
|
(lock-package cl:*package*)
|
|
(unlock-package cl:*package*)
|
|
(assert (not (logtest (sb-kernel:get-header-data '*mysym*)
|
|
sb-vm::+symbol-fast-bindable+)))
|
|
;; second, whether fast bindable or not, there should be a type-error
|
|
(assert-error (f-safe '(*mysym*) '("hi")))
|
|
;; however, now it's fast-bindable again
|
|
(assert (logtest (sb-kernel:get-header-data '*mysym*)
|
|
sb-vm::+symbol-fast-bindable+))
|
|
;; and still gets a type-error
|
|
(assert-error (f-safe '(*mysym*) '("hi"))))
|
|
|
|
(with-test (:name :full-call-to-set-symbol-value-does-not-imply-fast-bindable)
|
|
(let ((s (opaque-identity 'flerb)))
|
|
(set s 3)
|
|
(assert (not (logtest (sb-kernel:get-header-data s) sb-vm::+symbol-fast-bindable+)))))
|