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.

diff --git a/NEWS b/NEWS
index 06c67fd..5735d36 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,10 @@ changes in sbcl-1.0.20 relative to 1.0.19:
     Halik)
   * bug fix: non-local exit from a WITH-ALIEN form no longer causes
     alien-stack leakage. (reported by Andy Hefner)
+  * bug fix: PROGV signals an error when an attempt to violate declared
+    type of a variable or bind a constant is made.
+  * bug fix: SET signals an error when an attempt to violate declared
+    type of a variable is made.
 
 changes in sbcl-1.0.19 relative to 1.0.18:
   * new feature: user-customizable variable SB-EXT:*MUFFLED-WARNINGS*;

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index ac0552d..61794ec 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -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

diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp
index 10fd742..58f3fc1 100644 (file)
--- a/src/code/symbol.lisp
+++ b/src/code/symbol.lisp
@@ -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)

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 28a74da..947389f 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1430,17 +1430,23 @@
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))
-                          (dolist (var vars)
-                            (%primitive bind nil var)
-                            (makunbound var)))
+                          (let ((unbound-marker (%primitive make-other-immediate-type
+                                                            0 sb!vm:unbound-marker-widetag)))
+                            (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")
+                              (%primitive bind unbound-marker var))))
                         (,bind (vars vals)
                           (declare (optimize (speed 2) (debug 0)))
                           (cond ((null vars))
                                 ((null vals) (,unbind vars))
-                                (t (%primitive bind
-                                               (car vals)
-                                               (car vars))
-                                   (,bind (cdr vars) (cdr vals))))))
+                                (t
+                                 (let ((val (car vals))
+                                       (var (car vars)))
+                                   (about-to-modify-symbol-value var "bind ~S" val)
+                                   (%primitive bind val var))
+                                 (,bind (cdr vars) (cdr vals))))))
                  (,bind ,vars ,vals))
                nil
                ,@body)

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 84dd848..a508073 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -928,6 +928,13 @@
     (eval '(labels ((%f (&key x) x)) (%f nil nil)))
   (error (c) :good)
   (:no-error (val) (error "no error: ~S" val)))
+
+;;; PROGV must not bind constants, or violate declared types -- ditto for SET.
+(assert (raises-error? (set pi 3)))
+(assert (raises-error? (progv '(pi s) '(3 pi) (symbol-value x))))
+(declaim (cons *special-cons*))
+(assert (raises-error? (set '*special-cons* "nope") type-error))
+(assert (raises-error? (progv '(*special-cons*) '("no hope") (car *special-cons*)) type-error))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

diff --git a/version.lisp-expr b/version.lisp-expr
index 57e47ab..73bd3c9 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; 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.19.2"
+"1.0.19.3"