Changeset 14914


Ignore:
Timestamp:
11/24/16 10:31:17 (10 months ago)
Author:
mevenson
Message:

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> .

Location:
trunk/abcl
Files:
1 added
16 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/Load.java

    r14634 r14914  
    395395    // internal symbol
    396396    static final Symbol _FASL_VERSION_ =
    397         exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(42));
     397        exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(43));
    398398
    399399    // ### *fasl-external-format*
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r14529 r14914  
    17261726        :lambda-list ',lambda-list
    17271727        ,@(canonicalize-defgeneric-options options))
     1728       (sys::record-source-information-for-type ',function-name '(:generic-function ,function-name))
    17281729       ,@methods)))
    17291730
     
    28922893      (setf specializers-form `(list ,@(nreverse specializers-form)))
    28932894      `(progn
     2895   (sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))
    28942896         (ensure-method ',function-name
    28952897                        :lambda-list ',lambda-list
     
    30343036    `(progn
    30353037       (defgeneric ,temp-sym ,@rest)
     3038       (sys::record-source-information-for-type ',function-name '(:generic-function ,function-name))
     3039       ,@(loop for method-form in rest
     3040         when (eq (car method-form) :method)
     3041        collect
     3042        (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
     3043      (mop::parse-defmethod `(,function-name ,@(rest method-form)))
     3044          `(sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))))
    30363045       (let ((gf (symbol-function ',temp-sym)))
    30373046         ;; FIXME (rudi 2012-07-08): fset gets the source location info
     
    32393248    (error 'program-error "Wrong number of arguments for DEFCLASS."))
    32403249  (check-declaration-type name)
    3241   `(ensure-class ',name
     3250  `(progn
     3251     (sys::record-source-information-for-type ',name :class)
     3252     (ensure-class ',name
    32423253                 :direct-superclasses
    32433254                 (canonicalize-direct-superclasses ',direct-superclasses)
    32443255                 :direct-slots
    32453256                 ,(canonicalize-direct-slots direct-slots)
    3246                  ,@(canonicalize-defclass-options options)))
     3257                 ,@(canonicalize-defclass-options options))))
    32473258
    32483259
     
    41284139      (null
    41294140       `(progn
     4141    (sys::record-source-information-for-type  ',name :condition)
    41304142          (defclass ,name ,parent-types ,slot-specs ,@options)
    41314143          ',name))
    41324144      (string
    41334145       `(progn
     4146    (sys::record-source-information-for-type  ',name :condition)
    41344147          (defclass ,name ,parent-types ,slot-specs ,@options)
    41354148          (defmethod print-object ((condition ,name) stream)
     
    41404153      (t
    41414154       `(progn
     4155    (sys::record-source-information-for-type  ',name :condition)
    41424156          (defclass ,name ,parent-types ,slot-specs ,@options)
    41434157          (defmethod print-object ((condition ,name) stream)
  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r14460 r14914  
    268268  (note-toplevel-form form)
    269269  (eval form)
    270   form)
     270  `(progn
     271     (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form)  'sys::source nil)))
     272     ,form)
     273  )
    271274
    272275(declaim (ftype (function (t t t) t) process-toplevel-quote))
     
    300303  (precompile-toplevel-form form stream compile-time-too))
    301304
     305
     306(declaim (ftype (function (t t t) t) process-record-source-information))
     307
     308(defun process-record-source-information (form stream compile-time-too)
     309  (declare (ignore stream compile-time-too))
     310  (let* ((name (second form))
     311   (type (third form)))
     312    (when (quoted-form-p name) (setq name (second name)))
     313    (when (quoted-form-p type) (setq type (second type)))
     314    (let ((sym (if (consp name) (second name) name)))
     315      `(put ',sym 'sys::source (cons '(,type ,(namestring *source*) ,*source-position*)
     316           (get ',sym  'sys::source nil)))
     317      )))
     318
     319   
    302320(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
    303321(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
     
    359377      (let ((name (second form)))
    360378        (%defvar name)))
    361   form)
     379  (let ((name (second form)))
     380    `(progn
     381       (put ',name 'sys::source (cons (list :variable ,(namestring *source*) ,*source-position*) (get ',name  'sys::source nil)))
     382      ,form)))
    362383
    363384(declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package))
     
    365386  (declare (ignore stream compile-time-too))
    366387  (note-toplevel-form form)
    367   (setf form
    368         (precompiler:precompile-form form nil *compile-file-environment*))
    369   (eval form)
    370   ;; Force package prefix to be used when dumping form.
    371   (let ((*package* +keyword-package+))
    372     (output-form form))
    373   nil)
     388  (let ((defpackage-name (and (eq (car form) 'defpackage) (intern (string (second form)) :keyword))) )
     389    (setf form
     390    (precompiler:precompile-form form nil *compile-file-environment*))
     391    (eval form)
     392    ;; Force package prefix to be used when dumping form.
     393    (let ((*package* +keyword-package+))
     394      (output-form form))
     395    ;; a bit ugly here. Since we precompile, and added record-source-information we need to know where it is.
     396    ;; The defpackage is at top, so we know where the name is (though it is a string by now)
     397    ;; (if it is a defpackage)
     398    (if defpackage-name
     399  `(put ,defpackage-name 'sys::source
     400        (cons '(:package ,(namestring *source*) ,*source-position*)
     401        (get ,defpackage-name 'sys::source nil)))
     402  nil)))
    374403
    375404(declaim (ftype (function (t t t) t) process-toplevel-declare))
     
    389418  (note-toplevel-form form)
    390419  (eval form)
    391   form)
     420  `(progn
     421     (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form)  'sys::source nil)))
     422     ,form)
     423  )
    392424
    393425(declaim (ftype (function (t t t) t) process-toplevel-eval-when))
     
    432464  (let ((*compile-print* nil))
    433465    (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
    434                            stream compile-time-too))
    435   nil)
     466           stream compile-time-too))
     467  (let* ((sym (if (consp (second form)) (second (second form)) (second form))))
     468    (when (eq (car form) 'defgeneric)
     469      `(progn
     470   (put ',sym 'sys::source
     471        (cons  '((:generic-function ,(second form))  ,(namestring *source*) ,*source-position*) (get ',sym  'sys::source nil)))
     472   ,@(loop for method-form in (cdddr form)
     473     when (eq (car method-form) :method)
     474       collect
     475       (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
     476           (mop::parse-defmethod `(,(second form) ,@(rest method-form)))
     477         `(put ',sym 'sys::source
     478         (cons `((:method ,',sym ,',qualifiers ,',specializers) ,,(namestring *source*) ,,*source-position*)
     479         (get ',sym  'sys::source nil)))))
     480   ))))
     481
    436482
    437483(declaim (ftype (function (t t t) t) process-toplevel-locally))
     
    477523                            (sys::get-fasl-function *fasl-loader*
    478524                                                    ,saved-class-number)))
    479           `(fset ',name
    480                  (make-macro ',name
    481                              (sys::get-fasl-function *fasl-loader*
    482                                                      ,saved-class-number))
    483                  ,*source-position*
    484                  ',(third form))))))
     525    `(progn
     526       (put ',name 'sys::source
     527      (cons '(:macro  ,(namestring *source*) ,*source-position*) (get ',name  'sys::source nil)))
     528       (fset ',name
     529       (make-macro ',name
     530             (sys::get-fasl-function *fasl-loader*
     531                   ,saved-class-number))
     532       ,*source-position*
     533       ',(third form)
     534       ,(%documentation name 'cl:function)
     535       ))))))
    485536
    486537(declaim (ftype (function (t t t) t) process-toplevel-defun))
     
    522573               (when compile-time-too
    523574                 (eval form))
    524                (setf form
    525                      `(fset ',name
     575         (let ((sym (if (consp name) (second name) name)))
     576     (setf form
     577           `(progn
     578       (put ',sym 'sys::source (cons '((:function ,name)  ,(namestring *source*) ,*source-position*) (get ',sym  'sys::source nil)))           
     579       (fset ',name
    526580                            (sys::get-fasl-function *fasl-loader*
    527581                                                    ,saved-class-number)
    528582                            ,*source-position*
    529583                            ',lambda-list
    530                             ,doc)))
     584                            ,doc)))))
    531585              (t
    532586               (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
     
    600654                (SHADOW precompile-toplevel-form)
    601655                (%SET-FDEFINITION precompile-toplevel-form)
    602                 (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)))
     656                (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)
     657    (record-source-information-for-type process-record-source-information)))
    603658  (install-toplevel-handler (car pair) (cadr pair)))
    604659
     
    897952              (loop for line = (read-line in nil :eof)
    898953                 while (not (eq line :eof))
    899                  do (write-line line out)))))
     954        do (write-line line out)))))
    900955        (delete-file temp-file)
    901956        (when (find :windows *features*)
  • trunk/abcl/src/org/armedbear/lisp/compiler-macro.lisp

    r13597 r14914  
    6262                         (block ,block-name ,body))))
    6363        `(progn
     64     (record-source-information-for-type ',name :compiler-macro)
    6465           (setf (compiler-macro-function ',name) (function ,expander))
    6566           ',name)))))
  • trunk/abcl/src/org/armedbear/lisp/define-symbol-macro.lisp

    r13695 r14914  
    4040    (error 'program-error "~S has already been defined as a global variable." symbol))
    4141  `(eval-when (:compile-toplevel :load-toplevel :execute)
     42     (record-source-information-for-type ',symbol :symbol-macro)
     43     (record-source-information-for-type ',symbol :symbol-macro)
    4244     (%define-symbol-macro ',symbol ',expansion)))
  • trunk/abcl/src/org/armedbear/lisp/defmacro.lisp

    r13696 r14914  
    22;;;
    33;;; Copyright (C) 2003-2006 Peter Graves
    4 ;;; $Id$
     4;;; $Id: defmacro.lisp 13696 2011-11-15 22:34:19Z astalla $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    4242      (let ((expander `(lambda (,whole ,env) ,@decls ,body)))
    4343        `(progn
     44     (sys::record-source-information-for-type ',name :macro)
    4445           (let ((macro (make-macro ',name
    4546                                    (or (precompile nil ,expander) ,expander))))
  • trunk/abcl/src/org/armedbear/lisp/defpackage.lisp

    r14432 r14914  
    153153                    `(:shadowing-import-from
    154154                      ,@(apply #'append (mapcar #'rest shadowing-imports))))
    155     `(%defpackage ,(string package) ',nicknames ',size
    156                   ',shadows (ensure-available-symbols ',shadowing-imports)
    157                   ',(if use-p use nil)
    158                   (ensure-available-symbols ',imports) ',interns ',exports
    159                   ',local-nicknames ',doc)))
     155    `(prog1
     156       (%defpackage ,(string package) ',nicknames ',size
     157        ',shadows (ensure-available-symbols ',shadowing-imports)
     158        ',(if use-p use nil)
     159        (ensure-available-symbols ',imports) ',interns ',exports
     160        ',local-nicknames ',doc)
     161       ,(when (and (symbolp package) (not (keywordp package)))
     162    `(record-source-information-for-type ',package :package))
     163       (record-source-information-for-type ,(intern (string package) :keyword) :package)
     164       )))
  • trunk/abcl/src/org/armedbear/lisp/defstruct.lisp

    r14162 r14914  
    354354    (cond ((eq *dd-type* 'list)
    355355           `((declaim (ftype (function * ,type) ,accessor-name))
     356       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    356357             (setf (symbol-function ',accessor-name)
    357358                   (make-list-reader ,index))))
     
    359360               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    360361           `((declaim (ftype (function * ,type) ,accessor-name))
     362       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    361363             (setf (symbol-function ',accessor-name)
    362364                   (make-vector-reader ,index))
     365       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    363366             (define-source-transform ,accessor-name (instance)
    364367               `(aref (truly-the ,',*dd-type* ,instance) ,,index))))
     
    367370             (setf (symbol-function ',accessor-name)
    368371                   (make-structure-reader ,index ',*dd-name*))
     372       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
    369373             (define-source-transform ,accessor-name (instance)
    370374               ,(if (eq type 't)
     
    396400        (index (dsd-index slot)))
    397401    (cond ((eq *dd-type* 'list)
    398            `((setf (get ',accessor-name 'setf-function)
     402           `((record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
     403       (setf (get ',accessor-name 'setf-function)
    399404                   (make-list-writer ,index))))
    400405          ((or (eq *dd-type* 'vector)
     
    402407           `((setf (get ',accessor-name 'setf-function)
    403408                   (make-vector-writer ,index))
     409       (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
    404410             (define-source-transform (setf ,accessor-name) (value instance)
    405411               `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
     
    407413           `((setf (get ',accessor-name 'setf-function)
    408414                   (make-structure-writer ,index ',*dd-name*))
     415       (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
    409416             (define-source-transform (setf ,accessor-name) (value instance)
    410417               `(structure-set (the ,',*dd-name* ,instance)
     
    696703                             :inherited-accessors ',*dd-inherited-accessors*
    697704                             :documentation ',*dd-documentation*))
     705       (record-source-information-for-type ',*dd-name* :structure)
    698706       ,@(define-constructors)
    699707       ,@(define-predicate)
  • trunk/abcl/src/org/armedbear/lisp/deftype.lisp

    r11391 r14914  
    5858      (setf lambda-list (nreverse new-lambda-list))))
    5959  `(progn
     60     (record-source-information-for-type ',name :type)
    6061     (setf (get ',name 'deftype-definition)
    6162           #'(lambda ,lambda-list (block ,name ,@body)))
  • trunk/abcl/src/org/armedbear/lisp/describe.lisp

    r14478 r14914  
    8181         (when doc
    8282           (format stream "Function documentation:~%  ~A~%" doc)))
     83       (let ((doc (documentation object 'variable)))
     84         (when doc
     85           (format stream "Variable documentation:~%  ~A~%" doc)))
    8386       (let ((plist (symbol-plist object)))
    8487         (when plist
  • trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp

    r14451 r14914  
    7171           (put name '%source source)))))
    7272
     73(defun record-source-information-for-type (name type &optional source-pathname source-position)
     74  (unless SYS::*LOAD-TRUENAME-FASL*
     75    (unless source-pathname
     76      (setf source-pathname (or *source* :top-level)))
     77    (unless source-position
     78      (setf source-position *source-position*))
     79    (let ((source (if source-position
     80          (list source-pathname source-position)
     81          (list source-pathname))))
     82      (let ((sym (if (consp name) (second name) name)))
     83  (put sym 'sys::source (cons `(,type ,(if (symbolp (car source)) (car source) (namestring (car source))) ,(second source)) (get sym  'sys::source nil)))))))
     84
    7385;; Redefined in trace.lisp.
    7486(defun trace-redefined-update (&rest args)
  • trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp

    r14605 r14914  
    655655(setf (symbol-function 'common-lisp::file-position) #'gray-file-position)
    656656(setf (symbol-function 'common-lisp::listen) #'gray-listen)
     657
     658(dolist (e '((common-lisp::read-char gray-read-char)
     659       (common-lisp::peek-char gray-peek-char)
     660       (common-lisp::unread-char gray-unread-char)
     661       (common-lisp::read-line gray-read-line)
     662       (common-lisp::clear-input gray-clear-input)
     663       (common-lisp::read-char-no-hang gray-read-char-no-hang)
     664       (common-lisp::write-char gray-write-char)
     665       (common-lisp::fresh-line gray-fresh-line)
     666       (common-lisp::terpri gray-terpri)
     667       (common-lisp::write-string gray-write-string)
     668       (common-lisp::write-line gray-write-line)
     669       (sys::%force-output gray-force-output)
     670       (sys::%finish-output gray-finish-output)
     671       (sys::%clear-output gray-clear-output)
     672       (sys::%output-object gray-output-object)
     673       (common-lisp::read-byte gray-read-byte)
     674       (common-lisp::write-byte gray-write-byte)
     675       (common-lisp::stream-column gray-stream-column)
     676       (common-lisp::stream-element-type gray-stream-element-type)
     677       (common-lisp::close gray-close)
     678       (common-lisp::input-stream-p gray-input-stream-p)
     679       (common-lisp::input-character-stream-p gray-input-character-stream-p) ;; # fb 1.01
     680       (common-lisp::output-stream-p gray-output-stream-p)
     681       (common-lisp::open-stream-p gray-open-stream-p)
     682       (common-lisp::streamp gray-streamp)
     683       (common-lisp::read-sequence gray-read-sequence)
     684       (common-lisp::write-sequence gray-write-sequence)
     685       (common-lisp::file-position gray-file-position)
     686       (common-lisp::listen gray-listen)))
     687  (sys::put (car e) 'sys::source (cl:get (second e) 'sys::source)))
     688
    657689#|
    658690(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream)
  • trunk/abcl/src/org/armedbear/lisp/late-setf.lisp

    r14727 r14914  
    4242           'define-setf-expander
    4343           :environment environment)
    44       `(eval-when (:compile-toplevel :load-toplevel :execute)
    45          ,@(when doc
    46              `((%set-documentation ',access-fn 'setf ,doc)))
    47          (setf (get ',access-fn 'setf-expander)
    48              #'(lambda (,whole ,environment)
    49                 ,@local-decs
    50                 (block ,access-fn ,body)))
    51          ',access-fn))))
     44      `(progn
     45   (record-source-information-for-type ',access-fn :setf-expander)
     46   (eval-when (:compile-toplevel :load-toplevel :execute)
     47     ,@(when doc
     48         `((%set-documentation ',access-fn 'setf ,doc)))
     49     (setf (get ',access-fn 'setf-expander)
     50     #'(lambda (,whole ,environment)
     51         ,@local-decs
     52         (block ,access-fn ,body)))
     53     ',access-fn)))))
    5254
    5355(define-setf-expander values (&rest places &environment env)
  • trunk/abcl/src/org/armedbear/lisp/macros.lisp

    r14447 r14914  
    5151
    5252(defmacro defconstant (name initial-value &optional docstring)
    53   `(%defconstant ',name ,initial-value ,docstring))
     53  `(progn
     54     (record-source-information-for-type ',name :constant)
     55     (%defconstant ',name ,initial-value ,docstring)))
    5456
    5557(defmacro defparameter (name initial-value &optional docstring)
    56   `(%defparameter ',name ,initial-value ,docstring))
     58  `(progn
     59     (record-source-information-for-type ',name :variable)
     60     (%defparameter ',name ,initial-value ,docstring)))
    5761
    5862(defmacro truly-the (type value)
     
    178182(defmacro defvar (var &optional (val nil valp) (doc nil docp))
    179183  `(progn
     184     (sys::record-source-information-for-type ',var :variable)
    180185     (%defvar ',var)
    181186     ,@(when valp
  • trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

    r14911 r14914  
    12021202                ',name))
    12031203            (t
    1204              (when (and env (empty-environment-p env))
     1204       (when (and env (empty-environment-p env))
    12051205               (setf env nil))
    12061206             (when (null env)
    12071207               (setf lambda-expression (precompiler:precompile-form lambda-expression nil)))
    1208              `(prog1
    1209                   (%defun ',name ,lambda-expression)
    1210                 ,@(when doc
    1211                    `((%set-documentation ',name 'function ,doc)))))))))
     1208       (let ((sym (if (consp name) (second name) name)))
     1209         `(prog1
     1210        (%defun ',name ,lambda-expression)
     1211      (record-source-information-for-type ',sym '(:function ,name))
     1212;     (%set-arglist (fdefinition ',name) ,(format nil "~{~s~^ ~}" (third lambda-expression)))
     1213      ,@(when doc
     1214          `((%set-documentation ',name 'function ,doc)))
     1215      )))))))
    12121216
    12131217(export '(precompile))
  • trunk/abcl/src/org/armedbear/lisp/source-transform.lisp

    r13597 r14914  
    5858         (expander
    5959           `(lambda (,form) (block ,block-name ,body))))
    60     `(eval-when (:compile-toplevel :load-toplevel :execute)
    61        (setf (source-transform ',name) ,expander)
    62        ',name)))
     60    `(progn
     61       (record-source-information-for-type ',name '(:source-transform ,name))
     62       (eval-when (:compile-toplevel :load-toplevel :execute)
     63   (setf (source-transform ',name) ,expander)
     64   ',name))))
    6365
    6466(defun expand-source-transform-1 (form)
Note: See TracChangeset for help on using the changeset viewer.