(in-package "SB!KERNEL")
-(file-comment
- "$Header$")
+(/show0 "target-defstruct.lisp 12")
\f
;;;; structure frobbing primitives
(defun %set-funcallable-instance-info (fin i new-value)
(%set-funcallable-instance-info fin i new-value))
-(defun funcallable-instance-function (fin)
+(defun funcallable-instance-fun (fin)
(%funcallable-instance-lexenv fin))
;;; The heart of the magic of funcallable instances ("FINs"). The
;;; both the code pointer and the lexenv, since that code pointer (for
;;; an instance-lambda) is expecting that lexenv to be accessed. This
;;; effectively pre-flattens what would otherwise be a chain of
-;;; indirections. Lest this sound like an excessively obscure case,
-;;; note that it happens when PCL dispatch functions are
-;;; byte-compiled.
+;;; indirections. (That used to happen when PCL dispatch functions
+;;; were byte-compiled; now that the byte compiler is gone, I can't
+;;; think of another example offhand. -- WHN 2001-10-06)
;;;
;;; The only loss is that if someone accesses the
-;;; FUNCALLABLE-INSTANCE-FUNCTION, then won't get a FIN back. This
-;;; probably doesn't matter, since PCL only sets the FIN function. And
-;;; the only reason that interpreted functions are FINs instead of
-;;; bare closures is for debuggability.
-(defun (setf funcallable-instance-function) (new-value fin)
- (setf (%funcallable-instance-function fin)
- (%closure-function new-value))
+;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This probably
+;;; doesn't matter, since PCL only sets the FIN function. And the only
+;;; reason that interpreted functions are FINs instead of bare
+;;; closures is for debuggability.
+(defun (setf funcallable-instance-fun) (new-value fin)
+ (setf (%funcallable-instance-fun fin)
+ (%closure-fun new-value))
(setf (%funcallable-instance-lexenv fin)
(if (funcallable-instance-p new-value)
(%funcallable-instance-lexenv new-value)
(output-symbol-name (dsd-%name slot) stream)
(write-char #\space stream)
(pprint-newline :miser stream)
- (output-object (funcall (fdefinition (dsd-accessor slot))
- structure)
- stream)
+ (output-object
+ (funcall (fdefinition (dsd-accessor-name slot))
+ structure)
+ stream)
(when (null slots)
(return))
(write-char #\space stream)
(slots (dd-slots dd) (cdr slots)))
((or (null slots)
(and (not *print-readably*)
+ *print-length*
(>= index *print-length*)))
(if (null slots)
(write-string ")" stream)
(let ((slot (first slots)))
(output-symbol-name (dsd-%name slot) stream)
(write-char #\space stream)
- (output-object (funcall (fdefinition (dsd-accessor slot))
- structure)
- stream))))))))
+ (output-object
+ (funcall (fdefinition (dsd-accessor-name slot))
+ structure)
+ stream))))))))
(def!method print-object ((x structure-object) stream)
(default-structure-print x stream *current-level*))
;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that
;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code.
(and (typep obj 'instance)
- (let (;; FIXME: Mightn't there be a slight efficiency improvement
- ;; by delaying the binding of DEPTHOID 'til it's needed?
- (depthoid (layout-depthoid layout))
- (obj-layout (%instance-layout obj)))
+ (let ((obj-layout (%instance-layout obj)))
(cond ((eq obj-layout layout)
t)
;; FIXME: Does the test for LAYOUT-INVALID really belong
:expected-type (layout-class obj-layout)
:datum obj))
(t
- (and (> (layout-depthoid obj-layout) depthoid)
- (eq (svref (layout-inherits obj-layout) depthoid)
- layout)))))))
+ (let ((depthoid (layout-depthoid layout)))
+ (and (> (layout-depthoid obj-layout) depthoid)
+ (eq (svref (layout-inherits obj-layout) depthoid)
+ layout))))))))
\f
;;;; implementing structure slot accessors as closures
(unless (structure-test structure)
(error 'simple-type-error
:datum structure
- ;; FIXME: :EXPECTED-TYPE should be something
- ;; comprehensible to the user, not this. Perhaps we
- ;; could work backwards from the LAYOUT-CLASS slot to
- ;; find something. (Note that all four SIMPLE-TYPE-ERROR
- ;; calls in this section have the same disease.)
- :expected-type '(satisfies structure-test)
+ :expected-type (class-name (layout-class layout))
:format-control
"Structure for accessor ~S is not a ~S:~% ~S"
:format-arguments
- (list (dsd-accessor dsd)
+ (list (dsd-accessor-name dsd)
(sb!xc:class-name (layout-class layout))
structure))))
(%instance-ref structure (dsd-index dsd)))
:format-control
"The structure for accessor ~S is not a ~S:~% ~S"
:format-arguments
- (list (dsd-accessor dsd) class
+ (list (dsd-accessor-name dsd) class
structure)))
(%instance-ref structure (dsd-index dsd))))))
(defun structure-slot-setter (layout dsd)
(unless (structure-test structure)
(error 'simple-type-error
:datum structure
- :expected-type '(satisfies structure-test)
+ :expected-type (class-name (layout-class layout))
:format-control
"The structure for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(sb!xc:class-name (layout-class layout))
structure)))
(unless (typep-test new-value)
(error 'simple-type-error
:datum new-value
- :expected-type '(satisfies typep-test)
+ :expected-type (class-name (layout-class layout))
:format-control
"The new value for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(dsd-type dsd)
new-value))))
(setf (%instance-ref structure (dsd-index dsd)) new-value))
(unless (structure-test structure)
(error 'simple-type-error
:datum structure
- :expected-type '(satisfies structure-test)
+ :expected-type (class-name (layout-class layout))
:format-control
"The structure for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(sb!xc:class-name class)
structure)))
(unless (typep-test new-value)
(error 'simple-type-error
:datum new-value
- :expected-type '(satisfies typep-test)
+ :expected-type (class-name (layout-class layout))
:format-control
"The new value for setter ~S is not a ~S:~% ~S"
:format-arguments
- (list `(setf ,(dsd-accessor dsd))
+ (list `(setf ,(dsd-accessor-name dsd))
(dsd-type dsd)
new-value))))
(setf (%instance-ref structure (dsd-index dsd)) new-value)))))
+
+(/show0 "target-defstruct.lisp end of file")
projects / sbcl.git / blobdiff