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

[sbcl.git] / src / code / defstruct.lisp

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 6b6cd19..fba213a 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -341,8 +341,8 @@
         (declare (notinline find-classoid))
         ,@(let ((pf (dd-print-function defstruct))
                 (po (dd-print-object defstruct))
-                (x (gensym))
-                (s (gensym)))
+                (x (sb!xc:gensym "OBJECT"))
+                (s (sb!xc:gensym "STREAM")))
             ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
             ;; leaves PO or PF equal to NIL. The user-level effect is
             ;; to generate a PRINT-OBJECT method specialized for the type,
@@ -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)))
@@ -732,7 +738,8 @@
       ;;x#-sb-xc-host
       ;;x(when (and (fboundp accessor-name)
       ;;x           (not (accessor-inherited-data accessor-name defstruct)))
-      ;;x  (style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
+      ;;x  (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~
+      ;;                in DEFSTRUCT" accessor-name)))
       ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
       ;; a warning at MACROEXPAND time, when instead the warning should
       ;; occur not just because the code was constructed, but because it
@@ -1447,7 +1454,7 @@
             (types)
             (vals))
     (dolist (slot (dd-slots defstruct))
-      (let ((dum (gensym))
+      (let ((dum (sb!xc:gensym "DUM"))
             (name (dsd-name slot)))
         (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
         (types (dsd-type slot))
@@ -1535,12 +1542,12 @@
         (when auxp
           (arglist '&aux)
           (dolist (arg aux)
-            (arglist arg)
             (if (proper-list-of-length-p arg 2)
-              (let ((var (first arg)))
-                (vars var)
-                (types (get-slot var)))
-              (skipped-vars (if (consp arg) (first arg) arg))))))
+                (let ((var (first arg)))
+                  (arglist arg)
+                  (vars var)
+                  (types (get-slot var)))
+                (skipped-vars (if (consp arg) (first arg) arg))))))
 
       (funcall creator defstruct (first boa)
                (arglist) (vars) (types)
@@ -1744,8 +1751,8 @@
               :dd-type dd-type))
          (dd-slots (dd-slots dd))
          (dd-length (1+ (length slot-names)))
-         (object-gensym (gensym "OBJECT"))
-         (new-value-gensym (gensym "NEW-VALUE-"))
+         (object-gensym (sb!xc:gensym "OBJECT"))
+         (new-value-gensym (sb!xc:gensym "NEW-VALUE-"))
          (delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
     (multiple-value-bind (raw-maker-form raw-reffer-operator)
         (ecase dd-type