1.0.46.9: detect invalid use of :PREDICATE with DEFSTRUCT :TYPE

 Based on patch by Roman Marynchak, lp#520607.

 In case there are :TYPE and :PREDICATE options specified, :NAMED DEFSTRUCT
 option should be specified too. To check this, add the flag for :PREDICATE
 option in the function SB-KERNEL::PARSE-DEFSTRUCT-NAME-AND-OPTIONS, and
 verify that the flag is set, :TYPEP is set but :NAMED option is not provided.

 Also includes the regression test.

diff --git a/NEWS b/NEWS
index 9934248..5a7faef 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,8 @@ changes relative to sbcl-1.0.46:
     x86-64 builds caused a type-error.
   * bug fix: calling COMPILE with something else than a lambda-expression as the
     second argument reports a more sensible error. (lp#718905)
+  * bug fix: invalid combinations of :PREDICATE and :TYPE options in DEFSTRUCT
+    are detected. (lp#520607)
 
 changes in sbcl-1.0.46 relative to sbcl-1.0.45:
   * enhancement: largefile support on Solaris.

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 3d3e32c..fba213a 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -615,11 +615,14 @@
 (defun parse-defstruct-name-and-options (name-and-options)
   (destructuring-bind (name &rest options) name-and-options
     (aver name) ; A null name doesn't seem to make sense here.
-    (let ((dd (make-defstruct-description name)))
+    (let ((dd (make-defstruct-description name))
+          (predicate-named-p nil))
       (dolist (option options)
         (cond ((eq option :named)
                (setf (dd-named dd) t))
               ((consp option)
+               (when (and (eq (car option) :predicate) (second option))
+                 (setf predicate-named-p t))
                (parse-1-dd-option option dd))
               ((member option '(:conc-name :constructor :copier :predicate))
                (parse-1-dd-option (list option) dd))
@@ -639,6 +642,9 @@
            ;; make that messy, alas.)
            (incf (dd-length dd))))
         (t
+         ;; In case we are here, :TYPE is specified.
+         (when (and predicate-named-p (not (dd-named dd)))
+           (error ":PREDICATE cannot be used with :TYPE unless :NAMED is also specified."))
          (require-no-print-options-so-far dd)
          (when (dd-named dd)
            (incf (dd-length dd)))

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index e84e4f3..1354ab6 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -1071,3 +1071,15 @@ redefinition."
     (handler-bind ((style-warning #'error))
       (eval `(defstruct (bug-528807 (:constructor make-528807 (&aux x)))
                (x nil :type fixnum))))))
+
+(with-test (:name :bug-520607)
+  (assert
+    (raises-error?
+      (eval '(defstruct (typed-struct (:type list) (:predicate typed-struct-p))
+              (a 42 :type fixnum)))))
+  ;; NIL is ok, though.
+  (eval '(defstruct (typed-struct (:type list) (:predicate nil))
+          (a 42 :type fixnum)))
+  ;; So's empty.
+  (eval '(defstruct (typed-struct2 (:type list) (:predicate))
+          (a 42 :type fixnum))))

diff --git a/version.lisp-expr b/version.lisp-expr
index ec8bd49..d0a2090 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,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.46.8"
+"1.0.46.9"