Dramatically improve source recording on SYS::SOURCE plist for a symbol (Alan Ruttenberg)

The interface to recording information on the SYS:%SOURCE plist for a
symbol is now deprecated and will be removed with abcl-1.7.

Implementation
--------------

Source information for ABCL is now recorded on the SYS::SOURCE
property.  The appropiate information for type is recorded by the
SYS::RECORD-SOURCE-INFORMATION-BY-TYPE function:

    record-source-information-by-type (name type &optional source-pathname source-position)

TYPE is either a symbol or list.

Source information for functions, methods, and generic functions are
represented as lists of the following form:

    (:generic-function function-name)
    (:function function-name)
    (:method method-name qualifiers specializers)

Where FUNCTION-NAME or METHOD-NAME can be a either be of the form
'symbol or '(setf symbol).

Source information for all other forms have a symbol for TYPE which is
one of the following:

:class, :variable, :condition, :constant, :compiler-macro, :macro
:package, :structure, :type, :setf-expander, :source-transform

These values follow SBCL'S implemenation in SLIME
c.f. <https://github.com/slime/slime/blob/bad2acf672c33b913aabc1a7facb9c3c16a4afe9/swank/sbcl.lisp#L748>

Modifications are in two places, one at the definitions, calling
record-source-information-by-type and then again in the file-compiler,
which writes forms like

    (put 'source name (cons (list type pathname position) (get 'source name)))

In theory this can lead to redundancy if a fasl is loaded again and
again. I'm not sure how to fix this yet. Forms in the __loader__ get
called early in build when many of the sequence functions aren't
present.  Will probably just filter when presenting in slime.

