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.

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index 8e9c9a9..fe02c07 100644 (file)
--- 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 (file)
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 (file)
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 (file)
--- 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"