(dolist (dsd (dd-slots dd))
(/show0 "doing FDEFINITION for slot accessor")
(let ((accessor-name (dsd-accessor-name dsd)))
- (/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)))))
+ ;; 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))))))
;; Set FDEFINITION for copier.
(when (dd-copier-name dd)
((structure funcallable-structure)
(/show0 "with-LAYOUT case")
(lambda (object)
- (declare (optimize (speed 3) (safety 0)))
- (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..")
- (/nohexstr object)
- (/nohexstr layout)
- (typep-to-layout object layout)))
+ (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
*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.
(defun %default-structure-pretty-print (structure stream)
(let* ((layout (%instance-layout structure))
- (name (sb!xc:class-name (layout-class layout)))
+ (name (classoid-name (layout-classoid layout)))
(dd (layout-info layout)))
(pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
(prin1 name stream)
(pprint-newline :linear stream))))))))
(defun %default-structure-ugly-print (structure stream)
(let* ((layout (%instance-layout structure))
- (name (sb!xc:class-name (layout-class layout)))
+ (name (classoid-name (layout-classoid layout)))
(dd (layout-info layout)))
(descend-into (stream)
(write-string "#S(" stream)
(declare (ignore object environment))
(if slot-names
(error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
- :just-dump-it-normally))
+ :sb-just-dump-it-normally))
\f
;;;; testing structure types
((layout-invalid obj-layout)
(/noshow0 "LAYOUT-INVALID case")
(error 'layout-invalid
- :expected-type (layout-class obj-layout)
+ :expected-type (layout-classoid obj-layout)
:datum obj))
(t
(let ((depthoid (layout-depthoid layout)))
(unless (typep-to-layout x layout)
(error 'type-error
:datum x
- :expected-type (class-name (layout-class layout))))
+ :expected-type (classoid-name (layout-classoid layout))))
(values))
\f
(/show0 "target-defstruct.lisp end of file")