0.7.13.21:

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

diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp
index fecf0f8..bcde0b5 100644 (file)
--- a/src/code/defbangstruct.lisp
+++ b/src/code/defbangstruct.lisp
@@ -28,9 +28,6 @@
 ;;; information for DEF!STRUCT-defined types
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 
 ;;; information for DEF!STRUCT-defined types
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 

-  ;; FIXME: All this could be byte compiled. (Perhaps most of the rest
-  ;; of the file could be, too.)
-

   ;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that
   ;; TYPE inherits from, or NIL if none.
   (defvar *def!struct-supertype* (make-hash-table))
   ;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that
   ;; TYPE inherits from, or NIL if none.
   (defvar *def!struct-supertype* (make-hash-table))

@@ -71,7 +68,7 @@
   (defun (setf def!struct-type-make-load-form-fun) (new-value type)
     (when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
       (aver (subtypep type 'structure!object))
   (defun (setf def!struct-type-make-load-form-fun) (new-value type)
     (when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
       (aver (subtypep type 'structure!object))

-      (check-type new-value def!struct-type-make-load-form-fun))
+      (aver (typep new-value 'def!struct-type-make-load-form-fun)))

     (setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
 
 ;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
     (setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
 
 ;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT

@@ -79,8 +76,8 @@
 (defun just-dump-it-normally (object &optional (env nil env-p))
   (declare (type structure!object object))
   (if env-p
 (defun just-dump-it-normally (object &optional (env nil env-p))
   (declare (type structure!object object))
   (if env-p

-      (make-load-form-saving-slots object :environment env)
-      (make-load-form-saving-slots object)))
+      (sb!xc:make-load-form-saving-slots object :environment env)
+      (sb!xc:make-load-form-saving-slots object)))

 
 ;;; a MAKE-LOAD-FORM function for objects which don't use the load
 ;;; form system. This is used for LAYOUT objects because the special
 
 ;;; a MAKE-LOAD-FORM function for objects which don't use the load
 ;;; form system. This is used for LAYOUT objects because the special

@@ -100,7 +97,7 @@
   ;; a description of a DEF!STRUCT call to be stored until we get
   ;; enough of the system running to finish processing it
   (defstruct delayed-def!struct
   ;; a description of a DEF!STRUCT call to be stored until we get
   ;; enough of the system running to finish processing it
   (defstruct delayed-def!struct

-    (args (required-argument) :type cons)
+    (args (missing-arg) :type cons)

     (package (sane-package) :type package))
   ;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
   ;; working fully so that we can apply it to them then. After
     (package (sane-package) :type package))
   ;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
   ;; working fully so that we can apply it to them then. After

@@ -121,6 +118,7 @@
        (if (consp nameoid)
            (values (first nameoid) (rest nameoid))
            (values nameoid nil))
        (if (consp nameoid)
            (values (first nameoid) (rest nameoid))
            (values nameoid nil))

+      (declare (type list options))

       (let* ((include-clause (find :include options :key #'first))
             (def!struct-supertype nil) ; may change below
             (mlff-clause (find :make-load-form-fun options :key #'first))
       (let* ((include-clause (find :include options :key #'first))
             (def!struct-supertype nil) ; may change below
             (mlff-clause (find :make-load-form-fun options :key #'first))

@@ -146,30 +144,32 @@
 #+sb-xc-host
 (progn
   (defun %instance-length (instance)
 #+sb-xc-host
 (progn
   (defun %instance-length (instance)

-    (check-type instance structure!object)
+    (aver (typep instance 'structure!object))

     (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
   (defun %instance-ref (instance index)
     (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
   (defun %instance-ref (instance index)

-    (check-type instance structure!object)
+    (aver (typep instance 'structure!object))

     (let* ((class (sb!xc:find-class (type-of instance)))
           (layout (class-layout class)))
       (if (zerop index)
          layout
          (let* ((dd (layout-info layout))
                 (dsd (elt (dd-slots dd) (1- index)))
     (let* ((class (sb!xc:find-class (type-of instance)))
           (layout (class-layout class)))
       (if (zerop index)
          layout
          (let* ((dd (layout-info layout))
                 (dsd (elt (dd-slots dd) (1- index)))

-                (accessor (dsd-accessor dsd)))
-           (declare (type symbol accessor))
-           (funcall accessor instance)))))
+                (accessor-name (dsd-accessor-name dsd)))
+           (declare (type symbol accessor-name))
+           (funcall accessor-name instance)))))

   (defun %instance-set (instance index new-value)
   (defun %instance-set (instance index new-value)

-    (check-type instance structure!object)
+    (aver (typep instance 'structure!object))

     (let* ((class (sb!xc:find-class (type-of instance)))
           (layout (class-layout class)))
       (if (zerop index)
          (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
          (let* ((dd (layout-info layout))
                 (dsd (elt (dd-slots dd) (1- index)))
     (let* ((class (sb!xc:find-class (type-of instance)))
           (layout (class-layout class)))
       (if (zerop index)
          (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
          (let* ((dd (layout-info layout))
                 (dsd (elt (dd-slots dd) (1- index)))

-                (accessor (dsd-accessor dsd)))
-           (declare (type symbol accessor))
-           (funcall (fdefinition `(setf ,accessor)) new-value instance))))))
+                (accessor-name (dsd-accessor-name dsd)))
+           (declare (type symbol accessor-name))
+           (funcall (fdefinition `(setf ,accessor-name))
+                    new-value
+                    instance))))))

 
 ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
 ;;; DEFSTRUCT-style arguments with any class names in the SB!XC
 
 ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
 ;;; DEFSTRUCT-style arguments with any class names in the SB!XC