;;;; -*- coding: utf-8; fill-column: 78 -*-
+ * new feature: SB-EXT:DEFGLOBAL macro allows defining global non-special
+ variables.
+ * new feature: SB-EXT:ALWAYS-BOUND proclamation inhibits MAKUNBOUND, and
+ allows the compiler to safely elide boundedness checks for special
+ variables.
+ * new feature: SB-EXT:GLOBAL proclamation inhibits SPECIAL proclamations for
+ the symbol, prohibits both lexical and dynamic binding. This is mainly an
+ efficiency measure for threaded platforms, but also valueable in
+ expressing intent.
* optimization: compiler now generates faster array typechecking code.
* optimization: ARRAY-DIMENSION is now faster for multidimensional and
non-simple arrays.
Mösenlechner)
* bug fix: the value of CL:- in the inspector was the previous expression
evaluated rather than the expression being evaluated.
+ * bug fix: constants can no longer be locally declared special.
changes in sbcl-1.0.28 relative to 1.0.27:
* a number of bugs in cross-compilation have been fixed, with the ultimate
(declaim (ftype (sfunction
(symbol &optional (or null lexenv))
- (values (member nil :special :lexical :symbol-macro :constant)
+ (values (member nil :special :lexical :symbol-macro :constant :global)
boolean
list))
variable-information))
NAME refers to a named constant defined using DEFCONSTANT, or NAME
is a keyword.
+ :GLOBAL
+ NAME refers to a global variable. (SBCL specific extension.)
+
The second value is true if NAME is bound locally. This is currently
always NIL for special variables, although arguably it should be T
when there is a lexically apparent binding for the special variable.
T if there is explicit type declaration or proclamation associated
with NAME. The type specifier may be equivalent to or a supertype
of the original declaration. If the CDR is T the alist element may
- be omitted."
+ be omitted.
+
+Additionally, the SBCL specific SB-EXT:ALWAYS-BOUND declaration will
+appear with CDR as T if the variable has been declared always bound."
(let* ((*lexenv* (or env (make-null-lexenv)))
+ (kind (info :variable :kind name))
(var (lexenv-find name vars))
binding localp dx ignorep type)
(etypecase var
;; -- though it is _possible_ to declare them ignored, but
;; we don't keep the information around.
(sb-c::global-var
- (setf binding :special
- ;; FIXME: Lexically apparent binding or not?
+ (setf binding (if (eq :global kind)
+ :global
+ :special)
+ ;; FIXME: Lexically apparent binding or not for specials?
localp nil))
(sb-c::constant
(setf binding :constant
(setf binding :symbol-macro
localp t))
(null
- (let ((global-type (info :variable :type name))
- (kind (info :variable :kind name)))
+ (let ((global-type (info :variable :type name)))
(setf binding (case kind
(:macro :symbol-macro)
- (:global nil)
+ (:unknown nil)
(t kind))
type (if (eq *universal-type* global-type)
nil
(when (and type (neq *universal-type* type))
(push (cons 'type (type-specifier type)) alist))
(when dx (push (cons 'dynamic-extent t) alist))
+ (when (info :variable :always-bound name)
+ (push (cons 'sb-ext:always-bound t) alist))
alist))))
(declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
;;;; more information.
(defpackage :sb-cltl2-tests
- (:use :sb-cltl2 :cl :sb-rt))
+ (:use :sb-cltl2 :cl :sb-rt :sb-ext))
(in-package :sb-cltl2-tests)
(var-info #:undefined)
(nil nil nil))
+(declaim (global this-is-global))
+(deftest global-variable
+ (var-info this-is-global)
+ (:global nil nil))
+
+(defglobal this-is-global-too 42)
+(deftest global-variable.2
+ (var-info this-is-global-too)
+ (:global nil ((always-bound . t))))
+
;;;; FUNCTION-INFORMATION
(defmacro fun-info (var &environment env)
(fun-info identity))
(:function nil ((inline . inline)
(ftype function (t) (values t &optional)))))
-
@cindex Efficiency
@menu
-* Slot access::
-* Dynamic-extent allocation::
-* Modular arithmetic::
-* Miscellaneous Efficiency Issues::
+* Slot access::
+* Dynamic-extent allocation::
+* Modular arithmetic::
+* Global and Always-Bound variables::
+* Miscellaneous Efficiency Issues::
@end menu
@node Slot access
64 on Alpha. While it is possible to support smaller widths as well,
currently this is not implemented.
+@node Global and Always-Bound variables
+@comment node-name, next, previous, up
+@section Global and Always-Bound variables
+
+@include macro-sb-ext-defglobal.texinfo
+
+@deftp {Declaration} sb-ext:global
+
+Syntax: @code{(sb-ext:global symbol*)}
+
+Only valid as a global proclamation.
+
+Specifies that the named symbols cannot be proclaimed or locally
+declared @code{special}. Proclaiming an already special or constant
+variable name as @code{global} signal an error. Allows more efficient
+value lookup in threaded environments in addition to expressing
+programmer intention.
+@end deftp
+
+@deftp {Declaration} sb-ext:always-bound
+
+Syntax: @code{(sb-ext:always-bound symbol*)}
+
+Only valid as a global proclamation.
+
+Specifies that the named symbols is always bound. Inhibits @code{makunbound}
+of the named symbols. Proclaiming an unbound symbol as @code{always-bound} signals
+an error. Allows compiler to elide boundness checks from value lookups.
+@end deftp
+
@node Miscellaneous Efficiency Issues
@comment node-name, next, previous, up
@section Miscellaneous Efficiency Issues
"ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP"
"PHYSENV-DEBUG-LIVE-TN" "PHYSENV-LIVE-TN"
"FAST-SYMBOL-VALUE"
+ "FAST-SYMBOL-GLOBAL-VALUE"
"FIND-SAVED-FP-AND-PC"
"FIXUP-NOTE-KIND"
"FIXUP-NOTE-FIXUP"
"DEFCONSTANT-UNEQL" "DEFCONSTANT-UNEQL-NAME"
"DEFCONSTANT-UNEQL-NEW-VALUE" "DEFCONSTANT-UNEQL-OLD-VALUE"
+ ;; global lexicals, access to global symbol values
+ "DEFGLOBAL"
+ "SYMBOL-GLOBAL-VALUE"
+
;; package-locking stuff
#!+sb-package-locks "PACKAGE-LOCKED-P"
#!+sb-package-locks "LOCK-PACKAGE"
"*MUFFLED-WARNINGS*"
;; extended declarations..
- "FREEZE-TYPE" "INHIBIT-WARNINGS"
+ "ALWAYS-BOUND" "FREEZE-TYPE" "GLOBAL" "INHIBIT-WARNINGS"
"MAYBE-INLINE"
;; ..and variables to control compiler policy
"INFINITE-ERROR-PROTECT"
"FIND-CALLER-NAME-AND-FRAME"
"FIND-INTERRUPTED-NAME-AND-FRAME"
- "%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE"
+ "%SET-SYMBOL-VALUE" "%SET-SYMBOL-GLOBAL-VALUE" "%SET-SYMBOL-PACKAGE"
"OUTPUT-SYMBOL-NAME" "%COERCE-NAME-TO-FUN"
"INVOKE-MACROEXPAND-HOOK" "DEFAULT-STRUCTURE-PRINT"
"LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" "DSD-RAW-TYPE"
;;; vectors or not simple.
(macrolet ((def (name table-name)
`(progn
- (defvar ,table-name)
+ (defglobal ,table-name (make-array ,sb!vm:widetag-mask))
(defmacro ,name (array-var)
- `(the function
- (let ((tag 0))
- (when (sb!vm::%other-pointer-p ,array-var)
- (setf tag (%other-pointer-widetag ,array-var)))
- ;; SYMBOL-GLOBAL-VALUE is a performance hack
- ;; for threaded builds.
- (svref (sb!vm::symbol-global-value ',',table-name) tag)))))))
- (def !find-data-vector-setter *data-vector-setters*)
- (def !find-data-vector-setter/check-bounds *data-vector-setters/check-bounds*)
- (def !find-data-vector-reffer *data-vector-reffers*)
- (def !find-data-vector-reffer/check-bounds *data-vector-reffers/check-bounds*))
+ `(the function
+ (let ((tag 0))
+ (when (sb!vm::%other-pointer-p ,array-var)
+ (setf tag (%other-pointer-widetag ,array-var)))
+ (svref ,',table-name tag)))))))
+ (def !find-data-vector-setter **data-vector-setters**)
+ (def !find-data-vector-setter/check-bounds **data-vector-setters/check-bounds**)
+ (def !find-data-vector-reffer **data-vector-reffers**)
+ (def !find-data-vector-reffer/check-bounds **data-vector-reffers/check-bounds**))
(macrolet ((%ref (accessor-getter extra-params)
`(funcall (,accessor-getter array) array index ,@extra-params))
collect `(setf (svref ,symbol ,widetag)
(,deffer ,saetp ,check-form))))))
(defun !hairy-data-vector-reffer-init ()
- (define-reffers *data-vector-reffers* define-reffer
+ (define-reffers **data-vector-reffers** define-reffer
(progn)
#'slow-hairy-data-vector-ref)
- (define-reffers *data-vector-setters* define-setter
+ (define-reffers **data-vector-setters** define-setter
(progn)
#'slow-hairy-data-vector-set)
- (define-reffers *data-vector-reffers/check-bounds* define-reffer
+ (define-reffers **data-vector-reffers/check-bounds** define-reffer
(%check-bound vector (length vector))
#'slow-hairy-data-vector-ref/check-bounds)
- (define-reffers *data-vector-setters/check-bounds* define-setter
+ (define-reffers **data-vector-setters/check-bounds** define-setter
(%check-bound vector (length vector))
#'slow-hairy-data-vector-set/check-bounds)))
(defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
#!+sb-doc
- "Define a global variable at top level. Declare the variable
+ "Defines a special variable at top level. Declare the variable
SPECIAL and, optionally, initialize it. If the variable already has a
value, the old value is not clobbered. The third argument is an optional
documentation string for the variable."
(defsetf %array-dimension %set-array-dimension)
(defsetf sb!kernel:%vector-raw-bits sb!kernel:%set-vector-raw-bits)
#-sb-xc-host (defsetf symbol-value set)
+#-sb-xc-host (defsetf symbol-global-value set-symbol-global-value)
#-sb-xc-host (defsetf symbol-plist %set-symbol-plist)
#-sb-xc-host (defsetf nth %setnth)
#-sb-xc-host (defsetf fill-pointer %set-fill-pointer)
(:special "special variable")
(:macro "symbol macro")
(:constant "constant")
- (:global "undefined variable")
+ (:global "global variable")
+ (:unknown "undefined variable")
(:alien nil))))
(pprint-logical-block (s nil)
(cond
((boundp x)
(format s "~&~@<It is a ~A; its ~_value is ~S.~:>"
wot (symbol-value x)))
- ((not (eq kind :global))
+ ((not (eq kind :unknown))
(format s "~&~@<It is a ~A; no current value.~:>" wot)))
(when (eq (info :variable :where-from x) :declared)
;;; foo => 13, (constantp 'foo) => t
;;;
;;; ...in which case you frankly deserve to lose.
-(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep))
+(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind)
(declare (symbol symbol))
- (multiple-value-bind (what continue)
- (when (eq :constant (info :variable :kind symbol))
- (cond ((eq symbol t)
- (values "Veritas aeterna. (can't ~@?)" nil))
- ((eq symbol nil)
- (values "Nihil ex nihil. (can't ~@?)" nil))
- ((keywordp symbol)
- (values "Can't ~@?." nil))
- (t
- (values "Constant modification: attempt to ~@?." t))))
- (when what
- (if continue
- (cerror "Modify the constant." what action symbol)
- (error what action symbol)))
- (when valuep
- ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
- ;; check.
- (let ((type (info :variable :type symbol)))
- (unless (sb!kernel::%%typep new-value type nil)
- (let ((spec (type-specifier type)))
- (error 'simple-type-error
- :format-control "Cannot ~@? to ~S (not of type ~S.)"
- :format-arguments (list action symbol new-value spec)
- :datum new-value
- :expected-type spec))))))
+ (flet ((describe-action ()
+ (ecase action
+ (set "set SYMBOL-VALUE of ~S")
+ (progv "bind ~S")
+ (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S")
+ (defconstant "define ~S as a constant")
+ (makunbound "make ~S unbound"))))
+ (let ((kind (info :variable :kind symbol)))
+ (multiple-value-bind (what continue)
+ (cond ((eq :constant kind)
+ (cond ((eq symbol t)
+ (values "Veritas aeterna. (can't ~@?)" nil))
+ ((eq symbol nil)
+ (values "Nihil ex nihil. (can't ~@?)" nil))
+ ((keywordp symbol)
+ (values "Can't ~@?." nil))
+ (t
+ (values "Constant modification: attempt to ~@?." t))))
+ ((and bind (eq :global kind))
+ (values "Can't ~@? (global variable)." nil)))
+ (when what
+ (if continue
+ (cerror "Modify the constant." what (describe-action) symbol)
+ (error what (describe-action) symbol)))
+ (when valuep
+ ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
+ ;; check.
+ (let ((type (info :variable :type symbol)))
+ (unless (sb!kernel::%%typep new-value type nil)
+ (let ((spec (type-specifier type)))
+ (error 'simple-type-error
+ :format-control "Cannot ~@? to ~S (not of type ~S.)"
+ :format-arguments (list action (describe-action) new-value spec)
+ :datum new-value
+ :expected-type spec))))))))
(values))
;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
(typecase exp
(symbol
(ecase (info :variable :kind exp)
- ((:special :global :constant)
+ ((:special :global :constant :unknown)
(symbol-value exp))
;; FIXME: This special case here is a symptom of non-ANSI
;; weirdness in SBCL's ALIEN implementation, which could
(cond
((eq type :constant)
;; Horrible place for this, but it works.
- (ip-error "Can't bind constant symbol ~S" symbol))
+ (ip-error "Can't bind constant symbol: ~S" symbol))
+ ((eq type :global)
+ ;; Ditto...
+ (ip-error "Can't bind a global variable: ~S" symbol))
((eq type :special) t)
((member symbol declared-specials :test #'eq)
t)
\f
;;;; DYNAMIC-USAGE and friends
-(declaim (special sb!vm:*read-only-space-free-pointer*
- sb!vm:*static-space-free-pointer*))
-
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro def-c-var-fun (lisp-fun c-var-name)
`(defun ,lisp-fun ()
(,n-old ,old)
(,n-new ,new))
(declare (symbol ,n-symbol))
- (about-to-modify-symbol-value ,n-symbol "compare-and-swap SYMBOL-VALUE of ~S" ,n-new)
+ (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new)
(%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new)))))
(if (sb!xc:constantp name env)
(let ((cname (constant-form-value name env)))
(warn "Problem running ~A hook ~S:~% ~A" kind hook c)
(with-simple-restart (continue "Skip this ~A hook." kind)
(error "Problem running ~A hook ~S:~% ~A" kind hook c)))))))
+
+;;;; DEFGLOBAL
+
+(defmacro-mundanely defglobal (name value &optional (doc nil docp))
+ #!+sb-doc
+ "Defines NAME as a global variable that is always bound. VALUE is evaluated
+and assigned to NAME both at compile- and load-time, but only if NAME is not
+already bound.
+
+Global variables share their values between all threads, and cannot be
+locally bound, declared special, defined as constants, and neither bound
+nor defined as symbol macros.
+
+See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND."
+ `(progn
+ (eval-when (:compile-toplevel)
+ (let ((boundp (boundp ',name)))
+ (%compiler-defglobal ',name (unless boundp ,value) boundp)))
+ (eval-when (:load-toplevel :execute)
+ (let ((boundp (boundp ',name)))
+ (%defglobal ',name (unless boundp ,value) boundp ',doc ,docp
+ (sb!c:source-location))))))
+
+(defun %compiler-defglobal (name value boundp)
+ (sb!xc:proclaim `(global ,name))
+ (unless boundp
+ #-sb-xc-host
+ (set-symbol-global-value name value)
+ #+sb-xc-host
+ (set name value))
+ (sb!xc:proclaim `(always-bound ,name)))
+
+(defun %defglobal (name value boundp doc docp source-location)
+ (%compiler-defglobal name value boundp)
+ (when docp
+ (setf (fdocumentation name 'variable) doc))
+ (sb!c:with-source-location (source-location)
+ (setf (info :source-location :variable name) source-location))
+ name)
(:symbol name "defining ~A as a symbol-macro"))
(sb!c:with-source-location (source-location)
(setf (info :source-location :symbol-macro name) source-location))
- (ecase (info :variable :kind name)
- ((:macro :global nil)
- (setf (info :variable :kind name) :macro)
- (setf (info :variable :macro-expansion name) expansion))
- (:special
- (error 'simple-program-error
- :format-control "Symbol macro name already declared special: ~S."
- :format-arguments (list name)))
- (:constant
- (error 'simple-program-error
- :format-control "Symbol macro name already declared constant: ~S."
- :format-arguments (list name))))
+ (let ((kind (info :variable :kind name)))
+ (ecase kind
+ ((:macro :unknown)
+ (setf (info :variable :kind name) :macro)
+ (setf (info :variable :macro-expansion name) expansion))
+ ((:special :global)
+ (error 'simple-program-error
+ :format-control "Symbol macro name already declared ~A: ~S."
+ :format-arguments (list kind name)))
+ (:constant
+ (error 'simple-program-error
+ :format-control "Symbol macro name already defined as a constant: ~S."
+ :format-arguments (list name)))))
name)
\f
;;;; DEFINE-COMPILER-MACRO
;;;; files for more information.
(in-package "SB!VM")
+
+(declaim (special sb!vm:*read-only-space-free-pointer*
+ sb!vm:*static-space-free-pointer*))
\f
;;;; type format database
#!+sb-doc
"Set SYMBOL's value cell to NEW-VALUE."
(declare (type symbol symbol))
- (about-to-modify-symbol-value symbol "set SYMBOL-VALUE of ~S" new-value)
+ (about-to-modify-symbol-value symbol 'set new-value)
(%set-symbol-value symbol new-value))
(defun %set-symbol-value (symbol new-value)
(%set-symbol-value symbol new-value))
+(defun symbol-global-value (symbol)
+ #!+sb-doc
+ "Return the SYMBOL's current global value. Identical to SYMBOL-VALUE,
+in single-threaded builds: in multithreaded builds bound values are
+distinct from the global value. Can also be SETF."
+ (declare (optimize (safety 1)))
+ (symbol-global-value symbol))
+
+(defun set-symbol-global-value (symbol new-value)
+ (about-to-modify-symbol-value symbol 'set new-value)
+ (sb!kernel:%set-symbol-global-value symbol new-value))
+
(declaim (inline %makunbound))
(defun %makunbound (symbol)
(%set-symbol-value symbol (%primitive sb!c:make-other-immediate-type
#!+sb-doc
"Make SYMBOL unbound, removing any value it may currently have."
(with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A")
- (about-to-modify-symbol-value symbol "make ~S unbound")
+ (when (and (info :variable :always-bound symbol))
+ (error "Can't make ~A variable unbound: ~S" 'always-bound symbol))
+ (about-to-modify-symbol-value symbol 'makunbound)
(%makunbound symbol)
symbol))
;; ensure this is explained in the comment in objdef.lisp
(loadw res symbol symbol-hash-slot other-pointer-lowtag)
(inst bic res #.(ash lowtag-mask -1) res)))
+
+;;; On unithreaded builds these are just copies of the non-global versions.
+(define-vop (%set-symbol-global-value set))
+(define-vop (symbol-global-value symbol-value)
+ (:translate symbol-global-value))
+(define-vop (fast-symbol-global-value fast-symbol-value)
+ (:translate symbol-global-value))
\f
;;;; fdefinition (FDEFN) objects
(unless (or (constant-p v)
(and (global-var-p v)
(member (global-var-kind v)
- '(:global :special))))
+ '(:global :special :unknown))))
(barf "strange *FREE-VARS* entry: ~S" v))
(dolist (n (leaf-refs v))
(check-node-reached n))
(if (boundp name)
(if (typep name '(or boolean keyword))
;; Non-continuable error.
- (about-to-modify-symbol-value name "define ~S as a constant")
+ (about-to-modify-symbol-value name 'defconstant)
(let ((old (symbol-value name)))
(unless (eql value old)
(multiple-value-bind (ignore aborted)
(when aborted
(return-from sb!c::%defconstant name))))))
(warn "redefining a MAKUNBOUND constant: ~S" name)))
- (:global
+ (:unknown
;; (This is OK -- undefined variables are of this kind. So we
;; don't warn or error or anything, just fall through.)
)
\f
;;;; miscellaneous extensions
+(defknown symbol-global-value (symbol) t ())
+(defknown set-symbol-global-value (symbol t) t ())
+
(defknown get-bytes-consed () unsigned-byte (flushable))
(defknown mask-signed-field ((integer 0 *) integer) integer
(movable flushable foldable))
(fopcompilable-p macroexpansion)
;; Punt on :ALIEN variables
(let ((kind (info :variable :kind form)))
- (or (eq kind :special)
- ;; Not really a global, but a variable for
- ;; which no information exists.
- (eq kind :global)
- (eq kind :constant))))))
+ (member kind '(:special :constant :global :unknown))))))
(and (listp form)
(ignore-errors (list-length form))
(multiple-value-bind (macroexpansion macroexpanded-p)
for value = (if (consp binding)
(second binding)
nil)
- ;; Only allow binding lexicals,
- ;; since special bindings can't be
- ;; easily expressed with fops.
+ ;; Only allow binding locals, since special bindings can't
+ ;; be easily expressed with fops.
always (and (eq (info :variable :kind name)
- :global)
+ :unknown)
(let ((*lexenv* (ecase operator
(let orig-lexenv)
(let* *lexenv*))))
;; first data slot, and if you subtract 7 you get a symbol header.
;; also the CAR of NIL-as-end-of-list
- (value :init :unbound :ref-known (flushable) :ref-trans symbol-global-value)
+ (value :init :unbound
+ :set-trans %set-symbol-global-value
+ :set-known (unsafe))
;; also the CDR of NIL-as-end-of-list. Its reffer needs special
;; care for this reason, as hash values must be fixnums.
(hash :set-trans %set-symbol-hash)
(define-info-type
:class :variable
:type :kind
- :type-spec (member :special :constant :macro :global :alien)
+ :type-spec (member :special :constant :macro :global :alien :unknown)
:default (if (typep name '(or boolean keyword))
:constant
- :global))
+ :unknown))
+
+(define-info-type
+ :class :variable
+ :type :always-bound
+ :type-spec boolean
+ :default nil)
;;; the declared type for this variable
(define-info-type
;; we must go through an temporary to avoid gc
(move temp res)))
+;;; On unithreaded builds these are just copies of the non-global versions.
+(define-vop (%set-symbol-global-value set))
+(define-vop (symbol-global-value symbol-value)
+ (:translate symbol-global-value))
+(define-vop (fast-symbol-global-value fast-symbol-value)
+ (:translate symbol-global-value))
\f
;;;; Fdefinition (fdefn) objects.
(program-assert-symbol-home-package-unlocked
context name "binding ~A as a local symbol-macro"))
(let ((kind (info :variable :kind name)))
- (when (member kind '(:special :constant))
+ (when (member kind '(:special :constant :global))
(fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
kind name)))
;; A magical cons that MACROEXPAND-1 understands.
(dolist (lambda lambdas)
(setf (functional-allocator lambda) allocator)))))
-(defmacro with-fun-name-leaf ((leaf thing start &key global) &body body)
+(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body)
`(multiple-value-bind (,leaf allocate-p)
- (if ,global
+ (if ,global-function
(find-global-fun ,thing t)
(fun-name-leaf ,thing))
(if allocate-p
;;; expansions, and doesn't nag about undefined functions.
;;; Used for optimizing things like (FUNCALL 'FOO).
(def-ir1-translator global-function ((thing) start next result)
- (with-fun-name-leaf (leaf thing start :global t)
+ (with-fun-name-leaf (leaf thing start :global-function t)
(reference-leaf start next result leaf)))
(defun constant-global-fun-name (thing)
(with-fun-name-leaf (leaf (second function) start)
(ir1-convert start next result `(,leaf ,@args))))
((eq op 'global-function)
- (with-fun-name-leaf (leaf (second function) start :global t)
+ (with-fun-name-leaf (leaf (second function) start :global-function t)
(ir1-convert start next result `(,leaf ,@args))))
(t
(let ((ctran (make-ctran))
(compiler-style-warn
"~S is being set even though it was declared to be ignored."
name)))
- (if (and (global-var-p leaf) (eq :global (global-var-kind leaf)))
+ (if (and (global-var-p leaf) (eq :unknown (global-var-kind leaf)))
;; For undefined variables go through SET, so that we can catch
;; constant modifications.
(ir1-convert start next result `(set ',name ,value-form))
(compiler-error "The variable ~S occurs more than once in the lambda list."
name))
(let ((kind (info :variable :kind name)))
- (when (or (keywordp name) (eq kind :constant))
- (compiler-error "The name of the lambda variable ~S is already in use to name a constant."
- name))
+ (cond ((or (keywordp name) (eq kind :constant))
+ (compiler-error "The name of the lambda variable ~S is already in use to name a constant."
+ name))
+ ((eq :global kind)
+ (compiler-error "The name of the lambda variable ~S is already in use to name a global variable."
+ name)))
(cond ((eq kind :special)
(let ((specvar (find-free-var name)))
(make-lambda-var :%source-name name
(let ((kind (info :variable :kind name))
(type (info :variable :type name))
(where-from (info :variable :where-from name)))
- (when (and (eq where-from :assumed) (eq kind :global))
+ (when (eq kind :unknown)
(note-undefined-reference name :variable))
(setf (gethash name *free-vars*)
(case kind
;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE
;; which is not flushable, so that unbound dead variables signal
;; an error (bug 412).
- (ir1-convert start next result `(symbol-value ',name))
+ (ir1-convert start next result
+ (if (eq (global-var-kind var) :global)
+ `(symbol-global-value ',name)
+ `(symbol-value ',name)))
(etypecase var
(leaf
(when (lambda-var-p var)
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
+ ;; While CLHS seems to allow local SPECIAL declarations for constants,
+ ;; whatever the semantics are supposed to be is not at all clear to me
+ ;; -- since constants aren't allowed to be bound it should be a no-op as
+ ;; no-one can observe the difference portably, but specials are allowed
+ ;; to be bound... yet nowhere does it say that the special declaration
+ ;; removes the constantness. Call it a spec bug and prohibit it. Same
+ ;; for GLOBAL variables.
+ (let ((kind (info :variable :kind name)))
+ (unless (member kind '(:special :unknown))
+ (error "Can't declare ~(~A~) variable locally special: ~S" kind name)))
(program-assert-symbol-home-package-unlocked
context name "declaring ~A special")
(let ((var (find-in-bindings vars name)))
(let ((unsafe (policy node (zerop safety)))
(name (leaf-source-name leaf)))
(ecase (global-var-kind leaf)
- ((:special :global)
+ ((:special :unknown)
(aver (symbolp name))
(let ((name-tn (emit-constant name)))
- (if unsafe
+ (if (or unsafe (info :variable :always-bound name))
(vop fast-symbol-value node block name-tn res)
(vop symbol-value node block name-tn res))))
+ (:global
+ (aver (symbolp name))
+ (let ((name-tn (emit-constant name)))
+ (if (or unsafe (info :variable :always-bound name))
+ (vop fast-symbol-global-value node block name-tn res)
+ (vop symbol-global-value node block name-tn res))))
(:global-function
(let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
(if unsafe
(vop value-cell-set node block tn val)
(emit-move node block val tn)))))
(global-var
+ (aver (symbolp (leaf-source-name leaf)))
(ecase (global-var-kind leaf)
((:special)
- (aver (symbolp (leaf-source-name leaf)))
- (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
+ (vop set node block (emit-constant (leaf-source-name leaf)) val))
+ ((:global)
+ (vop %set-symbol-global-value node
+ block (emit-constant (leaf-source-name leaf)) val)))))
(when locs
(emit-move node block val (first locs))
(move-lvar-result node block locs lvar)))
(dolist (var vars)
;; CLHS says "bound and then made to have no value" -- user
;; should not be able to tell the difference between that and this.
- (about-to-modify-symbol-value var "bind ~S")
+ (about-to-modify-symbol-value var 'progv)
(%primitive bind unbound-marker var))))
(,bind (vars vals)
(declare (optimize (speed 2) (debug 0)
(t
(let ((val (car vals))
(var (car vars)))
- (about-to-modify-symbol-value var "bind ~S" val)
+ (about-to-modify-symbol-value var 'progv val t)
(%primitive bind val var))
(,bind (cdr vars) (cdr vals))))))
(,bind ,vars ,vals))
(loadw temp symbol symbol-hash-slot other-pointer-lowtag)
(inst srl temp n-fixnum-tag-bits)
(inst sll res temp n-fixnum-tag-bits)))
+
+;;; On unithreaded builds these are just copies of the non-global versions.
+(define-vop (%set-symbol-global-value set))
+(define-vop (symbol-global-value symbol-value)
+ (:translate symbol-global-value))
+(define-vop (fast-symbol-global-value fast-symbol-value)
+ (:translate symbol-global-value))
\f
;;;; Fdefinition (fdefn) objects.
(def!struct (global-var (:include basic-var))
;; kind of variable described
(kind (missing-arg)
- :type (member :special :global-function :global)))
+ :type (member :special :global-function :global :unknown)))
(defprinter (global-var :identity t)
%source-name
#!+sb-show id
;; ensure this is explained in the comment in objdef.lisp
(loadw res symbol symbol-hash-slot other-pointer-lowtag)
(inst clrrwi res res n-fixnum-tag-bits)))
+
+;;; On unithreaded builds these are just copies of the non-global versions.
+(define-vop (%set-symbol-global-value set))
+(define-vop (symbol-global-value symbol-value)
+ (:translate symbol-global-value))
+(define-vop (fast-symbol-global-value fast-symbol-value)
+ (:translate symbol-global-value))
\f
;;;; Fdefinition (fdefn) objects.
(kind (first form))
(args (rest form)))
(case kind
- (special
+ ((special global)
+ (flet ((make-special (name old)
+ (unless (member old '(:special :unknown))
+ (error "Cannot proclaim a ~(~A~) variable special: ~S" old name))
+ (with-single-package-locked-error
+ (:symbol name "globally declaring ~A special")
+ (setf (info :variable :kind name) :special)))
+ (make-global (name old)
+ (unless (member old '(:global :unknown))
+ (error "Cannot proclaim a ~(~A~) variable global: ~S" old name))
+ (with-single-package-locked-error
+ (:symbol name "globally declaring ~A global")
+ (setf (info :variable :kind name) :global))))
+ (let ((fun (if (eq 'special kind) #'make-special #'make-global)))
+ (dolist (name args)
+ (unless (symbolp name)
+ (error "Can't declare a non-symbol as ~S: ~S" kind name))
+ (funcall fun name (info :variable :kind name))))))
+ (always-bound
(dolist (name args)
(unless (symbolp name)
- (error "can't declare a non-symbol as SPECIAL: ~S" name))
+ (error "Can't proclaim a non-symbol as ~S: ~S" kind name))
+ (unless (boundp name)
+ (error "Can't proclaim an unbound symbol as ~S: ~S" kind name))
+ (when (eq :constant (info :variable :kind name))
+ (error "Can't proclaim a constant variable as ~S: ~S" kind name))
(with-single-package-locked-error
- (:symbol name "globally declaring ~A special")
- (about-to-modify-symbol-value name "proclaim ~S as SPECIAL")
- (setf (info :variable :kind name) :special))))
+ (:symbol name "globally declaring ~A always bound")
+ (setf (info :variable :always-bound name) t))))
(type
(if *type-system-initialized*
(let ((type (specifier-type (first args))))
;; ensure this is explained in the comment in objdef.lisp
(loadw res symbol symbol-hash-slot other-pointer-lowtag)
(inst andn res res fixnum-tag-mask)))
+
+;;; On unithreaded builds these are just copies of the non-global versions.
+(define-vop (%set-symbol-global-value set))
+(define-vop (symbol-global-value symbol-value)
+ (:translate symbol-global-value))
+(define-vop (fast-symbol-global-value fast-symbol-value)
+ (:translate symbol-global-value))
\f
;;;; FDEFINITION (fdefn) objects.
(define-vop (fdefn-fun cell-ref)
(inst cmp result unbound-marker-widetag)
(inst jmp :e unbound))))
-;;; these next two cf the sparc version, by jrd.
-;;; FIXME: Deref this ^ reference.
-
-
-;;; The compiler likes to be able to directly SET symbols.
-#!+sb-thread
-(define-vop (set)
- (:args (symbol :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
- (:temporary (:sc descriptor-reg) tls)
- ;;(:policy :fast-safe)
- (:generator 4
- (let ((global-val (gen-label))
- (done (gen-label)))
- (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
- (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
- no-tls-value-marker-widetag)
- (inst jmp :z global-val)
- (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
- value)
- (inst jmp done)
- (emit-label global-val)
- (storew value symbol symbol-value-slot other-pointer-lowtag)
- (emit-label done))))
-
-;; unithreaded it's a lot simpler ...
-#!-sb-thread
-(define-vop (set cell-set)
+(define-vop (%set-symbol-global-value cell-set)
(:variant symbol-value-slot other-pointer-lowtag))
-;;; With Symbol-Value, we check that the value isn't the trap object. So
-;;; Symbol-Value of NIL is NIL.
-#!+sb-thread
-(define-vop (symbol-value)
- (:translate symbol-value)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:result 1)))
- (:results (value :scs (descriptor-reg any-reg)))
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 9
- (let* ((check-unbound-label (gen-label))
- (err-lab (generate-error-code vop 'unbound-symbol-error object))
- (ret-lab (gen-label)))
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst mov value (make-ea :qword :base thread-base-tn
- :index value :scale 1))
- (inst cmp value no-tls-value-marker-widetag)
- (inst jmp :ne check-unbound-label)
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (emit-label check-unbound-label)
- (inst cmp value unbound-marker-widetag)
- (inst jmp :e err-lab)
- (emit-label ret-lab))))
-
-#!+sb-thread
-(define-vop (fast-symbol-value symbol-value)
- ;; KLUDGE: not really fast, in fact, because we're going to have to
- ;; do a full lookup of the thread-local area anyway. But half of
- ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
- ;; unbound", which is used in the implementation of COPY-SYMBOL. --
- ;; CSR, 2003-04-22
+(define-vop (fast-symbol-global-value cell-ref)
+ (:variant symbol-value-slot other-pointer-lowtag)
(:policy :fast)
- (:translate symbol-value)
- (:generator 8
- (let ((ret-lab (gen-label)))
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst mov value
- (make-ea :qword :base thread-base-tn :index value :scale 1))
- (inst cmp value no-tls-value-marker-widetag)
- (inst jmp :ne ret-lab)
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (emit-label ret-lab))))
+ (:translate symbol-global-value))
-#!-sb-thread
-(define-vop (symbol-value)
- (:translate symbol-value)
+(define-vop (symbol-global-value)
(:policy :fast-safe)
+ (:translate symbol-global-value)
(:args (object :scs (descriptor-reg) :to (:result 1)))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(inst cmp value unbound-marker-widetag)
(inst jmp :e err-lab))))
+#!+sb-thread
+(progn
+ (define-vop (set)
+ (:args (symbol :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg)))
+ (:temporary (:sc descriptor-reg) tls)
+ (:generator 4
+ (let ((global-val (gen-label))
+ (done (gen-label)))
+ (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
+ (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
+ no-tls-value-marker-widetag)
+ (inst jmp :z global-val)
+ (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
+ value)
+ (inst jmp done)
+ (emit-label global-val)
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
+ (emit-label done))))
+
+ ;; With Symbol-Value, we check that the value isn't the trap object. So
+ ;; Symbol-Value of NIL is NIL.
+ (define-vop (symbol-value)
+ (:translate symbol-value)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:result 1)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 9
+ (let* ((check-unbound-label (gen-label))
+ (err-lab (generate-error-code vop 'unbound-symbol-error object))
+ (ret-lab (gen-label)))
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst mov value (make-ea :qword :base thread-base-tn
+ :index value :scale 1))
+ (inst cmp value no-tls-value-marker-widetag)
+ (inst jmp :ne check-unbound-label)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (emit-label check-unbound-label)
+ (inst cmp value unbound-marker-widetag)
+ (inst jmp :e err-lab)
+ (emit-label ret-lab))))
+
+ (define-vop (fast-symbol-value symbol-value)
+ ;; KLUDGE: not really fast, in fact, because we're going to have to
+ ;; do a full lookup of the thread-local area anyway. But half of
+ ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
+ ;; unbound", which is used in the implementation of COPY-SYMBOL. --
+ ;; CSR, 2003-04-22
+ (:policy :fast)
+ (:translate symbol-value)
+ (:generator 8
+ (let ((ret-lab (gen-label)))
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst mov value
+ (make-ea :qword :base thread-base-tn :index value :scale 1))
+ (inst cmp value no-tls-value-marker-widetag)
+ (inst jmp :ne ret-lab)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (emit-label ret-lab)))))
+
#!-sb-thread
-(define-vop (fast-symbol-value cell-ref)
- (:variant symbol-value-slot other-pointer-lowtag)
- (:policy :fast)
- (:translate symbol-value))
+(progn
+ (define-vop (symbol-value symbol-global-value)
+ (:translate symbol-value))
+ (define-vop (fast-symbol-value fast-symbol-global-value)
+ (:translate symbol-value))
+ (define-vop (set %set-symbol-global-value)))
#!+sb-thread
(define-vop (boundp)
(inst cmp result unbound-marker-widetag)
(inst jmp :e unbound))))
-;;; these next two cf the sparc version, by jrd.
-;;; FIXME: Deref this ^ reference.
-
-
-;;; The compiler likes to be able to directly SET symbols.
-#!+sb-thread
-(define-vop (set)
- (:args (symbol :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
- (:temporary (:sc descriptor-reg) tls)
- ;;(:policy :fast-safe)
- (:generator 4
- (let ((global-val (gen-label))
- (done (gen-label)))
- (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
- (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs)
- (inst jmp :z global-val)
- (inst mov (make-ea :dword :base tls) value :fs)
- (inst jmp done)
- (emit-label global-val)
- (storew value symbol symbol-value-slot other-pointer-lowtag)
- (emit-label done))))
-
-;; unithreaded it's a lot simpler ...
-#!-sb-thread
-(define-vop (set cell-set)
+(define-vop (%set-symbol-global-value cell-set)
(:variant symbol-value-slot other-pointer-lowtag))
-;;; With Symbol-Value, we check that the value isn't the trap object. So
-;;; Symbol-Value of NIL is NIL.
-#!+sb-thread
-(define-vop (symbol-value)
- (:translate symbol-value)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:result 1)))
- (:results (value :scs (descriptor-reg any-reg)))
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 9
- (let* ((check-unbound-label (gen-label))
- (err-lab (generate-error-code vop 'unbound-symbol-error object))
- (ret-lab (gen-label)))
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst mov value (make-ea :dword :base value) :fs)
- (inst cmp value no-tls-value-marker-widetag)
- (inst jmp :ne check-unbound-label)
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (emit-label check-unbound-label)
- (inst cmp value unbound-marker-widetag)
- (inst jmp :e err-lab)
- (emit-label ret-lab))))
-
-#!+sb-thread
-(define-vop (fast-symbol-value symbol-value)
- ;; KLUDGE: not really fast, in fact, because we're going to have to
- ;; do a full lookup of the thread-local area anyway. But half of
- ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
- ;; unbound", which is used in the implementation of COPY-SYMBOL. --
- ;; CSR, 2003-04-22
+(define-vop (fast-symbol-global-value cell-ref)
+ (:variant symbol-value-slot other-pointer-lowtag)
(:policy :fast)
- (:translate symbol-value)
- (:generator 8
- (let ((ret-lab (gen-label)))
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst mov value (make-ea :dword :base value) :fs)
- (inst cmp value no-tls-value-marker-widetag)
- (inst jmp :ne ret-lab)
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (emit-label ret-lab))))
+ (:translate symbol-global-value))
-#!-sb-thread
-(define-vop (symbol-value)
- (:translate symbol-value)
+(define-vop (symbol-global-value)
(:policy :fast-safe)
+ (:translate symbol-global-value)
(:args (object :scs (descriptor-reg) :to (:result 1)))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(inst cmp value unbound-marker-widetag)
(inst jmp :e err-lab))))
+#!+sb-thread
+(progn
+ (define-vop (set)
+ (:args (symbol :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg)))
+ (:temporary (:sc descriptor-reg) tls)
+ (:generator 4
+ (let ((global-val (gen-label))
+ (done (gen-label)))
+ (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
+ (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs)
+ (inst jmp :z global-val)
+ (inst mov (make-ea :dword :base tls) value :fs)
+ (inst jmp done)
+ (emit-label global-val)
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
+ (emit-label done))))
+
+ ;; With Symbol-Value, we check that the value isn't the trap object. So
+ ;; Symbol-Value of NIL is NIL.
+ (define-vop (symbol-value)
+ (:translate symbol-value)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:result 1)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 9
+ (let* ((check-unbound-label (gen-label))
+ (err-lab (generate-error-code vop 'unbound-symbol-error object))
+ (ret-lab (gen-label)))
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst mov value (make-ea :dword :base value) :fs)
+ (inst cmp value no-tls-value-marker-widetag)
+ (inst jmp :ne check-unbound-label)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (emit-label check-unbound-label)
+ (inst cmp value unbound-marker-widetag)
+ (inst jmp :e err-lab)
+ (emit-label ret-lab))))
+
+ (define-vop (fast-symbol-value symbol-value)
+ ;; KLUDGE: not really fast, in fact, because we're going to have to
+ ;; do a full lookup of the thread-local area anyway. But half of
+ ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
+ ;; unbound", which is used in the implementation of COPY-SYMBOL. --
+ ;; CSR, 2003-04-22
+ (:policy :fast)
+ (:translate symbol-value)
+ (:generator 8
+ (let ((ret-lab (gen-label)))
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst mov value (make-ea :dword :base value) :fs)
+ (inst cmp value no-tls-value-marker-widetag)
+ (inst jmp :ne ret-lab)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (emit-label ret-lab)))))
+
#!-sb-thread
-(define-vop (fast-symbol-value cell-ref)
- (:variant symbol-value-slot other-pointer-lowtag)
- (:policy :fast)
- (:translate symbol-value))
+(progn
+ (define-vop (symbol-value symbol-global-value)
+ (:translate symbol-value))
+ (define-vop (fast-symbol-value fast-symbol-global-value)
+ (:translate symbol-value))
+ (define-vop (set %set-symbol-global-value)))
#!+sb-thread
(define-vop (boundp)
--- /dev/null
+;;;; DEFGLOBAL and related tests
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(proclaim '(special *foo*))
+
+(defun eval* (form)
+ (let ((*evaluator-mode* :interpret))
+ (eval form)))
+
+(defun unbound-marker ()
+ (sb-c::%primitive sb-c:make-other-immediate-type 0 sb-vm:unbound-marker-widetag))
+
+(defun assert-foo-not-checked (fun)
+ (let* ((marker (unbound-marker))
+ (*foo* marker))
+ (assert (eq marker (funcall fun)))))
+
+(defun assert-foo-checked (fun)
+ (let* ((marker (unbound-marker))
+ (*foo* marker))
+ (assert (eq :error
+ (handler-case
+ (funcall fun)
+ (unbound-variable (e)
+ (assert (eq '*foo* (cell-error-name e)))
+ :error))))))
+
+(with-test (:name :unbound-cannot-be-always-bound)
+ (assert (eq :error
+ (handler-case
+ (proclaim '(sb-ext:always-bound *foo*))
+ (error () :error)))))
+
+(set '*foo* t)
+(proclaim '(sb-ext:always-bound *foo*))
+
+(defun foo-safe ()
+ (declare (optimize (safety 3)))
+ *foo*)
+
+(with-test (:name :always-bound-elides-boundness-checking)
+ (assert-foo-not-checked #'foo-safe))
+
+(with-test (:name :cannot-unbind-always-bound)
+ (assert (eq :oops
+ (handler-case
+ (makunbound '*foo*)
+ (error () :oops)))))
+
+(defun can-globalize-p (x)
+ (handler-case
+ (progn (proclaim `(sb-ext:global ,x)) t)
+ (error () nil)))
+
+(with-test (:name :cannot-proclaim-special-global)
+ (assert (not (can-globalize-p '*foo*))))
+
+(define-symbol-macro sm 42)
+(with-test (:name :cannot-proclaim-symbol-macro-global)
+ (assert (not (can-globalize-p 'sm))))
+
+(defconstant con 13)
+(with-test (:name :cannot-proclaim-constant-global)
+ (assert (not (can-globalize-p 'con))))
+
+(with-test (:name :proclaim-global)
+ (assert (can-globalize-p '.bar.)))
+
+(defun bar1 () .bar.)
+(with-test (:name :global-does-not-imply-always-bound)
+ (assert (eq '.bar.
+ (handler-case
+ (bar1)
+ (unbound-variable (e)
+ (cell-error-name e))))))
+
+(with-test (:name :set-global)
+ (setf .bar. 7)
+ (assert (= 7 (bar1)))
+ (setf .bar. 123)
+ (assert (= 123 (bar1))))
+
+(with-test (:name :cannot-bind-globals)
+ (assert (eq :nope
+ (handler-case
+ (eval* '(let ((.bar. 6)) .bar.))
+ (error () :nope))))
+ (assert (eq :nope
+ (handler-case
+ (funcall (compile nil `(lambda ()
+ (let ((.bar. 5)) .bar.))))
+ (error () :nope)))))
+
+(with-test (:name :cannot-define-globals-as-symmacs)
+ (assert (eq :nope
+ (handler-case
+ (eval* '(define-symbol-macro .bar. 0))
+ (error () :nope))))
+ (assert (eq :nope
+ (handler-case
+ (eval* `(symbol-macrolet ((.bar. 11)) .bar.))
+ (error () :nope))))
+ (assert (eq :nope
+ (handler-case
+ (funcall (compile nil `(lambda ()
+ (symbol-macrolet ((.bar. 11)) .bar.))))
+ (error () :nope)))))
+
+;;; Cannot proclaim or declare a global as special
+(with-test (:name :cannot-declare-global-special)
+ (assert (eq :nope
+ (handler-case (proclaim '(special .bar. 666))
+ (error () :nope))))
+ (assert (eq :nope
+ (handler-case
+ (funcall (compile nil `(lambda ()
+ (declare (special .bar.))
+ .bar.)))
+ (error () :nope))))
+ (assert (eq :nope
+ (handler-case (eval `(locally (declare (special .bar.)) .bar.))
+ (error () :nope)))))
+
+;;; Dead globals get bound checks
+(declaim (global this-is-unbound))
+(with-test (:name :dead-unbound-global)
+ (assert (eq :error
+ (handler-case
+ (funcall (compile nil
+ '(lambda ()
+ this-is-unbound
+ 42)))
+ (unbound-variable ()
+ :error)))))
+
+(defun compile-form (form)
+ (let* ((lisp "defglobal-impure-tmp.lisp"))
+ (unwind-protect
+ (progn
+ (with-open-file (f lisp :direction :output)
+ (prin1 form f))
+ (multiple-value-bind (fasl warn fail) (compile-file lisp)
+ (declare (ignore warn))
+ (when fail
+ (error "compiling ~S failed" form))
+ fasl))
+ (ignore-errors (delete-file lisp)))))
+
+(defvar *counter*)
+(with-test (:name :defconstant-evals)
+ (let* ((*counter* 0)
+ (fasl (compile-form `(defglobal .counter-1. (incf *counter*)))))
+ (assert (= 1 *counter*))
+ (assert (= 1 (symbol-value '.counter-1.)))
+ (assert (eq :global (sb-int:info :variable :kind '.counter-1.)))
+ (unwind-protect
+ (load fasl)
+ (ignore-errors (delete-file fasl)))
+ (assert (= 1 *counter*))
+ (assert (= 1 (symbol-value '.counter-1.))))
+
+ (set '.counter-2. :bound)
+ (let* ((*counter* 0)
+ (fasl (compile-form `(defglobal .counter-2. (incf *counter*)))))
+ (assert (= 0 *counter*))
+ (assert (eq :bound (symbol-value '.counter-2.)))
+ (assert (eq :global (sb-int:info :variable :kind '.counter-2.)))
+ (unwind-protect
+ (load fasl)
+ (ignore-errors (delete-file fasl)))
+ (assert (= 0 *counter*))
+ (assert (eq :bound (symbol-value '.counter-2.))))
+
+ ;; This is a *really* dirty trick...
+ (let* ((*counter* 0)
+ (fasl (let ((.counter-3. :nasty))
+ (declare (special .counter-3.))
+ (compile-form `(defglobal .counter-3. (incf *counter*))))))
+ (assert (= 0 *counter*))
+ (assert (not (boundp '.counter-3.)))
+ (assert (eq :global (sb-int:info :variable :kind '.counter-3.)))
+ (unwind-protect
+ (load fasl)
+ (ignore-errors (delete-file fasl)))
+ (assert (= 1 *counter*))
+ (assert (= 1 (symbol-value '.counter-3.)))))
;;; From Matthew Swank on cll 2005-10-06
-(defmacro defglobal (name &optional value)
+(defmacro defglobal* (name &optional value)
(let ((internal (gensym)))
`(progn
(defparameter ,internal ,value)
(define-symbol-macro ,name ,internal))))
-(defglobal glob)
+(defglobal* glob)
(assert (= (let ((glob 4)) glob)))
(assert (null glob))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.28.29"
+"1.0.28.30"
projects / sbcl.git / commitdiff