;;; TODO
;;; 1) structs don't have within-file location info. problem for the
-;;; structure itself, accessors and the predicate
+;;; structure itself, accessors, the copier and the predicate
;;; 3) error handling. Signal random errors, or handle and resignal 'our'
;;; error, or return NIL?
;;; 4) FIXMEs
((struct-predicate-p object)
(find-definition-source
(struct-predicate-structure-class object)))
+ ((struct-copier-p object)
+ (find-definition-source
+ (struct-copier-structure-class object)))
(t
(find-function-definition-source object))))
((or condition standard-object structure-object)
(sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
(defvar *struct-predicate*
(sb-vm::%simple-fun-self #'definition-source-p))
+(defvar *struct-copier*
+ (sb-vm::%simple-fun-self #'copy-definition-source))
(defun struct-accessor-p (function)
(let ((self (sb-vm::%simple-fun-self function)))
(member self (list *struct-slotplace-reader*
*struct-slotplace-writer*))))
+(defun struct-copier-p (function)
+ (let ((self (sb-vm::%simple-fun-self function)))
+ ;; FIXME there may be other structure copier functions
+ (member self (list *struct-copier*))))
+
(defun struct-predicate-p (function)
(let ((self (sb-vm::%simple-fun-self function)))
;; FIXME there may be other structure predicate functions
type
(sb-impl::%fun-type function-designator)))))))
+;;; FIXME: These three are pretty terrible. Can we place have some proper metadata
+;;; instead.
+
(defun struct-accessor-structure-class (function)
(let ((self (sb-vm::%simple-fun-self function)))
(cond
(sb-kernel:%closure-index-ref function 1)))))
)))
+(defun struct-copier-structure-class (function)
+ (let ((self (sb-vm::%simple-fun-self function)))
+ (cond
+ ((member self (list *struct-copier*))
+ (find-class
+ (sb-kernel::classoid-name
+ (sb-kernel::layout-classoid
+ (sb-kernel:%closure-index-ref function 0)))))
+ )))
+
(defun struct-predicate-structure-class (function)
(let ((self (sb-vm::%simple-fun-self function)))
(cond
(loop for i from 0 below (length array) by 2
for xref-name = (aref array i)
for xref-path = (aref array (1+ i))
- do (when (eql xref-name wanted-name)
+ do (when (equal xref-name wanted-name)
(let ((source-location
(find-function-definition-source simple-fun)))
;; Use the more accurate source path from
(let* ((addr (sb-kernel:get-lisp-obj-address object))
(space
(cond ((< sb-vm:read-only-space-start addr
- (* sb-vm:*read-only-space-free-pointer*
- sb-vm:n-word-bytes))
+ (ash sb-vm:*read-only-space-free-pointer*
+ sb-vm:n-fixnum-tag-bits))
:read-only)
((< sb-vm:static-space-start addr
- (* sb-vm:*static-space-free-pointer*
- sb-vm:n-word-bytes))
+ (ash sb-vm:*static-space-free-pointer*
+ sb-vm:n-fixnum-tag-bits))
:static)
((< (sb-kernel:current-dynamic-space-start) addr
(sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer)))
(case (sb-kernel:widetag-of object)
(#.sb-vm::value-cell-header-widetag
(call (sb-kernel::value-cell-ref object)))
- #+(and sb-lutex sb-thread)
- (#.sb-vm::lutex-widetag)
(t
(warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
(sb-kernel:widetag-of object) object)))))))