From 4d916cef2d46a714ae203aee49e601b9bc81f113 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 20 Jun 2011 00:09:24 +0300 Subject: [PATCH] move ABOUT-TO-MODIFY-SYMBOL-VALUE to symbol.lisp Doesn't really belong in early-extensions.lisp. --- src/code/early-extensions.lisp | 51 ---------------------------------------- src/code/symbol.lisp | 51 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 51 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index b35eb8e..0927619 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -777,57 +777,6 @@ (char= #\* (aref name 0)) (char= #\* (aref name (1- (length name)))))))) -;;; 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 "~@" - :format-arguments (list (describe-action) symbol new-value spec) - :datum new-value - :expected-type spec)))))))) - (values)) - ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary ;;; assignment instead of doing cold static linking. That way things like ;;; (FLET ((FROB (X) ..)) diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index f2f7f35..6210a6d 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -289,3 +289,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 "~@" + :format-arguments (list (describe-action) symbol new-value spec) + :datum new-value + :expected-type spec)))))))) + (values)) -- 1.7.10.4