<> :closes <http://abcl.org/trac/ticket/421> .
<> :merges <https://github.com/armedbear/abcl/pull/5> .
parent 94678cf5
build
dist
abcl
......@@ -394,7 +394,7 @@ public final class Load
// ### *fasl-version*
// internal symbol
static final Symbol _FASL_VERSION_ =
exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(42));
exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(43));
// ### *fasl-external-format*
// internal symbol
......
......@@ -1725,6 +1725,7 @@ compare the method combination name to the symbol 'standard.")
',function-name
:lambda-list ',lambda-list
,@(canonicalize-defgeneric-options options))
(sys::record-source-information-for-type ',function-name '(:generic-function ,function-name))
,@methods)))
(defun canonicalize-defgeneric-options (options)
......@@ -2891,6 +2892,7 @@ to ~S with argument list ~S."
(push `',specializer specializers-form))))
(setf specializers-form `(list ,@(nreverse specializers-form)))
`(progn
(sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))
(ensure-method ',function-name
:lambda-list ',lambda-list
:qualifiers ',qualifiers
......@@ -3033,6 +3035,13 @@ generic functions without providing sensible behaviour."
(let ((temp-sym (gensym)))
`(progn
(defgeneric ,temp-sym ,@rest)
(sys::record-source-information-for-type ',function-name '(:generic-function ,function-name))
,@(loop for method-form in rest
when (eq (car method-form) :method)
collect
(multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
(mop::parse-defmethod `(,function-name ,@(rest method-form)))
`(sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))))
(let ((gf (symbol-function ',temp-sym)))
;; FIXME (rudi 2012-07-08): fset gets the source location info
;; to charpos 23 always (but (setf fdefinition) leaves the
......@@ -3238,12 +3247,14 @@ instance and, for setters, `new-value' the new value."
(unless (>= (length form) 3)
(error 'program-error "Wrong number of arguments for DEFCLASS."))
(check-declaration-type name)
`(ensure-class ',name
`(progn
(sys::record-source-information-for-type ',name :class)
(ensure-class ',name
:direct-superclasses
(canonicalize-direct-superclasses ',direct-superclasses)
:direct-slots
,(canonicalize-direct-slots direct-slots)
,@(canonicalize-defclass-options options)))
,@(canonicalize-defclass-options options))))
;;; AMOP pg. 180
......@@ -4127,10 +4138,12 @@ or T when any keyword is acceptable due to presence of
(typecase report
(null
`(progn
(sys::record-source-information-for-type ',name :condition)
(defclass ,name ,parent-types ,slot-specs ,@options)
',name))
(string
`(progn
(sys::record-source-information-for-type ',name :condition)
(defclass ,name ,parent-types ,slot-specs ,@options)
(defmethod print-object ((condition ,name) stream)
(if *print-escape*
......@@ -4139,6 +4152,7 @@ or T when any keyword is acceptable due to presence of
',name))
(t
`(progn
(sys::record-source-information-for-type ',name :condition)
(defclass ,name ,parent-types ,slot-specs ,@options)
(defmethod print-object ((condition ,name) stream)
(if *print-escape*
......
......@@ -267,7 +267,10 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
;; it always evaluates to the same value."
(note-toplevel-form form)
(eval form)
form)
`(progn
(put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form) 'sys::source nil)))
,form)
)
(declaim (ftype (function (t t t) t) process-toplevel-quote))
(defun process-toplevel-quote (form stream compile-time-too)
......@@ -299,6 +302,21 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(list sym-or-syms))))))
(precompile-toplevel-form form stream compile-time-too))
(declaim (ftype (function (t t t) t) process-record-source-information))
(defun process-record-source-information (form stream compile-time-too)
(declare (ignore stream compile-time-too))
(let* ((name (second form))
(type (third form)))
(when (quoted-form-p name) (setq name (second name)))
(when (quoted-form-p type) (setq type (second type)))
(let ((sym (if (consp name) (second name) name)))
`(put ',sym 'sys::source (cons '(,type ,(namestring *source*) ,*source-position*)
(get ',sym 'sys::source nil)))
)))
(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
(declare (ignore stream))
......@@ -358,19 +376,30 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
;; time."
(let ((name (second form)))
(%defvar name)))
form)
(let ((name (second form)))
`(progn
(put ',name 'sys::source (cons (list :variable ,(namestring *source*) ,*source-position*) (get ',name 'sys::source nil)))
,form)))
(declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package))
(defun process-toplevel-defpackage/in-package (form stream compile-time-too)
(declare (ignore stream compile-time-too))
(note-toplevel-form form)
(setf form
(precompiler:precompile-form form nil *compile-file-environment*))
(eval form)
;; Force package prefix to be used when dumping form.
(let ((*package* +keyword-package+))
(output-form form))
nil)
(let ((defpackage-name (and (eq (car form) 'defpackage) (intern (string (second form)) :keyword))) )
(setf form
(precompiler:precompile-form form nil *compile-file-environment*))
(eval form)
;; Force package prefix to be used when dumping form.
(let ((*package* +keyword-package+))
(output-form form))
;; a bit ugly here. Since we precompile, and added record-source-information we need to know where it is.
;; The defpackage is at top, so we know where the name is (though it is a string by now)
;; (if it is a defpackage)
(if defpackage-name
`(put ,defpackage-name 'sys::source
(cons '(:package ,(namestring *source*) ,*source-position*)
(get ,defpackage-name 'sys::source nil)))
nil)))
(declaim (ftype (function (t t t) t) process-toplevel-declare))
(defun process-toplevel-declare (form stream compile-time-too)
......@@ -388,7 +417,10 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(declare (ignore stream compile-time-too))
(note-toplevel-form form)
(eval form)
form)
`(progn
(put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form) 'sys::source nil)))
,form)
)
(declaim (ftype (function (t t t) t) process-toplevel-eval-when))
(defun process-toplevel-eval-when (form stream compile-time-too)
......@@ -431,8 +463,22 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
*toplevel-setf-functions*))
(let ((*compile-print* nil))
(process-toplevel-form (macroexpand-1 form *compile-file-environment*)
stream compile-time-too))
nil)
stream compile-time-too))
(let* ((sym (if (consp (second form)) (second (second form)) (second form))))
(when (eq (car form) 'defgeneric)
`(progn
(put ',sym 'sys::source
(cons '((:generic-function ,(second form)) ,(namestring *source*) ,*source-position*) (get ',sym 'sys::source nil)))
,@(loop for method-form in (cdddr form)
when (eq (car method-form) :method)
collect
(multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
(mop::parse-defmethod `(,(second form) ,@(rest method-form)))
`(put ',sym 'sys::source
(cons `((:method ,',sym ,',qualifiers ,',specializers) ,,(namestring *source*) ,,*source-position*)
(get ',sym 'sys::source nil)))))
))))
(declaim (ftype (function (t t t) t) process-toplevel-locally))
(defun process-toplevel-locally (form stream compile-time-too)
......@@ -476,12 +522,17 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(make-macro ',name
(sys::get-fasl-function *fasl-loader*
,saved-class-number)))
`(fset ',name
(make-macro ',name
(sys::get-fasl-function *fasl-loader*
,saved-class-number))
,*source-position*
',(third form))))))
`(progn
(put ',name 'sys::source
(cons '(:macro ,(namestring *source*) ,*source-position*) (get ',name 'sys::source nil)))
(fset ',name
(make-macro ',name
(sys::get-fasl-function *fasl-loader*
,saved-class-number))
,*source-position*
',(third form)
,(%documentation name 'cl:function)
))))))
(declaim (ftype (function (t t t) t) process-toplevel-defun))
(defun process-toplevel-defun (form stream compile-time-too)
......@@ -521,13 +572,16 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
compiled-function)
(when compile-time-too
(eval form))
(setf form
`(fset ',name
(let ((sym (if (consp name) (second name) name)))
(setf form
`(progn
(put ',sym 'sys::source (cons '((:function ,name) ,(namestring *source*) ,*source-position*) (get ',sym 'sys::source nil)))
(fset ',name
(sys::get-fasl-function *fasl-loader*
,saved-class-number)
,*source-position*
',lambda-list
,doc)))
,doc)))))
(t
(compiler-warn "Unable to compile function ~A. Using interpreted form instead.~%" name)
(when internal-compiler-errors
......@@ -599,7 +653,8 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
(REQUIRE precompile-toplevel-form)
(SHADOW precompile-toplevel-form)
(%SET-FDEFINITION precompile-toplevel-form)
(MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)))
(MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)
(record-source-information-for-type process-record-source-information)))
(install-toplevel-handler (car pair) (cadr pair)))
(declaim (ftype (function (t stream t) t) process-toplevel-form))
......@@ -896,7 +951,7 @@ interpreted toplevel form, non-NIL if it is 'simple enough'."
;; copy remaining content
(loop for line = (read-line in nil :eof)
while (not (eq line :eof))
do (write-line line out)))))
do (write-line line out)))))
(delete-file temp-file)
(when (find :windows *features*)
(remove-zip-cache-entry output-file))
......
......@@ -61,6 +61,7 @@
(declare (ignorable ,env))
(block ,block-name ,body))))
`(progn
(record-source-information-for-type ',name :compiler-macro)
(setf (compiler-macro-function ',name) (function ,expander))
',name)))))
......
......@@ -39,4 +39,6 @@
(when (special-variable-p symbol) ;;TODO astalla also check local declarations?
(error 'program-error "~S has already been defined as a global variable." symbol))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(record-source-information-for-type ',symbol :symbol-macro)
(record-source-information-for-type ',symbol :symbol-macro)
(%define-symbol-macro ',symbol ',expansion)))
;;; defmacro.lisp
;;;
;;; Copyright (C) 2003-2006 Peter Graves
;;; $Id$
;;; $Id: defmacro.lisp 13696 2011-11-15 22:34:19Z astalla $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
......@@ -41,6 +41,7 @@
(parse-defmacro lambda-list whole body name 'defmacro :environment env)
(let ((expander `(lambda (,whole ,env) ,@decls ,body)))
`(progn
(sys::record-source-information-for-type ',name :macro)
(let ((macro (make-macro ',name
(or (precompile nil ,expander) ,expander))))
,@(if (special-operator-p name)
......
......@@ -152,8 +152,13 @@
`(:shadow ,@shadows)
`(:shadowing-import-from
,@(apply #'append (mapcar #'rest shadowing-imports))))
`(%defpackage ,(string package) ',nicknames ',size
',shadows (ensure-available-symbols ',shadowing-imports)
',(if use-p use nil)
(ensure-available-symbols ',imports) ',interns ',exports
',local-nicknames ',doc)))
`(prog1
(%defpackage ,(string package) ',nicknames ',size
',shadows (ensure-available-symbols ',shadowing-imports)
',(if use-p use nil)
(ensure-available-symbols ',imports) ',interns ',exports
',local-nicknames ',doc)
,(when (and (symbolp package) (not (keywordp package)))
`(record-source-information-for-type ',package :package))
(record-source-information-for-type ,(intern (string package) :keyword) :package)
)))
......@@ -353,19 +353,23 @@
(type (dsd-type slot)))
(cond ((eq *dd-type* 'list)
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-list-reader ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-vector-reader ,index))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
`(aref (truly-the ,',*dd-type* ,instance) ,,index))))
(t
`((declaim (ftype (function * ,type) ,accessor-name))
(setf (symbol-function ',accessor-name)
(make-structure-reader ,index ',*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
,(if (eq type 't)
``(structure-ref (the ,',*dd-name* ,instance) ,,index)
......@@ -395,17 +399,20 @@
(let ((accessor-name (dsd-reader slot))
(index (dsd-index slot)))
(cond ((eq *dd-type* 'list)
`((setf (get ',accessor-name 'setf-function)
`((record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(setf (get ',accessor-name 'setf-function)
(make-list-writer ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((setf (get ',accessor-name 'setf-function)
(make-vector-writer ,index))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
(t
`((setf (get ',accessor-name 'setf-function)
(make-structure-writer ,index ',*dd-name*))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(structure-set (the ,',*dd-name* ,instance)
,,index ,value)))))))
......@@ -695,6 +702,7 @@
:slots ',*dd-slots*
:inherited-accessors ',*dd-inherited-accessors*
:documentation ',*dd-documentation*))
(record-source-information-for-type ',*dd-name* :structure)
,@(define-constructors)
,@(define-predicate)
,@(define-access-functions)
......
......@@ -57,6 +57,7 @@
(push thing new-lambda-list))
(setf lambda-list (nreverse new-lambda-list))))
`(progn
(record-source-information-for-type ',name :type)
(setf (get ',name 'deftype-definition)
#'(lambda ,lambda-list (block ,name ,@body)))
',name))
......
......@@ -80,6 +80,9 @@
(let ((doc (documentation object 'function)))
(when doc
(format stream "Function documentation:~% ~A~%" doc)))
(let ((doc (documentation object 'variable)))
(when doc
(format stream "Variable documentation:~% ~A~%" doc)))
(let ((plist (symbol-plist object)))
(when plist
(format stream "The symbol's property list contains these indicator/value pairs:~%")
......
......@@ -70,6 +70,18 @@
(cond ((symbolp name)
(put name '%source source)))))
(defun record-source-information-for-type (name type &optional source-pathname source-position)
(unless SYS::*LOAD-TRUENAME-FASL*
(unless source-pathname
(setf source-pathname (or *source* :top-level)))
(unless source-position
(setf source-position *source-position*))
(let ((source (if source-position
(list source-pathname source-position)
(list source-pathname))))
(let ((sym (if (consp name) (second name) name)))
(put sym 'sys::source (cons `(,type ,(if (symbolp (car source)) (car source) (namestring (car source))) ,(second source)) (get sym 'sys::source nil)))))))
;; Redefined in trace.lisp.
(defun trace-redefined-update (&rest args)
(declare (ignore args))
......
......@@ -654,6 +654,38 @@
(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence)
(setf (symbol-function 'common-lisp::file-position) #'gray-file-position)
(setf (symbol-function 'common-lisp::listen) #'gray-listen)
(dolist (e '((common-lisp::read-char gray-read-char)
(common-lisp::peek-char gray-peek-char)
(common-lisp::unread-char gray-unread-char)
(common-lisp::read-line gray-read-line)
(common-lisp::clear-input gray-clear-input)
(common-lisp::read-char-no-hang gray-read-char-no-hang)
(common-lisp::write-char gray-write-char)
(common-lisp::fresh-line gray-fresh-line)
(common-lisp::terpri gray-terpri)
(common-lisp::write-string gray-write-string)
(common-lisp::write-line gray-write-line)
(sys::%force-output gray-force-output)
(sys::%finish-output gray-finish-output)
(sys::%clear-output gray-clear-output)
(sys::%output-object gray-output-object)
(common-lisp::read-byte gray-read-byte)
(common-lisp::write-byte gray-write-byte)
(common-lisp::stream-column gray-stream-column)
(common-lisp::stream-element-type gray-stream-element-type)
(common-lisp::close gray-close)
(common-lisp::input-stream-p gray-input-stream-p)
(common-lisp::input-character-stream-p gray-input-character-stream-p) ;; # fb 1.01
(common-lisp::output-stream-p gray-output-stream-p)
(common-lisp::open-stream-p gray-open-stream-p)
(common-lisp::streamp gray-streamp)
(common-lisp::read-sequence gray-read-sequence)
(common-lisp::write-sequence gray-write-sequence)
(common-lisp::file-position gray-file-position)
(common-lisp::listen gray-listen)))
(sys::put (car e) 'sys::source (cl:get (second e) 'sys::source)))
#|
(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream)
(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream)
......
......@@ -1734,4 +1734,4 @@ be able to
|#
(provide '#:jvm-class-file)
\ No newline at end of file
(provide '#:jvm-class-file)
......@@ -41,14 +41,16 @@
(parse-defmacro lambda-list whole body access-fn
'define-setf-expander
:environment environment)
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(when doc
`((%set-documentation ',access-fn 'setf ,doc)))
(setf (get ',access-fn 'setf-expander)
#'(lambda (,whole ,environment)
,@local-decs
(block ,access-fn ,body)))
',access-fn))))
`(progn
(record-source-information-for-type ',access-fn :setf-expander)
(eval-when (:compile-toplevel :load-toplevel :execute)
,@(when doc
`((%set-documentation ',access-fn 'setf ,doc)))
(setf (get ',access-fn 'setf-expander)
#'(lambda (,whole ,environment)
,@local-decs
(block ,access-fn ,body)))
',access-fn)))))
(define-setf-expander values (&rest places &environment env)
(let ((setters ())
......
......@@ -50,10 +50,14 @@
`(return-from nil ,result))
(defmacro defconstant (name initial-value &optional docstring)
`(%defconstant ',name ,initial-value ,docstring))
`(progn
(record-source-information-for-type ',name :constant)
(%defconstant ',name ,initial-value ,docstring)))
(defmacro defparameter (name initial-value &optional docstring)
`(%defparameter ',name ,initial-value ,docstring))
`(progn
(record-source-information-for-type ',name :variable)
(%defparameter ',name ,initial-value ,docstring)))
(defmacro truly-the (type value)
`(the ,type ,value))
......@@ -177,6 +181,7 @@
(defmacro defvar (var &optional (val nil valp) (doc nil docp))
`(progn
(sys::record-source-information-for-type ',var :variable)
(%defvar ',var)
,@(when valp
`((unless (boundp ',var)
......
......@@ -1201,14 +1201,18 @@
(fset ',name ,lambda-expression)
',name))
(t
(when (and env (empty-environment-p env))
(when (and env (empty-environment-p env))
(setf env nil))
(when (null env)
(setf lambda-expression (precompiler:precompile-form lambda-expression nil)))
`(prog1
(%defun ',name ,lambda-expression)
,@(when doc
`((%set-documentation ',name 'function ,doc)))))))))
(let ((sym (if (consp name) (second name) name)))
`(prog1
(%defun ',name ,lambda-expression)
(record-source-information-for-type ',sym '(:function ,name))
; (%set-arglist (fdefinition ',name) ,(format nil "~{~s~^ ~}" (third lambda-expression)))
,@(when doc
`((%set-documentation ',name 'function ,doc)))
)))))))
(export '(precompile))
......
......@@ -57,9 +57,11 @@
(return-from ,block-name ,form))))
(expander
`(lambda (,form) (block ,block-name ,body))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (source-transform ',name) ,expander)
',name)))
`(progn
(record-source-information-for-type ',name '(:source-transform ,name))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (source-transform ',name) ,expander)
',name))))
(defun expand-source-transform-1 (form)
(let ((expander nil)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment