;; character set.
:sb-unicode
+ ;; Record source location information for variables, classes, conditions,
+ ;; packages, etc. Gives much better information on M-. in Slime, but
+ ;; increases core size by about 100kB.
+ :sb-source-locations
+
;; This affects the definition of a lot of things in bignum.lisp. It
;; doesn't seem to be documented anywhere what systems it might apply
;; to. It doesn't seem to be needed for X86 systems anyway.
;; This comes early because it's useful for debugging everywhere.
("src/code/show")
+ ;; This comes as early as possible, so that we catch the source locations
+ ;; for everything.
+ ("src/code/early-source-location")
+
;; This comes early because the cross-compilation host's backquote
;; logic can expand into something which can't be executed on the
;; target Lisp (e.g. in CMU CL where it expands into internal
("src/compiler/dump")
("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp
+ ("src/code/source-location")
("src/compiler/target-main" :not-host)
("src/compiler/ir1tran")
("src/compiler/ir1tran-lambda")
;;; TODO
;;; 1) structs don't have within-file location info. problem for the
;;; structure itself, accessors and the predicate
-;;; 2) what should find-definition-source on a symbol return? there may be
-;;; several definitions (class, function, etc)
;;; 3) error handling. Signal random errors, or handle and resignal 'our'
;;; error, or return NIL?
;;; 4) FIXMEs
-;;; 5) would be nice to have some interface to the compiler that lets us
-;;; fake the filename and position, for use with C-M-x
(defpackage :sb-introspect
(:use "CL")
(:export "FUNCTION-ARGLIST"
"VALID-FUNCTION-NAME-P"
"FIND-DEFINITION-SOURCE"
+ "FIND-DEFINITION-SOURCES-BY-NAME"
"DEFINITION-SOURCE"
"DEFINITION-SOURCE-PATHNAME"
"DEFINITION-SOURCE-FORM-PATH"
;; Null if not compiled from a file.
(file-write-date nil :type (or null integer))
;; plist from WITH-COMPILATION-UNIT
- (plist nil))
+ (plist nil)
+ ;; Any extra metadata that the caller might be interested in. For
+ ;; example the specializers of the method whose definition-source this
+ ;; is.
+ (description nil :type list))
+
+(defun find-definition-sources-by-name (name type)
+ "Returns a list of DEFINITION-SOURCEs for the objects of type TYPE
+defined with name NAME. NAME may be a symbol or a extended function
+name. Type can currently be one of the following:
+
+ (Public)
+ :CLASS
+ :COMPILER-MACRO
+ :CONDITION
+ :CONSTANT
+ :FUNCTION
+ :GENERIC-FUNCTION
+ :MACRO
+ :METHOD
+ :METHOD-COMBINATION
+ :PACKAGE
+ :SETF-EXPANDER
+ :STRUCTURE
+ :SYMBOL-MACRO
+ :TYPE
+ :VARIABLE
+
+ (Internal)
+ :OPTIMIZER
+ :SOURCE-TRANSFORM
+ :TRANSFORM
+ :VOP
+
+If an unsupported TYPE is requested, the function will return NIL.
+"
+ (flet ((listify (x)
+ (if (listp x)
+ x
+ (list x))))
+ (listify
+ (case type
+ ((:variable)
+ (when (eq (sb-int:info :variable :kind name) :special)
+ (translate-source-location (sb-int:info :source-location type name))))
+ ((:constant)
+ (when (eq (sb-int:info :variable :kind name) :constant)
+ (translate-source-location (sb-int:info :source-location type name))))
+ ((:symbol-macro)
+ (when (eq (sb-int:info :variable :kind name) :macro)
+ (translate-source-location (sb-int:info :source-location type name))))
+ ((:macro)
+ (when (and (symbolp name)
+ (macro-function name))
+ (find-definition-source (macro-function name))))
+ ((:compiler-macro)
+ (when (compiler-macro-function name)
+ (find-definition-source (compiler-macro-function name))))
+ ((:function :generic-function)
+ (when (and (fboundp name)
+ (or (not (symbolp name))
+ (not (macro-function name))))
+ (let ((fun (fdefinition name)))
+ (when (eq (not (typep fun 'generic-function))
+ (not (eq type :generic-function)))
+ (find-definition-source fun)))))
+ ((:type)
+ (let ((expander-fun (sb-int:info :type :expander name)))
+ (when expander-fun
+ (find-definition-source expander-fun))))
+ ((:method)
+ (when (and (fboundp name)
+ (typep (fdefinition name) 'generic-function))
+ (loop for method in (sb-mop::generic-function-methods
+ (fdefinition name))
+ for source = (find-definition-source method)
+ when source collect source)))
+ ((:setf-expander)
+ (when (and (consp name)
+ (eq (car name) 'setf))
+ (setf name (cadr name)))
+ (let ((expander-fun (or (sb-int:info :setf :inverse name)
+ (sb-int:info :setf :expander name))))
+ (when expander-fun
+ (sb-introspect:find-definition-source expander-fun))))
+ ((:structure)
+ (let ((class (ignore-errors (find-class name))))
+ (if class
+ (when (typep class 'sb-pcl::structure-class)
+ (find-definition-source class))
+ (when (sb-int:info :typed-structure :info name)
+ (translate-source-location
+ (sb-int:info :source-location :typed-structure name))))))
+ ((:condition :class)
+ (let ((class (ignore-errors (find-class name))))
+ (when class
+ (when (eq (not (typep class 'sb-pcl::condition-class))
+ (not (eq type :condition)))
+ (find-definition-source class)))))
+ ((:method-combination)
+ (let ((combination-fun
+ (ignore-errors (find-method #'sb-mop:find-method-combination
+ nil
+ (list (find-class 'generic-function)
+ (list 'eql name)
+ t)))))
+ (when combination-fun
+ (find-definition-source combination-fun))))
+ ((:package)
+ (when (symbolp name)
+ (let ((package (find-package name)))
+ (when package
+ (find-definition-source package)))))
+ ;;; TRANSFORM and OPTIMIZER handling from swank-sbcl
+ ((:transform)
+ (let ((fun-info (sb-int:info :function :info name)))
+ (when fun-info
+ (loop for xform in (sb-c::fun-info-transforms fun-info)
+ for source = (find-definition-source
+ (sb-c::transform-function xform))
+ for typespec = (sb-kernel:type-specifier
+ (sb-c::transform-type xform))
+ for note = (sb-c::transform-note xform)
+ do (setf (definition-source-description source)
+ (if (consp typespec)
+ (list (second typespec) note)
+ (list note)))
+ collect source))))
+ ((:optimizer)
+ (let ((fun-info (sb-int:info :function :info name)))
+ (when fun-info
+ (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
+ (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
+ (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
+ (sb-c::fun-info-optimizer . sb-c:optimizer))))
+ (loop for (reader . name) in otypes
+ for fn = (funcall reader fun-info)
+ when fn collect
+ (let ((source (find-definition-source fn)))
+ (setf (definition-source-description source)
+ (list name))
+ source))))))
+ ((:vop)
+ (let ((fun-info (sb-int:info :function :info name)))
+ (when fun-info
+ (loop for vop in (sb-c::fun-info-templates fun-info)
+ for source = (find-definition-source
+ (sb-c::vop-info-generator-function vop))
+ do (setf (definition-source-description source)
+ (list (sb-c::template-name vop)
+ (sb-c::template-note vop)))
+ collect source))))
+ ((:source-transform)
+ (let ((transform-fun (sb-int:info :function :source-transform name)))
+ (when transform-fun
+ (sb-introspect:find-definition-source transform-fun))))
+ (t
+ nil)))))
(defun find-definition-source (object)
- (etypecase object
+ (typecase object
+ ((or sb-pcl::condition-class sb-pcl::structure-class)
+ (let ((classoid (sb-impl::find-classoid (class-name object))))
+ (when classoid
+ (let ((layout (sb-impl::classoid-layout classoid)))
+ (when layout
+ (translate-source-location
+ (sb-kernel::layout-source-location layout)))))))
+ (method-combination
+ (car
+ (find-definition-sources-by-name (sb-pcl::method-combination-type object)
+ :method-combination)))
+ (package
+ (translate-source-location (sb-impl::package-source-location object)))
+ (class
+ (translate-source-location (sb-pcl::definition-source object)))
+ ;; Use the PCL definition location information instead of the function
+ ;; debug-info for methods and generic functions. Sometimes the
+ ;; debug-info would point into PCL internals instead of the proper
+ ;; location.
+ (generic-function
+ (let ((source (translate-source-location
+ (sb-pcl::definition-source object))))
+ (when source
+ (setf (definition-source-description source)
+ (list (sb-mop:generic-function-lambda-list object))))
+ source))
(method
- (find-definition-source (or (sb-pcl::method-fast-function object)
- (sb-pcl:method-function object))))
+ (let ((source (translate-source-location
+ (sb-pcl::definition-source object))))
+ (when source
+ (setf (definition-source-description source)
+ (append (method-qualifiers object)
+ (sb-pcl::unparse-specializers
+ (sb-mop:method-specializers object)))))
+ source))
(function
(cond ((struct-accessor-p object)
- (find-definition-source (struct-accessor-structure-class object)))
+ (find-definition-source
+ (struct-accessor-structure-class object)))
((struct-predicate-p object)
- (find-definition-source (struct-predicate-structure-class object)))
- (t (find-function-definition-source object))))
- (structure-class
- (let ((constructor
- (sb-kernel::structure-classoid-constructor
- (sb-kernel:classoid-cell-classoid
- (sb-int:info :type :classoid (class-name object))))))
- (find-definition-source constructor)))
+ (find-definition-source
+ (struct-predicate-structure-class object)))
+ (t
+ (find-function-definition-source object))))
(t
- (if (valid-function-name-p object)
- (find-definition-source (or (macro-function object)
- (fdefinition object)))))))
+ (error "Don't know how to retrive source location for a ~S~%"
+ (type-of object)))))
(defun find-function-definition-source (function)
(let* ((debug-info (function-debug-info function))
:file-write-date (sb-c::debug-source-created debug-source)
:plist (sb-c::debug-source-plist debug-source))))
+(defun translate-source-location (location)
+ (if location
+ (make-definition-source
+ :pathname (let ((n (sb-c:definition-source-location-namestring location)))
+ (when n
+ (parse-namestring n)))
+ :form-path
+ (let ((number (sb-c:definition-source-location-toplevel-form-number
+ location)))
+ (when number
+ (list number)))
+ :plist (sb-c:definition-source-location-plist location))
+ (make-definition-source)))
+
;;; This is kludgey. We expect these functions (the underlying functions,
;;; not the closures) to be in static space and so not move ever.
;;; FIXME It's also possibly wrong: not all structures use these vanilla
(assert (equal (function-arglist 'the)
'(type sb-c::value)))
-(let ((source (find-definition-source 'cl-user::one)))
+(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))))
+(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")))
(= form-number
(first (sb-introspect:definition-source-form-path ds))))))
-(assert (matchp 'cl-user::one 2))
+(defun matchp-name (type object form-number)
+ (let ((ds (car (sb-introspect:find-definition-sources-by-name object type))))
+ (and (pathnamep (sb-introspect:definition-source-pathname ds))
+ (= form-number
+ (first (sb-introspect:definition-source-form-path ds))))))
+
+(defun matchp-length (type object form-numbers)
+ (let ((ds (sb-introspect:find-definition-sources-by-name object type)))
+ (= (length ds) form-numbers)))
+
+(assert (matchp-name :function 'cl-user::one 2))
(assert (matchp #'cl-user::one 2))
-; (assert (matchp 'two 2)) ; defgenerics don't work yet
+(assert (matchp-name :generic-function 'cl-user::two 3))
(assert (matchp (car (sb-pcl:generic-function-methods #'cl-user::two)) 4))
+(assert (matchp-name :variable 'cl-user::*a* 8))
+(assert (matchp-name :variable 'cl-user::*b* 9))
+(assert (matchp-name :class 'cl-user::a 10))
+(assert (matchp-name :condition 'cl-user::b 11))
+(assert (matchp-name :structure 'cl-user::c 12))
+(assert (matchp-name :function 'cl-user::make-c 12))
+(assert (matchp-name :function 'cl-user::c-e 12))
+(assert (matchp-name :structure 'cl-user::d 13))
+(assert (matchp-name :function 'cl-user::make-d 13))
+(assert (matchp-name :function 'cl-user::d-e 13))
+(assert (matchp-name :package 'cl-user::e 14))
+(assert (matchp-name :symbol-macro 'cl-user::f 15))
+(assert (matchp-name :type 'cl-user::g 16))
+(assert (matchp-name :constant 'cl-user::+h+ 17))
+(assert (matchp-length :method 'cl-user::j 2))
+(assert (matchp-name :macro 'cl-user::l 20))
+(assert (matchp-name :compiler-macro 'cl-user::m 21))
+(assert (matchp-name :setf-expander 'cl-user::n 22))
+(assert (matchp-name :function '(setf cl-user::o) 23))
+(assert (matchp-name :method '(setf cl-user::p) 24))
+(assert (matchp-name :macro 'cl-user::q 25))
+(assert (matchp-name :method-combination 'cl-user::r 26))
+(assert (matchp-name :setf-expander 'cl-user::s 27))
+
+
;;; Unix success convention for exit codes
(sb-ext:quit :unix-status 0)
(with-compilation-unit (:source-plist (list :test-inner "IN"))
(eval '(defun four () 4)))
+
+"oops-off-by-one"
+
+(defparameter *a* 1)
+
+(defvar *b* 2)
+
+(defclass a ()
+ (a))
+
+(define-condition b (warning) (a))
+
+(defstruct c e f)
+
+(defstruct (d (:type list)) e f)
+
+(defpackage e (:use :cl))
+
+(define-symbol-macro f 'e)
+
+(deftype g () 'fixnum)
+
+(defconstant +h+ 1)
+
+(defmethod j ((a t))
+ 2)
+
+(defmethod j ((b null))
+ 2)
+
+(defmacro l (a)
+ a)
+
+(define-compiler-macro m (a)
+ (declare (ignore a))
+ 'b)
+
+(defsetf n (a) (store)
+ (format t "~a ~a~%" a store))
+
+(defun (setf o) (x)
+ (print x))
+
+(defmethod (setf p) (x y)
+ (format t "~a ~a~%" x y))
+
+(define-modify-macro q (x) logand)
+
+(define-method-combination r nil)
+
+(define-setf-expander s (a b)
+ (format t "~a ~a~%" a b))
+
"!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS"
"DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
"DEFINE-ASSEMBLY-ROUTINE"
+ "DEFINITION-SOURCE-LOCATION"
+ "DEFINITION-SOURCE-LOCATION-NAMESTRING"
+ "DEFINITION-SOURCE-LOCATION-TOPLEVEL-FORM-NUMBER"
+ "DEFINITION-SOURCE-LOCATION-PLIST"
"DEFINE-MODULAR-FUN"
"DEFINE-MOVE-FUN"
"DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE"
"SC-OFFSET-OFFSET" "SC-OFFSET-SCN" "SC-OR-LOSE" "SC-P" "SC-SB"
"SET-UNWIND-PROTECT" "SET-VECTOR-SUBTYPE"
"SETUP-CLOSURE-ENVIRONMENT" "SETUP-ENVIRONMENT"
+ "SOURCE-LOCATION"
"SOURCE-TRANSFORM-LAMBDA"
"SPECIFY-SAVE-TN"
"TAIL-CALL" "TAIL-CALL-NAMED"
"VM-SUPPORT-ROUTINES-GENERATE-CALL-SEQUENCE"
"VM-SUPPORT-ROUTINES-GENERATE-RETURN-SEQUENCE"
"VM-SUPPORT-ROUTINES-EMIT-NOP"
- "VM-SUPPORT-ROUTINES-LOCATION-NUMBER"))
+ "VM-SUPPORT-ROUTINES-LOCATION-NUMBER"
+
+ "WITH-SOURCE-LOCATION"
+ "*SOURCE-LOCATION-THUNKS*"))
#s(sb-cold:package-data
:name "SB!DEBUG"
(pure nil :type (member t nil 0))
;; Number of raw words at the end.
;; This slot is known to the C runtime support code.
- (n-untagged-slots 0 :type index))
+ (n-untagged-slots 0 :type index)
+ ;; Definition location
+ (source-location nil))
(def!method print-object ((layout layout) stream)
(print-unreadable-object (layout stream :type t :identity t)
(condition-writer-function condition new-value slot-name))))
(defun %define-condition (name parent-types layout slots documentation
- report default-initargs all-readers all-writers)
+ report default-initargs all-readers all-writers
+ source-location)
(with-single-package-locked-error
(:symbol name "defining ~A as a condition")
(%compiler-define-condition name parent-types layout all-readers all-writers)
+ (sb!c:with-source-location (source-location)
+ (setf (layout-source-location layout)
+ source-location))
(let ((class (find-classoid name)))
(setf (condition-classoid-slots class) slots)
(setf (condition-classoid-report class) report)
,report
(list ,@default-initargs)
',(all-readers)
- ',(all-writers)))))))
+ ',(all-writers)
+ (sb!c:source-location)))))))
\f
;;;; DESCRIBE on CONDITIONs
;;;; files for more information.
(in-package "SB!IMPL")
+
\f
;;;; IN-PACKAGE
#-sb-xc-host ,named-lambda
#+sb-xc-host (fdefinition ',name)
,doc
- ',inline-lambda))))))
+ ',inline-lambda
+ (sb!c:source-location)))))))
#-sb-xc-host
-(defun %defun (name def doc inline-lambda)
+(defun %defun (name def doc inline-lambda source-location)
+ (declare (ignore source-location))
(declare (type function def))
(declare (type (or null simple-string) doc))
(aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN
(eval-when (:compile-toplevel)
(%compiler-defvar ',var))
(eval-when (:load-toplevel :execute)
- (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp))))
+ (%defvar ',var (unless (boundp ',var) ,val)
+ ',valp ,doc ',docp
+ (sb!c:source-location)))))
(defmacro-mundanely defparameter (var val &optional (doc nil docp))
#!+sb-doc
(eval-when (:compile-toplevel)
(%compiler-defvar ',var))
(eval-when (:load-toplevel :execute)
- (%defparameter ',var ,val ,doc ',docp))))
+ (%defparameter ',var ,val ,doc ',docp (sb!c:source-location)))))
(defun %compiler-defvar (var)
(sb!xc:proclaim `(special ,var)))
#-sb-xc-host
-(defun %defvar (var val valp doc docp)
+(defun %defvar (var val valp doc docp source-location)
(%compiler-defvar var)
(when valp
(unless (boundp var)
(set var val)))
(when docp
(setf (fdocumentation var 'variable) doc))
+ (sb!c:with-source-location (source-location)
+ (setf (info :source-location :variable var) source-location))
var)
#-sb-xc-host
-(defun %defparameter (var val doc docp)
+(defun %defparameter (var val doc docp source-location)
(%compiler-defvar var)
(set var val)
(when docp
(setf (fdocumentation var 'variable) doc))
+ (sb!c:with-source-location (source-location)
+ (setf (info :source-location :variable var) source-location))
var)
\f
;;;; iteration constructs
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%defpackage ,(stringify-name package "package") ',nicknames ',size
',shadows ',shadowing-imports ',(if use-p use :default)
- ',imports ',interns ',exports ',implement ',lock ',doc))))
+ ',imports ',interns ',exports ',implement ',lock ',doc
+ (sb!c:source-location)))))
(defun check-disjoint (&rest args)
;; An arg is (:key . set)
names))
(defun %defpackage (name nicknames size shadows shadowing-imports
- use imports interns exports implement lock doc-string)
+ use imports interns exports implement lock doc-string
+ source-location)
(declare (type simple-string name)
(type list nicknames shadows shadowing-imports
imports interns exports)
:use nil
:internal-symbols (or size 10)
:external-symbols (length exports))))))
+ (sb!c:with-source-location (source-location)
+ (setf (package-source-location package) source-location))
(unless (string= (the string (package-name package)) name)
(error 'simple-package-error
:package name
;; class.
(with-single-package-locked-error
(:symbol ',name "defining ~A as a structure"))
- (%defstruct ',dd ',inherits)
+ (%defstruct ',dd ',inherits (sb!c:source-location))
(eval-when (:compile-toplevel :load-toplevel :execute)
(%compiler-defstruct ',dd ',inherits))
,@(unless expanding-into-code-for-xc-host-p
(:symbol ',name "defining ~A as a structure"))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (info :typed-structure :info ',name) ',dd))
+ (eval-when (:load-toplevel :execute)
+ (setf (info :source-location :typed-structure ',name)
+ (sb!c:source-location)))
,@(unless expanding-into-code-for-xc-host-p
(append (typed-accessor-definitions dd)
(typed-predicate-definitions dd)
;;; incompatible redefinition. Define those functions which are
;;; sufficiently stereotyped that we can implement them as standard
;;; closures.
-(defun %defstruct (dd inherits)
+(defun %defstruct (dd inherits source-location)
(declare (type defstruct-description dd))
;; We set up LAYOUTs even in the cross-compilation host.
(setq layout (classoid-layout classoid))))
(setf (find-classoid (dd-name dd)) classoid)
+ (sb!c:with-source-location (source-location)
+ (setf (layout-source-location layout) source-location))
+
;; Various other operations only make sense on the target SBCL.
#-sb-xc-host
(%target-defstruct dd layout))
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 60)
+(def!constant +fasl-file-version+ 61)
;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
;;; 38: (2003-01-05) changed names of internal SORT machinery
;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to
;;; 59: (2005-09-18) METAOBJECT implementation, removal of INSTANCE and
;;; FUNCALLABLE-INSTANCE classes.
;;; 60: (2005-10-24) Bumped for 0.9.6
+;;; 61: (2005-11-06) Improved source location recording added extra parameters
+;;; to multiple %DEFMUMBLE functions.
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
--- /dev/null
+;;;; Minimal implementation of the source-location tracking machinery, which
+;;;; defers the real work to until source-location.lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(defvar *source-location-thunks* nil)
+
+;; Should get called only in unusual circumstances. Normally handled
+;; by a compiler macro.
+(defun source-location ()
+ nil)
+
+;; Will be redefined in src/code/source-location.lisp
+#-sb-xc-host
+(define-compiler-macro source-location ()
+ (when (and (boundp '*source-info*)
+ (symbol-value '*source-info*))
+ `(cons ,(make-file-info-namestring
+ *compile-file-pathname*
+ (source-info-file-info (symbol-value '*source-info*)))
+ ,(when (boundp '*current-path*)
+ (source-path-tlf-number (symbol-value '*current-path*))))))
+
+;; If the whole source location tracking machinery has been loaded
+;; (detected by the type of SOURCE-LOCATION), execute BODY. Otherwise
+;; wrap it in a lambda and execute later.
+(defmacro with-source-location ((source-location) &body body)
+ `(when ,source-location
+ (if (consp ,source-location)
+ (push (lambda ()
+ (let ((,source-location
+ (make-definition-source-location
+ :namestring (car ,source-location)
+ :toplevel-form-number (cdr ,source-location))))
+ ,@body))
+ *source-location-thunks*)
+ ,@body)))
(defmacro-mundanely define-symbol-macro (name expansion)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%define-symbol-macro ',name ',expansion)))
+ (sb!c::%define-symbol-macro ',name ',expansion (sb!c:source-location))))
-(defun sb!c::%define-symbol-macro (name expansion)
+(defun sb!c::%define-symbol-macro (name expansion source-location)
(unless (symbolp name)
(error 'simple-type-error :datum name :expected-type 'symbol
:format-control "Symbol macro name is not a symbol: ~S."
:format-arguments (list name)))
(with-single-package-locked-error
(:symbol name "defining ~A as a symbol-macro"))
+ (sb!c:with-source-location (source-location)
+ (setf (info :source-location :symbol-macro name) source-location))
(ecase (info :variable :kind name)
((:macro :global nil)
(setf (info :variable :kind name) :macro)
#!+sb-package-locks
(lock nil :type boolean)
#!+sb-package-locks
- (%implementation-packages nil :type list))
+ (%implementation-packages nil :type list)
+ ;; Definition source location
+ (source-location nil :type (or null sb!c:definition-source-location)))
\f
;;;; iteration macros
--- /dev/null
+;;;; Source location tracking.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(def!struct (definition-source-location
+ (:make-load-form-fun sb!kernel:just-dump-it-normally))
+ ;; Namestring of the source file that the definition was compiled from.
+ ;; This is null if the definition was not compiled from a file.
+ (namestring
+ (when (and (boundp '*source-info*)
+ *source-info*)
+ (make-file-info-namestring *compile-file-pathname*
+ (source-info-file-info *source-info*)))
+ :type (or string null))
+ ;; Toplevel form index
+ (toplevel-form-number
+ (when (boundp '*current-path*)
+ (source-path-tlf-number *current-path*))
+ :type (or fixnum null))
+ ;; plist from WITH-COMPILATION-UNIT
+ (plist *source-plist*))
+
+(defun make-file-info-namestring (name file-info)
+ (let* ((untruename (file-info-untruename file-info))
+ (dir (and untruename (pathname-directory untruename))))
+ #+sb-xc-host
+ (let ((src (position "src" dir :test #'string=
+ :from-end t)))
+ (if src
+ (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
+ (subseq dir src) (pathname-name untruename))
+ ;; FIXME: just output/stuff-groveled-from-headers.lisp
+ (namestring untruename)))
+ #-sb-xc-host
+ (if (and dir (eq (first dir) :absolute))
+ (namestring untruename)
+ (if name
+ (namestring name)
+ nil))))
+
+#!+sb-source-locations
+(define-compiler-macro source-location (&environment env)
+ #-sb-xc-host
+ (unless (policy env (and (> space 1)
+ (> space debug)))
+ (make-definition-source-location)))
+
+(/show0 "/Processing source location thunks")
+#!+sb-source-locations
+(dolist (fun *source-location-thunks*)
+ (/show0 ".")
+ (funcall fun))
+;; Unbind the symbol to ensure that we detect any attempts to add new
+;; thunks after this.
+(makunbound '*source-location-thunks*)
+(/show0 "/Done with source location thunks")
(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)))
- (setf (debug-source-name res)
- #+sb-xc-host
- (let ((src (position "src" dir :test #'string= :from-end t)))
- (if src
- (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
- (subseq dir src) (pathname-name untruename))
- ;; FIXME: just output/stuff-groveled-from-headers.lisp
- (namestring untruename)))
- #-sb-xc-host
- (namestring
- (if (and dir (eq (first dir) :absolute))
- untruename
- name))))))
+ (setf (debug-source-name res)
+ (make-file-info-namestring name file-info))))
res))
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
EQL to the new value, the code is not portable (undefined behavior). The
third argument is an optional documentation string for the variable."
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%defconstant ',name ,value ',documentation)))
+ (sb!c::%defconstant ',name ,value ',documentation
+ (sb!c:source-location))))
;;; the guts of DEFCONSTANT
-(defun sb!c::%defconstant (name value doc)
+(defun sb!c::%defconstant (name value doc source-location)
(unless (symbolp name)
(error "The constant name is not a symbol: ~S" name))
(about-to-modify-symbol-value name)
(style-warn "defining ~S as a constant, even though the name follows~@
the usual naming convention (names like *FOO*) for special variables"
name))
+ (sb!c:with-source-location (source-location)
+ (setf (info :source-location :constant name) source-location))
(let ((kind (info :variable :kind name)))
(case kind
(:constant
;;; FIXME: This information should probably be pulled out of the
;;; cross-compiler's tables at genesis time instead of inserted by
;;; hand here as a bare numeric constant.
-(defconstant target-layout-length 17)
+(defconstant target-layout-length 18)
;;; Return a list of names created from the cold layout INHERITS data
;;; in X.
:type-spec list
:default ())
+;;; Used to record the source location of definitions.
+(define-info-class :source-location)
+
+(define-info-type
+ :class :source-location
+ :type :variable
+ :type-spec t
+ :default nil)
+
+(define-info-type
+ :class :source-location
+ :type :constant
+ :type-spec t
+ :default nil)
+
+(define-info-type
+ :class :source-location
+ :type :typed-structure
+ :type-spec t
+ :default nil)
+
+(define-info-type
+ :class :source-location
+ :type :symbol-macro
+ :type-spec t
+ :default nil)
+
#!-sb-fluid (declaim (freeze-type info-env))
\f
;;; Now that we have finished initializing *INFO-CLASSES* and
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(compile-or-load-defgeneric ',fun-name))
- (load-defgeneric ',fun-name ',lambda-list ,@initargs)
+ (load-defgeneric ',fun-name ',lambda-list
+ (sb-c:source-location) ,@initargs)
,@(mapcar #'expand-method-definition methods)
(fdefinition ',fun-name)))))
(setf (info :function :type fun-name)
(specifier-type 'function))))
-(defun load-defgeneric (fun-name lambda-list &rest initargs)
+(defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
(when (fboundp fun-name)
(style-warn "redefining ~S in DEFGENERIC" fun-name)
(let ((fun (fdefinition fun-name)))
(apply #'ensure-generic-function
fun-name
:lambda-list lambda-list
- :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
+ :definition-source source-location
initargs))
(define-condition generic-function-lambda-list-error
;; addition to in the list. FIXME: We should no longer need to do
;; this, since the CLOS code is now SBCL-specific, and doesn't
;; need to be ported to every buggy compiler in existence.
- ',pv-table-symbol))
+ ',pv-table-symbol
+ (sb-c:source-location)))
(defmacro make-method-function (method-lambda &environment env)
(make-method-function-internal method-lambda env))
`(method-function-get ,method-function 'closure-generator))
(defun load-defmethod
- (class name quals specls ll initargs &optional pv-table-symbol)
+ (class name quals specls ll initargs pv-table-symbol source-location)
(setq initargs (copy-tree initargs))
(let ((method-spec (or (getf initargs :method-spec)
(make-method-spec name quals specls))))
(setf (getf initargs :method-spec) method-spec)
(load-defmethod-internal class name quals specls
- ll initargs pv-table-symbol)))
+ ll initargs pv-table-symbol
+ source-location)))
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
- initargs pv-table-symbol)
+ initargs pv-table-symbol source-location)
(when pv-table-symbol
(setf (getf (getf initargs :plist) :pv-table-symbol)
pv-table-symbol))
gf-spec qualifiers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
- :definition-source `((defmethod ,gf-spec
- ,@qualifiers
- ,specializers)
- ,*load-pathname*)
+ :definition-source source-location
initargs)))
(unless (or (eq method-class 'standard-method)
(eq (find-class method-class nil) (class-of method)))
(defun ensure-generic-function (fun-name
&rest all-keys
- &key environment
+ &key environment source-location
&allow-other-keys)
(declare (ignore environment))
(let ((existing (and (fboundp fun-name)
&key (lambda-list nil
lambda-list-p)
argument-precedence-order
+ source-location
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
(make-early-gf spec lambda-list lambda-list-p existing
- argument-precedence-order)
+ argument-precedence-order source-location)
(error "The function ~S is not already defined." spec)))
(existing
(error "~S should be on the list ~S."
(t
(pushnew spec *!early-generic-functions* :test #'equal)
(make-early-gf spec lambda-list lambda-list-p nil
- argument-precedence-order))))
+ argument-precedence-order source-location))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
- function argument-precedence-order)
+ function argument-precedence-order source-location)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-function
fin
(!bootstrap-set-slot 'standard-generic-function
fin
'source
- *load-pathname*)
+ source-location)
(set-fun-name fin spec)
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
(meta (ecd-metaclass definition))
- (source (ecd-source definition))
+ (source (ecd-source-location definition))
(direct-supers (ecd-superclass-names definition))
(direct-slots (ecd-canonical-slots definition))
(other-initargs (ecd-other-initargs definition)))
smc
name
value)))
- (set-slot 'source *load-pathname*)
+ (set-slot 'source nil)
(set-slot 'type 'standard)
(set-slot 'documentation "The standard method combination.")
(set-slot 'options ()))
canonical-options))
',*readers-for-this-defclass*
',*writers-for-this-defclass*
- ',*slot-names-for-this-defclass*))))
+ ',*slot-names-for-this-defclass*
+ (sb-c:source-location)))))
(if defstruct-p
(progn
;; FIXME: (YUK!) Why do we do this? Because in order
(error "~S is not a class in *early-class-definitions*." class-name)))
(defun make-early-class-definition
- (name source metaclass
+ (name source-location metaclass
superclass-names canonical-slots other-initargs)
(list 'early-class-definition
- name source metaclass
+ name source-location metaclass
superclass-names canonical-slots other-initargs))
(defun ecd-class-name (ecd) (nth 1 ecd))
-(defun ecd-source (ecd) (nth 2 ecd))
+(defun ecd-source-location (ecd) (nth 2 ecd))
(defun ecd-metaclass (ecd) (nth 3 ecd))
(defun ecd-superclass-names (ecd) (nth 4 ecd))
(defun ecd-canonical-slots (ecd) (nth 5 ecd))
(declaim (notinline load-defclass))
(defun load-defclass (name metaclass supers canonical-slots canonical-options
- readers writers slot-names)
+ readers writers slot-names source-location)
(%compiler-defclass name readers writers slot-names)
(setq supers (copy-tree supers)
canonical-slots (copy-tree canonical-slots)
canonical-options (copy-tree canonical-options))
(let ((ecd
(make-early-class-definition name
- *load-pathname*
+ source-location
metaclass
supers
canonical-slots
(operator
(getf (cddr whole) :operator type)))
`(load-short-defcombin
- ',type ',operator ',identity-with-one-arg ',documentation)))
+ ',type ',operator ',identity-with-one-arg ',documentation
+ (sb-c:source-location))))
-(defun load-short-defcombin (type operator ioa doc)
- (let* ((pathname *load-pathname*)
- (specializers
+(defun load-short-defcombin (type operator ioa doc source-location)
+ (let* ((specializers
(list (find-class 'generic-function)
(intern-eql-specializer type)
*the-class-t*))
(short-combine-methods
type options operator ioa new-method doc))
args))
- :definition-source `((define-method-combination ,type) ,pathname)))
+ :definition-source source-location))
(when old-method
(remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)
type lambda-list method-group-specifiers args-option gf-var
body)
`(load-long-defcombin ',type ',documentation #',function
- ',args-option))))
+ ',args-option (sb-c:source-location)))))
(defvar *long-method-combination-functions* (make-hash-table :test 'eq))
-(defun load-long-defcombin (type doc function args-lambda-list)
+(defun load-long-defcombin (type doc function args-lambda-list source-location)
(let* ((specializers
(list (find-class 'generic-function)
(intern-eql-specializer type)
:args-lambda-list args-lambda-list
:documentation doc))
args))
- :definition-source `((define-method-combination ,type)
- ,*load-pathname*))))
+ :definition-source source-location)))
(setf (gethash type *long-method-combination-functions*) function)
(when old-method (remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)
:initarg :from-defclass-p)))
(defclass definition-source-mixin (standard-object)
- ((source :initform *load-pathname* :reader definition-source
- :initarg :definition-source)))
+ ((source
+ :initform nil
+ :reader definition-source
+ :initarg :definition-source)))
(defclass plist-mixin (standard-object)
((plist :initform () :accessor object-plist)))
(constantly (make-member-type :members (list (specializer-object specl))))))
(defun real-load-defclass (name metaclass-name supers slots other
- readers writers slot-names)
+ readers writers slot-names source-location)
(with-single-package-locked-error (:symbol name "defining ~S as a class")
(%compiler-defclass name readers writers slot-names)
(let ((res (apply #'ensure-class name :metaclass metaclass-name
:direct-superclasses supers
:direct-slots slots
- :definition-source `((defclass ,name)
- ,*load-pathname*)
+ :definition-source source-location
other)))
res)))
;;; 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.6.24"
+"0.9.6.25"
projects / sbcl.git / commitdiff