0.9.2.43:
[sbcl.git] / src / code / target-defstruct.lisp
index 22d7199..5fb9ac1 100644 (file)
 ;;; doesn't matter, since PCL only sets the FIN function.
 (defun (setf funcallable-instance-fun) (new-value fin)
   (setf (%funcallable-instance-fun fin)
-       (%closure-fun new-value))
+        (%closure-fun new-value))
   (setf (%funcallable-instance-lexenv fin)
-       (if (funcallable-instance-p new-value)
-           (%funcallable-instance-lexenv new-value)
-           new-value)))
+        (if (funcallable-instance-p new-value)
+            (%funcallable-instance-lexenv new-value)
+            new-value)))
 
 ;;; service function for structure constructors
 (defun %make-instance-with-layout (layout)
   (/show0 "entering PROTECT-CL, SYMBOL=..")
   (/hexstr symbol)
   (when (and *cold-init-complete-p*
-            (eq (symbol-package symbol) *cl-package*))
+             (eq (symbol-package symbol) *cl-package*))
     (cerror "Go ahead and patch the system."
-           "attempting to modify a symbol in the COMMON-LISP package: ~S"
-           symbol))
+            "attempting to modify a symbol in the COMMON-LISP package: ~S"
+            symbol))
   (/show0 "leaving PROTECT-CL")
   (values))
 
     (let ((accessor-name (dsd-accessor-name dsd)))
       ;; We mustn't step on any inherited accessors
       (unless (accessor-inherited-data accessor-name dd)
-       (/show0 "ACCESSOR-NAME=..")
-       (/hexstr accessor-name)
-       (protect-cl accessor-name)
-       (/hexstr "getting READER-FUN and WRITER-FUN")
-       (multiple-value-bind (reader-fun writer-fun)
-           (slot-accessor-funs dd dsd)
-         (declare (type function reader-fun writer-fun))
-         (/show0 "got READER-FUN and WRITER-FUN=..")
-         (/hexstr reader-fun)
-         (setf (symbol-function accessor-name) reader-fun)
-         (unless (dsd-read-only dsd)
-           (/show0 "setting FDEFINITION for WRITER-FUN=..")
-           (/hexstr writer-fun)
-           (setf (fdefinition `(setf ,accessor-name)) writer-fun))))))
+        (/show0 "ACCESSOR-NAME=..")
+        (/hexstr accessor-name)
+        (protect-cl accessor-name)
+        (/hexstr "getting READER-FUN and WRITER-FUN")
+        (multiple-value-bind (reader-fun writer-fun)
+            (slot-accessor-funs dd dsd)
+          (declare (type function reader-fun writer-fun))
+          (/show0 "got READER-FUN and WRITER-FUN=..")
+          (/hexstr reader-fun)
+          (setf (symbol-function accessor-name) reader-fun)
+          (unless (dsd-read-only dsd)
+            (/show0 "setting FDEFINITION for WRITER-FUN=..")
+            (/hexstr writer-fun)
+            (setf (fdefinition `(setf ,accessor-name)) writer-fun))))))
 
   ;; Set FDEFINITION for copier.
   (when (dd-copier-name dd)
     ;; (And funcallable instances don't need copiers anyway.)
     (aver (eql (dd-type dd) 'structure))
     (setf (symbol-function (dd-copier-name dd))
-         ;; FIXME: should use a closure which checks arg type before copying
-         #'copy-structure))
+          ;; FIXME: should use a closure which checks arg type before copying
+          #'copy-structure))
 
   ;; Set FDEFINITION for predicate.
   (when (dd-predicate-name dd)
     (/show0 "doing FDEFINITION for predicate")
     (protect-cl (dd-predicate-name dd))
     (setf (symbol-function (dd-predicate-name dd))
-         (ecase (dd-type dd)
-           ;; structures with LAYOUTs
-           ((structure funcallable-structure)
-            (/show0 "with-LAYOUT case")
-            (lambda (object)
-              (locally ; <- to keep SAFETY 0 from affecting arg count checking
-                (declare (optimize (speed 3) (safety 0)))
-                (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..")
-                (/nohexstr object)
-                (/nohexstr layout)
-                (typep-to-layout object layout))))
-           ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST)
-           ;;
-           ;; FIXME: should handle the :NAMED T case in these cases
-           (vector
-            (/show0 ":TYPE VECTOR case")
-            #'vectorp)
-           (list
-            (/show0 ":TYPE LIST case")
-            #'listp))))
+          (ecase (dd-type dd)
+            ;; structures with LAYOUTs
+            ((structure funcallable-structure)
+             (/show0 "with-LAYOUT case")
+             (lambda (object)
+               (locally ; <- to keep SAFETY 0 from affecting arg count checking
+                 (declare (optimize (speed 3) (safety 0)))
+                 (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..")
+                 (/nohexstr object)
+                 (/nohexstr layout)
+                 (typep-to-layout object layout))))
+            ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST)
+            ;;
+            ;; FIXME: should handle the :NAMED T case in these cases
+            (vector
+             (/show0 ":TYPE VECTOR case")
+             #'vectorp)
+            (list
+             (/show0 ":TYPE LIST case")
+             #'listp))))
 
   (when (dd-doc dd)
     (setf (fdocumentation (dd-name dd) 'structure)
-         (dd-doc dd)))
+          (dd-doc dd)))
 
   ;; the BOUNDP test here is to get past cold-init.
   (when (boundp '*defstruct-hooks*)
     (dolist (fun *defstruct-hooks*)
       (funcall fun (find-classoid (dd-name dd)))))
-  
+
   (/show0 "leaving %TARGET-DEFSTRUCT")
   (values))
 \f
   ;; things like INSTANCE and DSD-INDEX from the namespace they're
   ;; expanded in.
   (macrolet (;; code shared between funcallable instance case and the
-            ;; ordinary STRUCTURE-OBJECT case: Handle native
-            ;; structures with LAYOUTs and (possibly) raw slots.
-            (%native-slot-accessor-funs (dd-ref-fun-name)
-              (let ((instance-type-check-form
-                     '(%check-structure-type-from-layout instance layout)))
-                (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form)
-                `(let ((layout (dd-layout-or-lose dd))
-                       (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
-                   ;; 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
-                   ;; reasonably efficiently.
-                   (cond
-                    ;; nonraw slot case
-                    ((eql dsd-raw-type t)
-                     #+sb-xc (/show0 "in nonraw slot case")
-                     (%slotplace-accessor-funs
-                      (,dd-ref-fun-name instance dsd-index)
-                      ,instance-type-check-form))
-                    ;; raw slot cases
-                    ,@(mapcar (lambda (rtd)
-                                (let ((raw-type (raw-slot-data-raw-type rtd))
-                                      (accessor-name
-                                       (raw-slot-data-accessor-name rtd)))
-                                  `((equal dsd-raw-type ',raw-type)
-                                    #+sb-xc (/show0 "in raw slot case")
-                                    (%slotplace-accessor-funs
-                                     (,accessor-name instance dsd-index)
-                                     ,instance-type-check-form))))
-                              *raw-slot-data-list*)
-                    ;; oops
-                    (t
-                     (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.
-            (%colontyped-slot-accessor-funs () (error "stub")) 
-            ;; the common structure of the raw-slot and not-raw-slot
-            ;; cases, defined in terms of the writable SLOTPLACE. All
-            ;; possible flavors of slot access should be able to pass
-            ;; through here.
-            (%slotplace-accessor-funs (slotplace instance-type-check-form)
-              (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
-              `(let ((typecheckfun (typespec-typecheckfun dsd-type)))
+             ;; ordinary STRUCTURE-OBJECT case: Handle native
+             ;; structures with LAYOUTs and (possibly) raw slots.
+             (%native-slot-accessor-funs (dd-ref-fun-name)
+               (let ((instance-type-check-form
+                      '(%check-structure-type-from-layout instance layout)))
+                 (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form)
+                 `(let ((layout (dd-layout-or-lose dd))
+                        (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
+                    ;; 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
+                    ;; reasonably efficiently.
+                    (cond
+                     ;; nonraw slot case
+                     ((eql dsd-raw-type t)
+                      #+sb-xc (/show0 "in nonraw slot case")
+                      (%slotplace-accessor-funs
+                       (,dd-ref-fun-name instance dsd-index)
+                       ,instance-type-check-form))
+                     ;; raw slot cases
+                     ,@(mapcar (lambda (rtd)
+                                 (let ((raw-type (raw-slot-data-raw-type rtd))
+                                       (accessor-name
+                                        (raw-slot-data-accessor-name rtd)))
+                                   `((equal dsd-raw-type ',raw-type)
+                                     #+sb-xc (/show0 "in raw slot case")
+                                     (%slotplace-accessor-funs
+                                      (,accessor-name instance dsd-index)
+                                      ,instance-type-check-form))))
+                               *raw-slot-data-list*)
+                     ;; oops
+                     (t
+                      (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.
+             (%colontyped-slot-accessor-funs () (error "stub"))
+             ;; the common structure of the raw-slot and not-raw-slot
+             ;; cases, defined in terms of the writable SLOTPLACE. All
+             ;; possible flavors of slot access should be able to pass
+             ;; through here.
+             (%slotplace-accessor-funs (slotplace instance-type-check-form)
+               (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
+               `(let ((typecheckfun (typespec-typecheckfun dsd-type)))
                   (values (if (dsd-safe-p dsd)
                               (lambda (instance)
                                 (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
                                   (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")
-                           (funcall typecheckfun new-value)
-                           (/noshow0 "back from TYPECHECKFUN")
-                           (setf ,slotplace new-value))))))
+                            (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer")
+                            ,instance-type-check-form
+                            (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+                            (funcall typecheckfun new-value)
+                            (/noshow0 "back from TYPECHECKFUN")
+                            (setf ,slotplace new-value))))))
 
     (let ((dsd-index (dsd-index dsd))
-         (dsd-type (dsd-type dsd)))
+          (dsd-type (dsd-type dsd)))
 
       #+sb-xc (/show0 "got DSD-TYPE=..")
       #+sb-xc (/hexstr dsd-type)
       (ecase (dd-type dd)
 
-       ;; native structures
-       (structure
-        #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
-        (%native-slot-accessor-funs %instance-ref))
+        ;; native structures
+        (structure
+         #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
+         (%native-slot-accessor-funs %instance-ref))
 
-       ;; structures with the :TYPE option
+        ;; structures with the :TYPE option
 
-       ;; FIXME: Worry about these later..
-       #|
+        ;; FIXME: Worry about these later..
+        #|
         ;; In :TYPE LIST and :TYPE VECTOR structures, ANSI specifies the
         ;; layout completely, so that raw slots are impossible.
         (list
          (dd-type-slot-accessor-funs nth-but-with-sane-arg-order
-                                `(%check-structure-type-from-dd
-                                :maybe-raw-p nil))
+                                 `(%check-structure-type-from-dd
+                                 :maybe-raw-p nil))
         (vector
          (dd-type-slot-accessor-funs aref
-                                :maybe-raw-p nil)))
+                                 :maybe-raw-p nil)))
         |#
-       ))))
+        ))))
 \f
 ;;; Copy any old kind of structure.
 (defun copy-structure (structure)
   "Return a copy of STRUCTURE with the same (EQL) slot values."
   (declare (type structure-object structure))
   (let* ((len (%instance-length structure))
-        (res (%make-instance len))
-        (layout (%instance-layout structure))
-        (nuntagged (layout-n-untagged-slots layout)))
+         (res (%make-instance len))
+         (layout (%instance-layout structure))
+         (nuntagged (layout-n-untagged-slots layout)))
 
     (declare (type index len))
     (when (layout-invalid layout)
     (dotimes (i (- len nuntagged))
       (declare (type index i))
       (setf (%instance-ref res i)
-           (%instance-ref structure i)))
+            (%instance-ref structure i)))
 
     ;; Copy raw slots.
     (dotimes (i nuntagged)
       (declare (type index i))
       (setf (%raw-instance-ref/word res i)
-           (%raw-instance-ref/word structure i)))
+            (%raw-instance-ref/word structure i)))
 
     res))
 \f
 
 (defun %default-structure-pretty-print (structure stream)
   (let* ((layout (%instance-layout structure))
-        (name (classoid-name (layout-classoid layout)))
-        (dd (layout-info layout)))
+         (name (classoid-name (layout-classoid layout)))
+         (dd (layout-info layout)))
     ;; KLUDGE: during the build process with SB-SHOW, we can sometimes
     ;; attempt to print out a PCL object (with null LAYOUT-INFO).
     #!+sb-show
     (when (null dd)
       (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
-       (prin1 name stream)
-       (write-char #\space stream)
-       (write-string "(no LAYOUT-INFO)"))
+        (prin1 name stream)
+        (write-char #\space stream)
+        (write-string "(no LAYOUT-INFO)"))
       (return-from %default-structure-pretty-print nil))
     ;; the structure type doesn't count as a component for
     ;; *PRINT-LEVEL* processing.  We can likewise elide the logical
     (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
       (prin1 name stream)
       (let ((remaining-slots (dd-slots dd)))
-       (when remaining-slots
-         (write-char #\space stream)
-         ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
-         ;; but I can't see why. -- WHN 20000205
-         (pprint-newline :linear stream)
-         (loop
-          (pprint-pop)
-          (let ((slot (pop remaining-slots)))
-            (write-char #\: 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))
-                                    structure)
-                           stream)
-            (when (null remaining-slots)
-              (return))
-            (write-char #\space stream)
-            (pprint-newline :linear stream))))))))
+        (when remaining-slots
+          (write-char #\space stream)
+          ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
+          ;; but I can't see why. -- WHN 20000205
+          (pprint-newline :linear stream)
+          (loop
+           (pprint-pop)
+           (let ((slot (pop remaining-slots)))
+             (write-char #\: 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))
+                                     structure)
+                            stream)
+             (when (null remaining-slots)
+               (return))
+             (write-char #\space stream)
+             (pprint-newline :linear stream))))))))
 (defun %default-structure-ugly-print (structure stream)
   (let* ((layout (%instance-layout structure))
-        (name (classoid-name (layout-classoid layout)))
-        (dd (layout-info layout)))
+         (name (classoid-name (layout-classoid layout)))
+         (dd (layout-info layout)))
     (when (and dd (null (dd-slots dd)))
       (write-string "#S(" stream)
       (prin1 name stream)
       (write-string "#S(" stream)
       (prin1 name stream)
       (do ((index 0 (1+ index))
-          (remaining-slots (dd-slots dd) (cdr remaining-slots)))
-         ((or (null remaining-slots)
-              (and (not *print-readably*)
-                   *print-length*
-                   (>= index *print-length*)))
-          (if (null remaining-slots)
-              (write-string ")" stream)
-              (write-string " ...)" stream)))
-       (declare (type index index))
-       (write-char #\space stream)
-       (write-char #\: stream)
-       (let ((slot (first remaining-slots)))
-         (output-symbol-name (symbol-name (dsd-name slot)) stream)
-         (write-char #\space stream)
-         (output-object
-          (funcall (fdefinition (dsd-accessor-name slot))
-                   structure)
-          stream))))))
+           (remaining-slots (dd-slots dd) (cdr remaining-slots)))
+          ((or (null remaining-slots)
+               (and (not *print-readably*)
+                    *print-length*
+                    (>= index *print-length*)))
+           (if (null remaining-slots)
+               (write-string ")" stream)
+               (write-string " ...)" stream)))
+        (declare (type index index))
+        (write-char #\space stream)
+        (write-char #\: stream)
+        (let ((slot (first remaining-slots)))
+          (output-symbol-name (symbol-name (dsd-name slot)) stream)
+          (write-char #\space stream)
+          (output-object
+           (funcall (fdefinition (dsd-accessor-name slot))
+                    structure)
+           stream))))))
 (defun default-structure-print (structure stream depth)
   (declare (ignore depth))
   (cond ((funcallable-instance-p structure)
-        (print-unreadable-object (structure stream :identity t :type t)))
-       (*print-pretty*
-        (%default-structure-pretty-print structure stream))
-       (t
-        (%default-structure-ugly-print structure stream))))
+         (print-unreadable-object (structure stream :identity t :type t)))
+        (*print-pretty*
+         (%default-structure-pretty-print structure stream))
+        (t
+         (%default-structure-ugly-print structure stream))))
 (def!method print-object ((x structure-object) stream)
   (default-structure-print x stream *current-level-in-print*))
 \f
   ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code.
   (and (typep obj 'instance)
        (let ((obj-layout (%instance-layout obj)))
-        (cond ((eq obj-layout layout)
-               ;; (In this case OBJ-LAYOUT can't be invalid, because
-               ;; we determined LAYOUT is valid in the test above.)
-               (/noshow0 "EQ case")
-               t)
-              ((layout-invalid obj-layout)
-               (/noshow0 "LAYOUT-INVALID case")
-               (error 'layout-invalid
-                      :expected-type (layout-classoid obj-layout)
-                      :datum obj))
-              (t
-               (let ((depthoid (layout-depthoid layout)))
-                 (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..")
-                 (/nohexstr depthoid)
-                 (/nohexstr layout-inherits)
-                 (and (> (layout-depthoid obj-layout) depthoid)
-                      (eq (svref (layout-inherits obj-layout) depthoid)
-                          layout))))))))
+         (cond ((eq obj-layout layout)
+                ;; (In this case OBJ-LAYOUT can't be invalid, because
+                ;; we determined LAYOUT is valid in the test above.)
+                (/noshow0 "EQ case")
+                t)
+               ((layout-invalid obj-layout)
+                (/noshow0 "LAYOUT-INVALID case")
+                (error 'layout-invalid
+                       :expected-type (layout-classoid obj-layout)
+                       :datum obj))
+               (t
+                (let ((depthoid (layout-depthoid layout)))
+                  (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..")
+                  (/nohexstr depthoid)
+                  (/nohexstr layout-inherits)
+                  (and (> (layout-depthoid obj-layout) depthoid)
+                       (eq (svref (layout-inherits obj-layout) depthoid)
+                           layout))))))))
 \f
 ;;;; checking structure types
 
     (ecase (dd-type dd)
       ((structure funcallable-instance)
        `(%check-structure-type-from-layout
-        ,x
-        ,(compiler-layout-or-lose class-name)))
+         ,x
+         ,(compiler-layout-or-lose class-name)))
       ((vector)
        (with-unique-names (xx)
-        `(let ((,xx ,x))
-           (declare (type vector ,xx))
-           ,@(when (dd-named dd)
-               `((unless (eql (aref ,xx 0) ',class-name)
-                   (error
-                    'simple-type-error
-                    :datum (aref ,xx 0)
-                    :expected-type `(member ,class-name)
-                    :format-control
-                    "~@<missing name in instance of ~
+         `(let ((,xx ,x))
+            (declare (type vector ,xx))
+            ,@(when (dd-named dd)
+                `((unless (eql (aref ,xx 0) ',class-name)
+                    (error
+                     'simple-type-error
+                     :datum (aref ,xx 0)
+                     :expected-type `(member ,class-name)
+                     :format-control
+                     "~@<missing name in instance of ~
                       VECTOR-typed structure ~S: ~2I~_S~:>"
-                    :format-arguments (list ',class-name ,xx)))))
-           (values))))
+                     :format-arguments (list ',class-name ,xx)))))
+            (values))))
       ((list)
        (with-unique-names (xx)
-        `(let ((,xx ,x))
-           (declare (type list ,xx))
-           ,@(when (dd-named dd)
-               `((unless (eql (first ,xx) ',class-name)
-                   (error
-                    'simple-type-error
-                    :datum (aref ,xx 0)
-                    :expected-type `(member ,class-name)
-                    :format-control
-                    "~@<missing name in instance of LIST-typed structure ~S: ~
+         `(let ((,xx ,x))
+            (declare (type list ,xx))
+            ,@(when (dd-named dd)
+                `((unless (eql (first ,xx) ',class-name)
+                    (error
+                     'simple-type-error
+                     :datum (aref ,xx 0)
+                     :expected-type `(member ,class-name)
+                     :format-control
+                     "~@<missing name in instance of LIST-typed structure ~S: ~
                       ~2I~_S~:>"
-                    :format-arguments (list ',class-name ,xx)))))
-           (values)))))))
+                     :format-arguments (list ',class-name ,xx)))))
+            (values)))))))
 
 ;;; Check that X is an instance of the structure class with layout LAYOUT.
 (defun %check-structure-type-from-layout (x layout)
   (unless (typep-to-layout x layout)
     (error 'type-error
-          :datum x
-          :expected-type (classoid-name (layout-classoid layout))))
+           :datum x
+           :expected-type (classoid-name (layout-classoid layout))))
   (values))
 \f
 (/show0 "target-defstruct.lisp end of file")