Commit 9908313f authored by Daniel Barlow's avatar Daniel Barlow
Browse files

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.
parent 1e9966d5
Loading
Loading
Loading
Loading
+58 −6
Original line number Diff line number Diff line
;;; 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)))))
+16 −0
Original line number Diff line number Diff line
(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))
+14 −0
Original line number Diff line number Diff line
;; 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
+1 −1
Original line number Diff line number Diff line
@@ -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"