From 3120740c3569735b00123b94b61679f56e253ea6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 20 Feb 2011 10:48:32 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ src/code/defstruct.lisp | 8 +++++++- tests/defstruct.impure.lisp | 12 ++++++++++++ version.lisp-expr | 2 +- 4 files changed, 22 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 9934248..5a7faef 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4