0.6.11.32:

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 4ac42bc..40f7ba9 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -85,7 +85,7 @@
   ;; classes, CLASS-STRUCTURE-P = NIL)
   ;;
   ;; vector element type
-  (element-type 't)
+  (element-type t)
   ;; T if :NAMED was explicitly specified, NIL otherwise
   (named nil :type boolean)
   ;; any INITIAL-OFFSET option on this direct type
@@ -165,8 +165,8 @@
 ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
 ;;;; close personal friend SB!XC:DEFSTRUCT)
 
-;;; Return a list of forms to install print and make-load-form funs, mentioning
-;;; them in the expansion so that they can be compiled.
+;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
+;;; mentioning them in the expansion so that they can be compiled.
 (defun class-method-definitions (defstruct)
   (let ((name (dd-name defstruct)))
     `((locally
@@ -199,7 +199,7 @@
                         (funcall #',(farg po) ,x ,s))))
                    (t nil))))
        ,@(let ((pure (dd-pure defstruct)))
-           (cond ((eq pure 't)
+           (cond ((eq pure t)
                   `((setf (layout-pure (class-layout
                                         (sb!xc:find-class ',name)))
                           t)))
@@ -210,9 +210,7 @@
        ,@(let ((def-con (dd-default-constructor defstruct)))
            (when (and def-con (not (dd-alternate-metaclass defstruct)))
              `((setf (structure-class-constructor (sb!xc:find-class ',name))
-                     #',def-con))))
-       ;; FIXME: MAKE-LOAD-FORM is supposed to be handled here, too.
-       ))))
+                     #',def-con))))))))
 ;;; FIXME: I really would like to make structure accessors less special,
 ;;; just ordinary inline functions. (Or perhaps inline functions with special
 ;;; compact implementations of their expansions, to avoid bloating the system.)
@@ -248,11 +246,13 @@
        (if (class-structure-p dd)
           (let ((inherits (inherits-for-structure dd)))
             `(progn
+               (/noshow0 "doing CLASS-STRUCTURE-P case for DEFSTRUCT " ,name)
                (eval-when (:compile-toplevel :load-toplevel :execute)
                  (%compiler-only-defstruct ',dd ',inherits))
                (%defstruct ',dd ',inherits)
                ,@(when (eq (dd-type dd) 'structure)
                    `((%compiler-defstruct ',dd)))
+               (/noshow0 "starting not-for-the-xc-host section in DEFSTRUCT")
                ,@(unless expanding-into-code-for-xc-host-p
                    (append (raw-accessor-definitions dd)
                            (predicate-definitions dd)
@@ -262,8 +262,10 @@
                                        ;(copier-definition dd)
                            (constructor-definitions dd)
                            (class-method-definitions dd)))
+               (/noshow0 "done with DEFSTRUCT " ,name)
                ',name))
           `(progn
+             (/show0 "doing NOT CLASS-STRUCTURE-P case for DEFSTRUCT " ,name)
              (eval-when (:compile-toplevel :load-toplevel :execute)
                (setf (info :typed-structure :info ',name) ',dd))
              ,@(unless expanding-into-code-for-xc-host-p
@@ -271,6 +273,7 @@
                          (typed-predicate-definitions dd)
                          (typed-copier-definitions dd)
                          (constructor-definitions dd)))
+             (/noshow0 "done with DEFSTRUCT " ,name)
              ',name)))))
 
 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
@@ -488,7 +491,7 @@
         (cond ((eq type 'funcallable-structure)
                (setf (dd-type defstruct) type))
               ((member type '(list vector))
-               (setf (dd-element-type defstruct) 't)
+               (setf (dd-element-type defstruct) t)
                (setf (dd-type defstruct) type))
               ((and (consp type) (eq (first type) 'vector))
                (destructuring-bind (vector vtype) type
@@ -511,7 +514,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun parse-name-and-options (name-and-options)
   (destructuring-bind (name &rest options) name-and-options
-    (assert name) ; A null name doesn't seem to make sense here.
+    (aver name) ; A null name doesn't seem to make sense here.
     (let ((defstruct (make-defstruct-description name)))
       (dolist (option options)
        (cond ((consp option)
@@ -616,7 +619,7 @@
       (setf (dsd-default islot) default))
     (when type-p
       (setf (dsd-type islot)
-           (if (eq (dsd-type islot) 't)
+           (if (eq (dsd-type islot) t)
                type
                `(and ,(dsd-type islot) ,type))))
     (when ro-p
@@ -1163,7 +1166,7 @@
        (t
        (dsd-index slot)))
      (cond
-      ((eq rtype 't) object)
+      ((eq rtype t) object)
       (data)
       (t
        `(truly-the (simple-array (unsigned-byte 32) (*))
@@ -1264,8 +1267,7 @@
     (dolist (slot (dd-slots defstruct))
       (let ((dum (gensym))
            (name (dsd-name slot)))
-       (arglist `((,(intern (string name) "KEYWORD") ,dum)
-                  ,(dsd-default slot)))
+       (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
        (types (dsd-type slot))
        (vals dum)))
     (funcall creator