X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=4d6f1cb37bcfac28bac579a68a35f6cfdb30b175;hb=722703e7cbd3a4b279a4c1baab5d95df2c23cce9;hp=803a61ffb29748bba7180ce3e668c0d24bf42c11;hpb=58a0e578e00abcb85940021d5ef3051c0b4c2082;p=sbcl.git

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 803a61f..4d6f1cb 100644
--- 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))
 
-;;;; 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))
-
 
 ;;;; 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
@@ -267,24 +276,28 @@
 		       (,dd-ref-fun-name instance dsd-index)
 		       ,instance-type-check-form))
 		     ;; raw slot cases
-		     ,@(mapcar (lambda (raw-type-and-rawref-fun-name)
-				 (destructuring-bind (raw-type
-						      . rawref-fun-name)
-				     raw-type-and-rawref-fun-name
+		     ,@(mapcar (lambda (rtd)
+				 (let ((raw-type (raw-slot-data-raw-type rtd))
+				       (accessor-name
+					(raw-slot-data-accessor-name rtd))
+				       (n-words (raw-slot-data-n-words rtd)))
 				   `((equal dsd-raw-type ',raw-type)
 				     #+sb-xc (/show0 "in raw slot case")
 				     (let ((raw-index (dd-raw-index dd)))
-				       (%slotplace-accessor-funs
-					(,rawref-fun-name (,dd-ref-fun-name
+				       (multiple-value-bind (scaled-dsd-index
+							     misalignment)
+					   (floor dsd-index ,n-words)
+					 (aver (zerop misalignment))
+					 (%slotplace-accessor-funs
+					  (,accessor-name (,dd-ref-fun-name
 							   instance
 							   raw-index)
-							  dsd-index)
-					,instance-type-check-form)))))
-			       *raw-type->rawref-fun-name*)
+							  scaled-dsd-index)
+					  ,instance-type-check-form))))))
+			       *raw-slot-data-list*)
 		     ;; oops
 		     (t
-		      (error "internal error: unexpected DSD-RAW-TYPE ~S"
-			     dsd-raw-type))))))
+		      (bug "unexpected DSD-RAW-TYPE ~S" dsd-raw-type))))))
 	     ;; code shared between DEFSTRUCT :TYPE LIST and
 	     ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed
 	     ;; structure" case, with no LAYOUTs and no raw slots.
@@ -430,15 +443,15 @@
 	(*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*))
+  (default-structure-print x stream *current-level-in-print*))
 
 (defun make-load-form-saving-slots (object &key slot-names environment)
   (declare (ignore object environment))
   (if slot-names
-    (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
-    :just-dump-it-normally))
+      (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
+      :just-dump-it-normally))
 
 ;;;; testing structure types
 
@@ -447,9 +460,11 @@
 ;;; which have a handle on the type's LAYOUT.
 ;;;
 ;;; FIXME: This is fairly big, so it should probably become
-;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so
-;;; that the things which call it are all closures, so that it's
-;;; expanded only in a small number of places.
+;;; MAYBE-INLINE instead of INLINE, or its inlineness should become
+;;; conditional (probably through DEFTRANSFORM) on (> SPEED SPACE). Or
+;;; else we could fix things up so that the things which call it are
+;;; all closures, so that it's expanded only in a small number of
+;;; places.
 #!-sb-fluid (declaim (inline typep-to-layout))
 (defun typep-to-layout (obj layout)
   (declare (type layout layout) (optimize (speed 3) (safety 0)))