initargs, making them be a list of (INITARG INITFORM INITFUNCTION)
as per the MOP, rather than the historical (INITARG INITFUNCTION
INITFORM). (reported by Bruno Haible)
+ * new feature: WITH-COMPILATION-UNIT now accepts a non-standard
+ :SOURCE-PLIST option. See (DOCUMENTATION #'WITH-COMPILATION-UNIT T)
+ for more information.
* SB-SPROF now works (more) reliably on non-GENCGC platforms.
* fixed some lockups due to gc/thread interaction
* dynamic space size on PPC has been increased to 768Mb. (thanks to
(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"
+ "DEFINITION-SOURCE-PATHNAME"
"DEFINITION-SOURCE-FORM-PATH"
"DEFINITION-SOURCE-CHARACTER-OFFSET"
"DEFINITION-SOURCE-FILE-WRITE-DATE"
+ "DEFINITION-SOURCE-PLIST"
+ "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
"FIND-FUNCTION-CALLEES"
- "FIND-FUNCTION-CALLERS"
- ))
+ "FIND-FUNCTION-CALLERS"))
+
(in-package :sb-introspect)
;;;; Internal interface for SBCL debug info
(declaim (ftype (function (debug-info) debug-source) debug-info-source))
(defun debug-info-source (debug-info)
- (destructuring-bind (debug-source &rest other-debug-sources)
- (sb-c::compiled-debug-info-source debug-info)
- ;; COMPILED-DEBUG-INFO-SOURCES can return a list but we expect
- ;; this to always contain exactly one element in SBCL. The list
- ;; interface is inherited from CMUCL. -luke (12/Mar/2005)
- (assert (null other-debug-sources))
- debug-source))
+ (sb-c::debug-info-source debug-info))
(declaim (ftype (function (debug-info) debug-function) debug-info-debug-function))
(defun debug-info-debug-function (debug-info)
(character-offset nil :type (or null integer))
;; File-write-date of the source file when compiled.
;; Null if not compiled from a file.
- (file-write-date nil :type (or null integer)))
+ (file-write-date nil :type (or null integer))
+ ;; plist from WITH-COMPILATION-UNIT
+ (plist nil))
(defun find-definition-source (object)
(etypecase object
;; debug-source. FIXME: We could use sb-di:code-locations to get
;; a full source path. -luke (12/Mar/2005)
:form-path (if tlf (list tlf))
- :file-write-date (sb-c::debug-source-created debug-source))))
+ :file-write-date (sb-c::debug-source-created debug-source)
+ :plist (sb-c::debug-source-plist debug-source))))
;;; This is kludgey. We expect these functions (the underlying functions,
;;; not the closures) to be in static space and so not move ever.
(:use "SB-INTROSPECT" "CL"))
(in-package :sb-introspect-test)
-(load (compile-file (merge-pathnames "test.lisp" *load-pathname*)))
+(with-compilation-unit (:source-plist (list :test-outer "OUT"))
+ (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)))
(assert (equal (function-arglist 'the)
'(type sb-c::value)))
-(assert (= (definition-source-file-write-date
- (find-definition-source 'cl-user::one))
- (file-write-date (merge-pathnames "test.lisp" *load-pathname*))))
+
+(let ((source (find-definition-source 'cl-user::one)))
+ (assert (= (definition-source-file-write-date source)
+ (file-write-date (merge-pathnames "test.lisp" *load-pathname*))))
+ (assert (equal (getf (definition-source-plist source) :test-outer)
+ "OUT")))
+
+(let ((plist (definition-source-plist (find-definition-source 'cl-user::four))))
+ (assert (equal (getf plist :test-outer) "OUT"))
+ (assert (equal (getf plist :test-inner) "IN")))
(defun matchp (object form-number)
(let ((ds (sb-introspect:find-definition-source object)))
(defstruct three four five)
-
-
\ No newline at end of file
+(with-compilation-unit (:source-plist (list :test-inner "IN"))
+ (eval '(defun four () 4)))
;;; to at least know which function is an XEP for the real function
;;; (which would be useful info anyway).
\f
-;;;; debug source
+;;;; DEBUG SOURCE
+;;; There is one per compiled file and one per function compiled at
+;;; toplevel or loaded from source.
(def!struct (debug-source #-sb-xc-host (:pure t))
;; This slot indicates where the definition came from:
;; :FILE - from a file (i.e. COMPILE-FILE)
;; :DEBUG-SOURCE-FORM is :LISP.
(start-positions nil :type (or (simple-array * (*)) null))
;; If from :LISP, this is the function whose source is form 0.
- (info nil))
+ (function nil)
+ ;; Additional information from (WITH-COMPILATION-UNIT (:SOURCE-PLIST ...))
+ (plist *source-plist*))
\f
;;;; DEBUG-INFO structures
;; *** NOTE: the offset of this slot is wired into the fasl dumper
;; *** so that it can backpatch the source info when compilation
;; *** is complete.
- (source nil :type list))
+ (source nil))
(def!struct (compiled-debug-info
(:include debug-info)
;;; Return the CODE-LOCATION's DEBUG-SOURCE.
(defun code-location-debug-source (code-location)
- (etypecase code-location
- (compiled-code-location
- (let* ((info (compiled-debug-fun-debug-info
- (code-location-debug-fun code-location)))
- (sources (sb!c::compiled-debug-info-source info))
- (len (length sources)))
- (declare (list sources))
- (when (zerop len)
- (debug-signal 'no-debug-blocks :debug-fun
- (code-location-debug-fun code-location)))
- (if (= len 1)
- (car sources)
- (do ((prev sources src)
- (src (cdr sources) (cdr src))
- (offset (code-location-toplevel-form-offset code-location)))
- ((null src) (car prev))
- (when (< offset (sb!c::debug-source-source-root (car src)))
- (return (car prev)))))))
- ;; (There used to be more cases back before sbcl-0.7.0, when we
- ;; did special tricks to debug the IR1 interpreter.)
- ))
+ (let ((info (compiled-debug-fun-debug-info
+ (code-location-debug-fun code-location))))
+ (or (sb!c::debug-info-source info)
+ (debug-signal 'no-debug-blocks :debug-fun
+ (code-location-debug-fun code-location)))))
;;; Returns the number of top level forms before the one containing
;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
(declare (type stream s))
(let ((info (sb-kernel:%code-debug-info code-obj)))
(when info
- (let ((sources (sb-c::debug-info-source info)))
- (when sources
+ (let ((source (sb-c::debug-info-source info)))
+ (when source
(format s "~&On ~A it was compiled from:"
;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system
;; should become more consistent, probably not using
;; any nondefault options.
- (format-universal-time nil
- (sb-c::debug-source-compiled
- (first sources))
+ (format-universal-time nil (sb-c::debug-source-compiled source)
:style :abbreviated))
- (dolist (source sources)
- (let ((name (sb-c::debug-source-name source)))
- (ecase (sb-c::debug-source-from source)
- (:file
- (format s "~&~A~@:_ Created: " (namestring name))
- (format-universal-time s (sb-c::debug-source-created
- source)))
- (:lisp (format s "~&~S" name))))))))))
+ (let ((name (sb-c::debug-source-name source)))
+ (ecase (sb-c::debug-source-from source)
+ (:file
+ (format s "~&~A~@:_ Created: " (namestring name))
+ (format-universal-time s (sb-c::debug-source-created source)))
+ (:lisp (format s "~&~S" name)))))))))
;;; Describe a compiled function. The closure case calls us to print
;;; the guts.
(code (sb!di::fun-code-header fun))
(info (sb!kernel:%code-debug-info code)))
(if info
- (let ((source (first (sb!c::compiled-debug-info-source info))))
+ (let ((source (sb!c::debug-info-source info)))
(cond ((and (eq (sb!c::debug-source-from source) :lisp)
- (eq (sb!c::debug-source-info source) fun))
+ (eq (sb!c::debug-source-function source) fun))
(values (svref (sb!c::debug-source-name source) 0)
nil
name))
(values (copy-seq *byte-buffer*) tlf-num)))
\f
-;;; Return a list of DEBUG-SOURCE structures containing information
-;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always
-;;; dump the START-POSITIONS, since it is too hard figure out whether
-;;; we need them or not.
+;;; Return DEBUG-SOURCE structure containing information derived from
+;;; INFO.
(defun debug-source-for-info (info)
(declare (type source-info info))
(let* ((file-info (source-info-file-info info))
(name (file-info-name file-info)))
(etypecase name
((member :lisp)
- (setf (debug-source-from res) name)
- (setf (debug-source-name res)
- (coerce (file-info-forms file-info) 'simple-vector)))
+ (setf (debug-source-from res) name
+ (debug-source-name res) (file-info-forms file-info)))
(pathname
(let* ((untruename (file-info-untruename file-info))
(dir (pathname-directory untruename)))
(if (and dir (eq (first dir) :absolute))
untruename
name))))))
- (list res)))
+ res))
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
;;; possible. Ordinarily we coerce it to the smallest specialized
(error "Unresolved forward reference."))))
;;; Backpatch all the DEBUG-INFOs dumped so far with the specified
-;;; SOURCE-INFO list. We also check that there are no outstanding forward
-;;; references to functions.
-(defun fix-core-source-info (info object &optional source-info)
- (declare (type source-info info) (type core-object object))
+;;; SOURCE-INFO list. We also check that there are no outstanding
+;;; forward references to functions.
+(defun fix-core-source-info (info object &optional function)
+ (declare (type core-object object)
+ (type (or null function) function))
(aver (zerop (hash-table-count (core-object-patch-table object))))
- (let ((res (debug-source-for-info info)))
- (dolist (sinfo res)
- (setf (debug-source-info sinfo) source-info))
+ (let ((source (debug-source-for-info info)))
+ (setf (debug-source-function source) function)
(dolist (info (core-object-debug-info object))
- (setf (compiled-debug-info-source info) res))
- (setf (core-object-debug-info object) ()))
+ (setf (debug-info-source info) source)))
+ (setf (core-object-debug-info object) nil)
(values))
This form affects compilations that take place within its dynamic extent. It
is intended to be wrapped around the compilation of all files in the same
system. These keywords are defined:
+
:OVERRIDE Boolean-Form
One of the effects of this form is to delay undefined warnings
until the end of the form, instead of giving them at the end of each
compilation. If OVERRIDE is NIL (the default), then the outermost
WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
OVERRIDE true causes that form to grab any enclosed warnings, even if
- it is enclosed by another WITH-COMPILATION-UNIT."
+ it is enclosed by another WITH-COMPILATION-UNIT.
+
+ :SOURCE-PLIST Plist-Form
+ Attaches the value returned by the Plist-Form to internal debug-source
+ information of functions compiled in within the dynamic contour.
+ Primarily for use by development environments, in order to eg. associate
+ function definitions with editor-buffers. Can be accessed as
+ SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested
+ WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended
+ togather, innermost left. If Unaffected by :OVERRIDE."
`(%with-compilation-unit (lambda () ,@body) ,@options))
-(defun %with-compilation-unit (fn &key override)
+(defvar *source-plist* nil)
+
+(defun %with-compilation-unit (fn &key override source-plist)
(declare (type function fn))
- (let ((succeeded-p nil))
+ (let ((succeeded-p nil)
+ (*source-plist* (append source-plist *source-plist*)))
(if (and *in-compilation-unit* (not override))
;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
;; ordinarily (unless OVERRIDE) basically a no-op.
;;; 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.9.1.24"
+"0.9.1.25"
projects / sbcl.git / commitdiff