From 960a9fbd48e695e5b970a01315aa687ab59dc3fe Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 30 Jul 2008 13:51:55 +0000 Subject: [PATCH] 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. --- NEWS | 4 ++++ src/code/early-extensions.lisp | 15 +++++++++++++-- src/code/symbol.lisp | 2 +- src/compiler/ir2tran.lisp | 20 +++++++++++++------- tests/compiler.impure.lisp | 7 +++++++ version.lisp-expr | 2 +- 6 files changed, 39 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index 06c67fd..5735d36 100644 --- 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 --- 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 --- 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 --- 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 --- 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)) ;;;; 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 --- 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" -- 1.7.10.4