From a27839c3a9c59b2ca1b4080de5a3a9dd682ac5b9 Mon Sep 17 00:00:00 2001 From: Didier Verna Date: Fri, 10 Jun 2011 13:02:56 +0300 Subject: [PATCH] sb-introspect: source locations for structure copiers Closely paralleling the existing hacks for structure accessors and copiers. --- contrib/sb-introspect/introspect.lisp | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index c7fc14f..9a18f8a 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -21,7 +21,7 @@ ;;; 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 @@ -357,6 +357,9 @@ If an unsupported TYPE is requested, the function will return NIL. ((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) @@ -413,6 +416,8 @@ If an unsupported TYPE is requested, the function will return NIL. (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))) @@ -420,6 +425,11 @@ If an unsupported TYPE is requested, the function will return NIL. (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 @@ -491,6 +501,9 @@ value." 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 @@ -501,6 +514,16 @@ value." (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 -- 1.7.10.4