[prev in list] [next in list] [prev in thread] [next in thread] 

List:       sbcl-commits
Subject:    [Sbcl-commits] CVS: sbcl/src/code early-extensions.lisp, 1.94,
From:       Nikodemus Siivola <demoss () users ! sourceforge ! net>
Date:       2008-07-30 13:51:58
Message-ID: E1KOC5u-0003hK-MQ () sc8-pr-cvs8 ! sourceforge ! net
[Download RAW message or body]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14190/src/code

Modified Files:
	early-extensions.lisp symbol.lisp 
Log Message:
1.0.19.3: more careful PROGV and SET

 * Don't bind constants in PROGV.

 * Check variable types before binding / assignment.

 * When un-binding, PROGV doesn't temporarily bind a variable to NIL
   anymore, but directly to the unbound marker, so that an interrupt
   handler cannot see a bogus value.

 * Based on patch by Richard Kreuter.


Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.94
retrieving revision 1.95
diff -u -d -r1.94 -r1.95
--- early-extensions.lisp	4 Jun 2008 12:39:40 -0000	1.94
+++ early-extensions.lisp	30 Jul 2008 13:51:55 -0000	1.95
@@ -767,7 +767,7 @@
 ;;;   foo => 13, (constantp 'foo) => t
 ;;;
 ;;; ...in which case you frankly deserve to lose.
-(defun about-to-modify-symbol-value (symbol action)
+(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep))
   (declare (symbol symbol))
   (multiple-value-bind (what continue)
       (when (eq :constant (info :variable :kind symbol))
@@ -782,7 +782,18 @@
     (when what
       (if continue
           (cerror "Modify the constant." what action symbol)
-          (error 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)
+          (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))))))
   (values))
 
 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary

Index: symbol.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/symbol.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- symbol.lisp	4 Jun 2008 12:39:40 -0000	1.23
+++ symbol.lisp	30 Jul 2008 13:51:56 -0000	1.24
@@ -32,7 +32,7 @@
   #!+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")
+  (about-to-modify-symbol-value symbol "set SYMBOL-VALUE of ~S" new-value)
   (%set-symbol-value symbol new-value))
 
 (defun %set-symbol-value (symbol new-value)


-------------------------------------------------------------------------
This SF.Net email is sponsored by the Moblin Your Move Developer's challenge
Build the coolest Linux based applications with Moblin SDK & win great prizes
Grand prize is a trip for two to an Open Source event anywhere in the world
http://moblin-contest.org/redirect.php?banner_id=100&url=/
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]