[Sbcl-commits] 1.0.46.9: detect invalid use of :PREDICATE with DEFSTRUCT :TYPE

[Nikodemus S. <nik...@ra...>]

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.

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1880
diff -u -r1.1880 NEWS
--- NEWS	20 Feb 2011 10:43:24 -0000	1.1880
+++ NEWS	20 Feb 2011 10:47:31 -0000
@@ -10,6 +10,8 @@
     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.
Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5193
diff -u -r1.5193 version.lisp-expr
--- version.lisp-expr	20 Feb 2011 10:43:24 -0000	1.5193
+++ version.lisp-expr	20 Feb 2011 10:47:31 -0000
@@ -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"
Index: src/code/defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v
retrieving revision 1.102
diff -u -r1.102 defstruct.lisp
--- src/code/defstruct.lisp	2 Sep 2010 08:14:32 -0000	1.102
+++ src/code/defstruct.lisp	20 Feb 2011 10:47:32 -0000
@@ -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)))
Index: tests/defstruct.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/defstruct.impure.lisp,v
retrieving revision 1.38
diff -u -r1.38 defstruct.impure.lisp
--- tests/defstruct.impure.lisp	12 Mar 2010 11:23:12 -0000	1.38
+++ tests/defstruct.impure.lisp	20 Feb 2011 10:47:32 -0000
@@ -1071,3 +1071,15 @@
     (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))))