0.7.7.12:

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index d06c839..984fa3a 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -50,21 +50,25 @@
             (:conc-name dd-)
             (:make-load-form-fun just-dump-it-normally)
             #-sb-xc-host (:pure t)
-            (:constructor make-defstruct-description (name)))
+            (:constructor make-defstruct-description
+                          (name &aux
+                                (conc-name (symbolicate name "-"))
+                                (copier-name (symbolicate "COPY-" name))
+                                (predicate-name (symbolicate name "-P")))))
   ;; name of the structure
-  (name (missing-arg) :type symbol)
+  (name (missing-arg) :type symbol :read-only t)
   ;; documentation on the structure
   (doc nil :type (or string null))
   ;; prefix for slot names. If NIL, none.
-  (conc-name (symbolicate name "-") :type (or symbol null))
+  (conc-name nil :type (or symbol null))
   ;; the name of the primary standard keyword constructor, or NIL if none
   (default-constructor nil :type (or symbol null))
   ;; all the explicit :CONSTRUCTOR specs, with name defaulted
   (constructors () :type list)
   ;; name of copying function
-  (copier-name (symbolicate "COPY-" name) :type (or symbol null))
+  (copier-name nil :type (or symbol null))
   ;; name of type predicate
-  (predicate-name (symbolicate name "-P") :type (or symbol null))
+  (predicate-name nil :type (or symbol null))
   ;; the arguments to the :INCLUDE option, or NIL if no included
   ;; structure
   (include nil :type list)
@@ -274,7 +278,10 @@
                       fun-name)))
              (cond ((not (eql pf 0))
                     `((def!method print-object ((,x ,name) ,s)
-                        (funcall #',(farg pf) ,x ,s *current-level*))))
+                        (funcall #',(farg pf)
+                                 ,x
+                                 ,s
+                                 *current-level-in-print*))))
                    ((not (eql po 0))
                     `((def!method print-object ((,x ,name) ,s)
                         (funcall #',(farg po) ,x ,s))))
@@ -883,9 +890,7 @@
 
   (%compiler-set-up-layout dd inherits)
 
-  (let* ((dd-name (dd-name dd))
-        (dtype (dd-declarable-type dd))
-        (class (sb!xc:find-class dd-name)))
+  (let* ((dtype (dd-declarable-type dd)))
 
     (let ((copier-name (dd-copier-name dd)))
       (when copier-name
@@ -1205,8 +1210,8 @@
 ;;; Given a structure and a BOA constructor spec, call CREATOR with
 ;;; the appropriate args to make a constructor.
 (defun create-boa-constructor (defstruct boa creator)
-  (multiple-value-bind (req opt restp rest keyp keys allowp aux)
-      (sb!kernel:parse-lambda-list (second boa))
+  (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
+      (parse-lambda-list (second boa))
     (collect ((arglist)
              (vars)
              (types))
@@ -1232,9 +1237,16 @@
          (dolist (arg opt)
            (cond ((consp arg)
                   (destructuring-bind
-                      (name &optional (def (nth-value 1 (get-slot name))))
+                        ;; FIXME: this shares some logic (though not
+                        ;; code) with the &key case below (and it
+                        ;; looks confusing) -- factor out the logic
+                        ;; if possible. - CSR, 2002-04-19
+                        (name
+                         &optional
+                         (def (nth-value 1 (get-slot name)))
+                         (supplied-test nil supplied-test-p))
                       arg
-                    (arglist `(,name ,def))
+                    (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
                     (vars name)
                     (types (get-slot name))))
                  (t
@@ -1249,21 +1261,27 @@
          (arglist '&key)
          (dolist (key keys)
            (if (consp key)
-               (destructuring-bind (wot &optional (def nil def-p)) key
+               (destructuring-bind (wot
+                                     &optional
+                                     (def nil def-p)
+                                     (supplied-test nil supplied-test-p))
+                    key
                  (let ((name (if (consp wot)
                                  (destructuring-bind (key var) wot
                                    (declare (ignore key))
                                    var)
                                  wot)))
-                   (multiple-value-bind (type slot-def) (get-slot name)
-                     (arglist `(,wot ,(if def-p def slot-def)))
+                   (multiple-value-bind (type slot-def)
+                        (get-slot name)
+                     (arglist `(,wot ,(if def-p def slot-def)
+                                 ,@(if supplied-test-p `(,supplied-test) nil)))
                      (vars name)
                      (types type))))
                (do-default key))))
 
        (when allowp (arglist '&allow-other-keys))
 
-       (when aux
+       (when auxp
          (arglist '&aux)
          (dolist (arg aux)
            (let* ((arg (if (consp arg) arg (list arg)))
@@ -1402,7 +1420,6 @@
              :metaclass-name metaclass-name
              :metaclass-constructor metaclass-constructor
              :dd-type dd-type))
-        (conc-name (concatenate 'string (symbol-name class-name) "-"))
         (dd-slots (dd-slots dd))
         (dd-length (1+ (length slot-names)))
         (object-gensym (gensym "OBJECT"))