(in-package "SB!IMPL")
-(declaim (maybe-inline get get2 get3 %put getf remprop %putf get-properties keywordp))
+(declaim (maybe-inline get get3 %put getf remprop %putf get-properties keywordp))
(defun symbol-value (symbol)
#!+sb-doc
(declare (optimize (safety 1)))
(symbol-value symbol))
+#-sb-xc-host
+(define-compiler-macro symbol-value (&whole form symbol &environment env)
+ (when (sb!xc:constantp symbol env)
+ (let ((name (constant-form-value symbol env)))
+ (when (symbolp name)
+ (check-deprecated-variable name))))
+ form)
+
(defun boundp (symbol)
#!+sb-doc
"Return non-NIL if SYMBOL is bound to a value."
(declaim (inline %makunbound))
(defun %makunbound (symbol)
- (%set-symbol-value symbol (%primitive sb!c:make-other-immediate-type
- 0 sb!vm:unbound-marker-widetag)))
+ (%set-symbol-value symbol (%primitive sb!c:make-unbound-marker)))
(defun makunbound (symbol)
#!+sb-doc
is found, return the associated value, else return DEFAULT."
(get3 symbol indicator default))
-(defun get2 (symbol indicator)
- (get3 symbol indicator nil))
-#|
- (let (cdr-pl)
- (do ((pl (symbol-plist symbol) (cdr cdr-pl)))
- ((atom pl) nil)
- (setf cdr-pl (cdr pl))
- (cond ((atom cdr-pl)
- (error "~S has an odd number of items in its property list."
- symbol))
- ((eq (car pl) indicator)
- (return (car cdr-pl)))))))
-|#
-
(defun get3 (symbol indicator default)
(let (cdr-pl)
(do ((pl (symbol-plist symbol) (cdr cdr-pl)))
(defun getf (place indicator &optional (default ()))
#!+sb-doc
- "Search the property list stored in Place for an indicator EQ to INDICATOR.
+ "Search the property list stored in PLACE for an indicator EQ to INDICATOR.
If one is found, return the corresponding value, else return DEFAULT."
(do ((plist place (cddr plist)))
((null plist) default)
\f
;;;; GENSYM and friends
+(defun %make-symbol-name (prefix counter)
+ (with-output-to-string (s)
+ (write-string prefix s)
+ (%output-integer-in-base counter 10 s)))
+
(defvar *gensym-counter* 0
#!+sb-doc
"counter for generating unique GENSYM symbols")
(let ((new (etypecase old
(index (1+ old))
(unsigned-byte (1+ old)))))
- (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
+ (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
(setq *gensym-counter* new)))
(multiple-value-bind (prefix int)
(etypecase thing
(simple-string (values thing old))
- (fixnum (values "G" thing))
+ (unsigned-byte (values "G" thing))
(string (values (coerce thing 'simple-string) old)))
(declare (simple-string prefix))
- (make-symbol
- (concatenate 'simple-string prefix
- (the simple-string
- (quick-integer-to-string int)))))))
+ (make-symbol (%make-symbol-name prefix int)))))
(defvar *gentemp-counter* 0)
(declaim (type unsigned-byte *gentemp-counter*))
#!+sb-doc
"Creates a new symbol interned in package PACKAGE with the given PREFIX."
(declare (type string prefix))
- (loop
- (let ((*print-base* 10)
- (*print-radix* nil)
- (*print-pretty* nil)
- (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*))))
- (multiple-value-bind (symbol existsp) (find-symbol new-pname package)
- (declare (ignore symbol))
- (unless existsp (return (values (intern new-pname package))))))))
+ (loop for name = (%make-symbol-name prefix (incf *gentemp-counter*))
+ while (nth-value 1 (find-symbol name package))
+ finally (return (values (intern name package)))))
+
+;;; This function is to be called just before a change which would affect the
+;;; symbol value. We don't absolutely have to call this function before such
+;;; changes, since such changes to constants are given as undefined behavior,
+;;; it's nice to do so. To circumvent this you need code like this:
+;;;
+;;; (defvar foo)
+;;; (defun set-foo (x) (setq foo x))
+;;; (defconstant foo 42)
+;;; (set-foo 13)
+;;; 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) bind)
+ (declare (symbol symbol))
+ (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 (describe-action) symbol new-value spec)
+ :datum new-value
+ :expected-type spec))))))))
+ (values))
projects / sbcl.git / blobdiff