(I seem to've screwed up during the checkin of 0.pre7.131 before, so

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

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 702abbc..3937071 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -133,8 +133,14 @@
        (if (funcallable-instance-p new-value)
            (%funcallable-instance-lexenv new-value)
            new-value)))
+
+;;; service function for structure constructors
+(defun %make-instance-with-layout (layout)
+  (let ((result (%make-instance (layout-length layout))))
+    (setf (%instance-layout result) layout)
+    result))
 \f
-;;;; target-only parts of the DEFSTRUCT top-level code
+;;;; target-only parts of the DEFSTRUCT top level code
 
 ;;; Catch attempts to mess up definitions of symbols in the CL package.
 (defun protect-cl (symbol)
@@ -148,9 +154,7 @@
   (/show0 "leaving PROTECT-CL")
   (values))
 
-;;; the part of %DEFSTRUCT which sets up out-of-line implementations
-;;; of those structure functions which are sufficiently similar
-;;; between structures that they can be closures
+;;; the part of %DEFSTRUCT which makes sense only on the target SBCL
 ;;;
 ;;; (The "static" in the name is because it needs to be done not only
 ;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as
@@ -162,9 +166,11 @@
 
   (/show0 "entering %TARGET-DEFSTRUCT")
 
+  (remhash (dd-name dd) *typecheckfuns*)
+
   ;; (Constructors aren't set up here, because constructors are
   ;; varied enough (possibly parsing any specified argument list)
-  ;; that we can't reasonably implement them as closures, and so
+  ;; that we can't reasonably implement them as closures, so we
   ;; implement them with DEFUN instead.)
 
   ;; Set FDEFINITIONs for slot accessors.
@@ -222,9 +228,12 @@
             (/show0 ":TYPE LIST case")
             #'listp))))
 
+  (when (dd-doc dd)
+    (setf (fdocumentation (dd-name dd) 'type)
+         (dd-doc dd)))
+
   (/show0 "leaving %TARGET-DEFSTRUCT")
   (values))
-
 \f
 ;;;; generating out-of-line slot accessor functions
 
@@ -254,7 +263,7 @@
                        (dsd-raw-type (dsd-raw-type dsd)))
                    #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code")
                    ;; Map over all the possible RAW-TYPEs, compiling
-                   ;; a different closure-function for each one, so
+                   ;; a different closure function for each one, so
                    ;; that once the COND over RAW-TYPEs happens (at
                    ;; the time closure is allocated) there are no
                    ;; more decisions to be made and things execute
@@ -435,7 +444,7 @@
        (*print-pretty*
         (%default-structure-pretty-print structure stream))
        (t
-        (%default-structure-ugly-print structure-stream))))
+        (%default-structure-ugly-print structure stream))))
 (def!method print-object ((x structure-object) stream)
   (default-structure-print x stream *current-level*))