From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 16 Jul 2007 16:52:52 +0000 (+0000)
Subject: 1.0.7.22: (SETF SYMBOL-PLIST) type checking
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=038ecde3e0386e347550709a199c7f856052c0cd;p=sbcl.git

1.0.7.22: (SETF SYMBOL-PLIST) type checking

 * Disallow non-lists as the new value.
---

diff --git a/NEWS b/NEWS
index 47475d0..d453f74 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,8 @@ changes in sbcl-1.0.8 relative to sbcl-1.0.7:
     variables now works on x86-64.  (reported by Christopher Laux)
   * bug fix: modifications to packages (INTERN, EXPORT, etc) are now
     thread safe.
+  * bug fix: (SETF SYMBOL-PLIST) no longer allows assigning a non-list
+    as the property-list of a symbol.
 
 changes in sbcl-1.0.7 relative to sbcl-1.0.6:
   * MOP improvement: support for user-defined subclasses of
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 46b3aa9..efee375 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1509,7 +1509,7 @@
   :destroyed-constant-args (nth-constant-args 1))
 (defknown %set-symbol-value (symbol t) t (unsafe))
 (defknown (setf symbol-function) (function symbol) function (unsafe))
-(defknown %set-symbol-plist (symbol t) t (unsafe))
+(defknown %set-symbol-plist (symbol list) list (unsafe))
 (defknown (setf fdocumentation) ((or string null) t symbol)
   (or string null)
   ())
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index f4c515d..bf81d29 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -324,6 +324,7 @@
   (plist :ref-trans symbol-plist
          :set-trans %set-symbol-plist
          :cas-trans %compare-and-swap-symbol-plist
+         :type list
          :init :null)
   (name :ref-trans symbol-name :init :arg)
   (package :ref-trans symbol-package
diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index ce4ec85..50c3441 100644
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -136,3 +136,13 @@
                         (assoc x '(nil (a . b) nil (nil . c) (c . d))
                          :test #'eq)))))
   (assert (equal (funcall f 'nil) '(nil . c))))
+
+;;; enforce lists in symbol-plist
+(let ((s (gensym))
+      (l (list 1 3 4)))
+  (assert (not (symbol-plist s)))
+  (assert (eq l (setf (symbol-plist s) l)))
+  (multiple-value-bind (res err)
+      (ignore-errors (setf (symbol-plist s) (car l)))
+    (assert (not res))
+    (assert (typep err 'type-error))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 20b6688..93f0421 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.7.21"
+"1.0.7.22"