X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=2a7cebe9e1d7238702977d4c2d1669874b41ae08;hb=ec735ab75335c1744b39190314142a7e6f1ecdb3;hp=01ed4b24d3c2add12743c9275c147aae3d7d461f;hpb=e049902f5e7c30501d2dbb7a41d058a0c717fc1f;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 01ed4b2..2a7cebe 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -175,7 +175,7 @@
 	     (:copier nil)
 	     #-sb-xc-host (:pure t))
   ;; string name of slot
-  %name	
+  %name
   ;; its position in the implementation sequence
   (index (missing-arg) :type fixnum)
   ;; the name of the accessor function
@@ -187,6 +187,8 @@
   (accessor-name nil)
   default			; default value expression
   (type t)			; declared type specifier
+  (safe-p t :type boolean)      ; whether the slot is known to be
+                                ; always of the specified type
   ;; If this object does not describe a raw slot, this value is T.
   ;;
   ;; If this object describes a raw slot, this value is the type of the
@@ -235,11 +237,11 @@
     ;; What operator is used (on the raw data vector) to access a slot
     ;; of this type?
     (accessor-name (missing-arg) :type symbol :read-only t)
-    ;; How many words are each value of this type? (This is used to 
+    ;; How many words are each value of this type? (This is used to
     ;; rescale the offset into the raw data vector.)
     (n-words (missing-arg) :type (and index (integer 1)) :read-only t))
 
-  (defvar *raw-slot-data-list* 
+  (defvar *raw-slot-data-list*
     (list
      ;; The compiler thinks that the raw data vector is a vector of
      ;; word-sized unsigned bytes, so if the slot we want to access
@@ -888,17 +890,16 @@
 ;;; and writer functions of the slot described by DSD.
 (defun slot-accessor-inline-expansion-designators (dd dsd)
   (let ((instance-type-decl `(declare (type ,(dd-name dd) instance)))
-	(accessor-place-form (%accessor-place-form dd dsd 'instance))
-	(dsd-type (dsd-type dsd)))
-    (values (lambda ()
-	      `(lambda (instance)
-		 ,instance-type-decl
-		 (truly-the ,dsd-type ,accessor-place-form)))
-	    (lambda ()
-	      `(lambda (new-value instance)
-		 (declare (type ,dsd-type new-value))
-		 ,instance-type-decl
-		 (setf ,accessor-place-form new-value))))))
+        (accessor-place-form (%accessor-place-form dd dsd 'instance))
+        (dsd-type (dsd-type dsd))
+        (value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
+    (values (lambda () `(lambda (instance)
+                          ,instance-type-decl
+                          (,value-the ,dsd-type ,accessor-place-form)))
+	    (lambda () `(lambda (new-value instance)
+                          (declare (type ,dsd-type new-value))
+                          ,instance-type-decl
+                          (setf ,accessor-place-form new-value))))))
 
 ;;; Return a LAMBDA form which can be used to set a slot.
 (defun slot-setter-lambda-form (dd dsd)
@@ -1398,10 +1399,11 @@
 	       (arglist) (vars) (types)
                (loop for slot in (dd-slots defstruct)
                      for name = (dsd-name slot)
-                     collect (if (find name (skipped-vars) :test #'string=)
-                                 '.do-not-initialize-slot.
-                                 (or (find (dsd-name slot) (vars) :test #'string=)
-                                     (dsd-default slot))))))))
+                     collect (cond ((find name (skipped-vars) :test #'string=)
+                                    (setf (dsd-safe-p slot) nil)
+                                    '.do-not-initialize-slot.)
+                                   ((or (find (dsd-name slot) (vars) :test #'string=)
+                                        (dsd-default slot)))))))))
 
 ;;; Grovel the constructor options, and decide what constructors (if
 ;;; any) to create.
@@ -1461,7 +1463,7 @@
 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
 ;;;; -- WHN 2001-10-28
-;;;; 
+;;;;
 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
 ;;;; instead of just implementing them as primitive objects. (This
@@ -1585,7 +1587,7 @@
 			          ,slot-name)))
 		       slot-names)
 	     ,object-gensym))
-			      
+
 	 ;; predicate
 	 ,@(when predicate
 	     ;; Just delegate to the compiler's type optimization