X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=4138741cccdf0f97b15b59e18c6f2e884e5d9feb;hb=020de3c04699323437f0c746fe986506b716ab97;hp=71c9c68d038650e57c5a4ec149bbb39a03501aa7;hpb=086927c64682b73e00cb5090ec72e1a72fb30ece;p=sbcl.git

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 71c9c68..4138741 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -321,13 +321,21 @@
 	     ;; through here.
 	     (%slotplace-accessor-funs (slotplace instance-type-check-form)
 	       (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
-	       `(values (lambda (instance)
-			  (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
-			  ,instance-type-check-form
-			  (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
-			  ,slotplace)
-			(let ((typecheckfun (typespec-typecheckfun dsd-type)))
-			  (lambda (new-value instance)
+	       `(let ((typecheckfun (typespec-typecheckfun dsd-type)))
+                  (values (if (dsd-safe-p dsd)
+                              (lambda (instance)
+                                (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+                                ,instance-type-check-form
+                                (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+                                ,slotplace)
+                              (lambda (instance)
+                                (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+                                ,instance-type-check-form
+                                (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+                                (let ((value ,slotplace))
+                                  (funcall typecheckfun value)
+                                  value)))
+                          (lambda (new-value instance)
 			    (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer")
 			    ,instance-type-check-form
 			    (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
@@ -337,7 +345,7 @@
 
     (let ((dsd-index (dsd-index dsd))
 	  (dsd-type (dsd-type dsd)))
-	    
+
       #+sb-xc (/show0 "got DSD-TYPE=..")
       #+sb-xc (/hexstr dsd-type)
       (ecase (dd-type dd)
@@ -346,7 +354,7 @@
 	(structure
 	 #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
 	 (%native-slot-accessor-funs %instance-ref))
-				     
+
 	;; structures with the :TYPE option
 
 	;; FIXME: Worry about these later..
@@ -395,7 +403,7 @@
 
     res))
 
-;;; default PRINT-OBJECT and MAKE-LOAD-FORM methods
+;;; default PRINT-OBJECT method
 
 (defun %default-structure-pretty-print (structure stream)
   (let* ((layout (%instance-layout structure))
@@ -422,7 +430,7 @@
 	   (pprint-pop)
 	   (let ((slot (pop remaining-slots)))
 	     (write-char #\: stream)
-	     (output-symbol-name (dsd-%name slot) stream)
+	     (output-symbol-name (symbol-name (dsd-name slot)) stream)
 	     (write-char #\space stream)
 	     (pprint-newline :miser stream)
 	     (output-object (funcall (fdefinition (dsd-accessor-name slot))
@@ -452,7 +460,7 @@
 	(write-char #\space stream)
 	(write-char #\: stream)
 	(let ((slot (first remaining-slots)))
-	  (output-symbol-name (dsd-%name slot) stream)
+	  (output-symbol-name (symbol-name (dsd-name slot)) stream)
 	  (write-char #\space stream)
 	  (output-object
 	   (funcall (fdefinition (dsd-accessor-name slot))
@@ -468,12 +476,6 @@
 	 (%default-structure-ugly-print structure stream))))
 (def!method print-object ((x structure-object) stream)
   (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
-      :sb-just-dump-it-normally))
 
 ;;;; testing structure types
 
@@ -535,7 +537,7 @@
 	 ,x
 	 ,(compiler-layout-or-lose class-name)))
       ((vector)
-       (let ((xx (gensym "X")))
+       (with-unique-names (xx)
 	 `(let ((,xx ,x))
 	    (declare (type vector ,xx))
 	    ,@(when (dd-named dd)
@@ -550,7 +552,7 @@
 		     :format-arguments (list ',class-name ,xx)))))
 	    (values))))
       ((list)
-       (let ((xx (gensym "X")))
+       (with-unique-names (xx)
 	 `(let ((,xx ,x))
 	    (declare (type list ,xx))
 	    ,@(when (dd-named dd)