X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsymbol.lisp;h=5ef0d7bbb3225f6eaec4a646ae840c4ec10a2ab5;hb=1540c1c1d517c58fa9a41629beb65cdce7dfafb6;hp=f2f7f35a6aafa5c60043491e4cea14fd4d4a5804;hpb=eee9d17abd872b55db3d9ab5b9b6fdc923c00cb2;p=sbcl.git

diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index f2f7f35..5ef0d7b 100644
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -23,6 +23,14 @@
   (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."
@@ -52,8 +60,7 @@ distinct from the global value. Can also be SETF."
 
 (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
@@ -274,7 +281,7 @@ distinct from the global value. Can also be SETF."
     (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 (%make-symbol-name prefix int)))))
@@ -289,3 +296,54 @@ distinct from the global value. Can also be SETF."
   (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))