0.7.1.18:

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 5c3eb5c..2a81fb3 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))))
@@ -515,7 +522,7 @@
           (when offset (incf (dd-length dd) offset)))))
 
       (when (dd-include dd)
-       (do-dd-inclusion-stuff dd))
+       (frob-dd-inclusion-stuff dd))
 
       dd)))
 
@@ -676,7 +683,7 @@
 
 ;;; Process any included slots pretty much like they were specified.
 ;;; Also inherit various other attributes.
-(defun do-dd-inclusion-stuff (dd)
+(defun frob-dd-inclusion-stuff (dd)
   (destructuring-bind (included-name &rest modified-slots) (dd-include dd)
     (let* ((type (dd-type dd))
           (included-structure
@@ -721,7 +728,7 @@
       (dolist (included-slot (dd-slots included-structure))
        (let* ((included-name (dsd-name included-slot))
               (modified (or (find included-name modified-slots
-                                  :key #'(lambda (x) (if (atom x) x (car x)))
+                                  :key (lambda (x) (if (atom x) x (car x)))
                                   :test #'string=)
                             `(,included-name))))
          (parse-1-dsd dd
@@ -1141,15 +1148,15 @@
   (let ((temp (gensym))
        (etype (dd-element-type dd)))
     `(defun ,cons-name ,arglist
-       (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
+       (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var))
                          vars types))
        (let ((,temp (make-array ,(dd-length dd)
                                :element-type ',(dd-element-type dd))))
-        ,@(mapcar #'(lambda (x)
-                      `(setf (aref ,temp ,(cdr x))  ',(car x)))
+        ,@(mapcar (lambda (x)
+                    `(setf (aref ,temp ,(cdr x))  ',(car x)))
                   (find-name-indices dd))
-        ,@(mapcar #'(lambda (dsd value)
-                      `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+        ,@(mapcar (lambda (dsd value)
+                    `(setf (aref ,temp ,(dsd-index dsd)) ,value))
                   (dd-slots dd) values)
         ,temp))))
 (defun create-list-constructor (dd cons-name arglist vars types values)
@@ -1160,8 +1167,7 @@
       (setf (elt vals (dsd-index dsd)) val))
 
     `(defun ,cons-name ,arglist
-       (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
-                         vars types))
+       (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
        (list ,@vals))))
 (defun create-structure-constructor (dd cons-name arglist vars types values)
   (let* ((instance (gensym "INSTANCE"))
@@ -1275,9 +1281,9 @@
 
       (funcall creator defstruct (first boa)
               (arglist) (vars) (types)
-              (mapcar #'(lambda (slot)
-                          (or (find (dsd-name slot) (vars) :test #'string=)
-                              (dsd-default slot)))
+              (mapcar (lambda (slot)
+                        (or (find (dsd-name slot) (vars) :test #'string=)
+                            (dsd-default slot)))
                       (dd-slots defstruct))))))
 
 ;;; Grovel the constructor options, and decide what constructors (if