From 9908313f6f76672cfc28c48b21c9aa88daeb8d10 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Fri, 10 Oct 2003 04:05:00 +0000 Subject: [PATCH] 0.8.4.16 More navel-gazing ... FIND-DEFINITION-SOURCE takes a thing and returns the source pathname and location at which it was defined. Currently works for only a small number of things (simple functions and methods of gfs) and returns the location as the number of source forms from the start of the file. Suspect that a character offset would be a better bet. Poor pretence for a test case added as well. So far no framework to automate same. --- contrib/sb-introspect/sb-introspect.lisp | 64 +++++++++++++++++++++++++++--- contrib/sb-introspect/test-driver.lisp | 16 ++++++++ contrib/sb-introspect/test.lisp | 14 +++++++ version.lisp-expr | 2 +- 4 files changed, 89 insertions(+), 7 deletions(-) create mode 100644 contrib/sb-introspect/test-driver.lisp create mode 100644 contrib/sb-introspect/test.lisp diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 8e9c9a9..fe02c07 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -1,19 +1,28 @@ +;;; This is here as a discussion point, not yet a supported interface. If +;;; you would like to use the functions here, or you would like other +;;; functions to be here, join the debate on sbcl-devel + +;;; For the avoidance of doubt, the exported interface is the +;;; proposed supported interface. + (defpackage :sb-introspect (:use "CL") - (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P")) - + (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P" + "FIND-DEFINITION-SOURCE" + "DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME" + "DEFINITION-NOT-FOUND" "DEFINITION-NAME" + "DEFINITION-SOURCE-FORM-NUMBER" ; unsure. character offset instead? + )) (in-package :sb-introspect) -;; This is here as a discussion point, not yet a supported interface. If -;; you would like to use the functions here, or you would like other -;; functions to be here, join the debate on sbcl-devel (defun valid-function-name-p (name) "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION " (and (sb-int:valid-function-name-p name) t)) (defun function-arglist (function) - "Given a function designator FUNCTION, return a description of its lambda list. Works for macros, simple functions and generic functions" + "Describe the lambda list for the function designator FUNCTION. +Works for macros, simple functions and generic functions" (cond ((valid-function-name-p function) (function-arglist (or (macro-function function) (fdefinition function)))) @@ -22,3 +31,46 @@ (t (sb-impl::%simple-fun-arglist function)))) +;;; Considering whether to throw this or something like it when a definition +;;; is unforthcoming. Presently we do something undefined (NIL or random +;;; error) +(define-condition definition-not-found (error) + ((name :initarg :name :reader definition-name)) + (:report (lambda (c s) + (format s "No definition for ~S known" (definition-name c))))) + +;;; find-definition-source returns a definition-source object, with accessors +;;; as per export list. Might not be a struct. +(defstruct definition-source pathname form-number) + + +;;; the intention is that everything we're able to query the source +;;; location for, we should be able to do it through this gf +(defgeneric find-definition-source (thing)) + +;;; breaks on structure accessors, probably other closures as well +(defmethod find-definition-source ((o function)) + (let* ((name (sb-vm::%simple-fun-name o)) + (debug-info + (sb-kernel:%code-debug-info (sb-kernel:fun-code-header o))) + (debug-source (car (sb-c::compiled-debug-info-source debug-info)))) + ;; FIXME why only the first debug-source? can there be >1? + (sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info)))) + (make-definition-source + :pathname + (and (eql (sb-c::debug-source-from debug-source) :file) + (parse-namestring (sb-c::debug-source-name debug-source))) + :form-number + (loop for debug-fun across (sb-c::compiled-debug-info-fun-map debug-info) + when (and (sb-c::debug-fun-p debug-fun) + (eql (sb-c::compiled-debug-fun-name debug-fun) name)) + return (sb-c::compiled-debug-fun-tlf-number debug-fun))))) + +(defmethod find-definition-source ((o method)) + (find-definition-source (or (sb-pcl::method-fast-function o) + (sb-pcl:method-function o)))) + +(defmethod find-definition-source (name) + (and (valid-function-name-p name) + (find-definition-source (or (macro-function name) (fdefinition name))))) + diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp new file mode 100644 index 0000000..fa4372d --- /dev/null +++ b/contrib/sb-introspect/test-driver.lisp @@ -0,0 +1,16 @@ +(defpackage :sb-introspect-test + (:use "SB-INTROSPECT" "CL")) +(load (compile-file (merge-pathnames "test.lisp" *load-pathname*))) + +(assert (equal (function-arglist 'cl-user::one) + '(cl-user::a cl-user::b cl-user::c))) + +(defun matchp (object form-number) + (let ((ds (sb-introspect:find-definition-source object))) + (and (pathnamep (sb-introspect:definition-source-pathname ds)) + (= form-number (sb-introspect:definition-source-form-number ds))))) + +(assert (matchp 'cl-user::one 2)) +(assert (matchp #'cl-user::one 2)) +; (assert (matchp 'two 2)) ; defgenerics don't work yet +(assert (matchp (car (sb-pcl:generic-function-methods #'cl-user::two)) 4)) diff --git a/contrib/sb-introspect/test.lisp b/contrib/sb-introspect/test.lisp new file mode 100644 index 0000000..50e3161 --- /dev/null +++ b/contrib/sb-introspect/test.lisp @@ -0,0 +1,14 @@ +;; Do not alter this file unless you edit test-driver.lisp to match +(declaim (optimize (debug 3))) +(in-package :cl-user) + +(defun one (a b c) (+ a b c)) + +(defgeneric two (a b)) +(defmethod two ((a number) b) + (* 2 a)) + +(defstruct three four five) + + + \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index a18bf5b..4fb6f34 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.4.15" +"0.8.4.16" -- 1.7.10.4