Changeset 8867


Ignore:
Timestamp:
Mar 23, 2008, 9:51:54 PM (11 years ago)
Author:
mb
Message:

New record-source-file implementation.

Rewrote the code around record-source-file. See the comments in
lib/source-files.lips for details on the new API.

edit-definition-p, get-source-files-with-types&classes and
%source-files still exist and are now defined in terms of the new
API. I believe that they're parameters and return values have not
changed, i'm not 100% sure.

Location:
branches/working-0711/ccl
Files:
1 added
11 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/PPC/ppc-lap.lisp

    r5869 r8867  
    4444     (record-source-file ',name 'ppc-lap)
    4545     ',name))
     46
     47(define-definition-type ppc-lap ()
     48  (:default-name-function symbol))
    4649
    4750(defvar *ppc-lap-constants* ())
  • branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp

    r7624 r8867  
    130130
    131131(defvar *x8664-backend* (car *known-x8664-backends*))
     132
     133(define-definition-type x8664-vinsn ()
     134  (:default-name-function symbol))
    132135
    133136(defun fixup-x8664-backend ()
  • branches/working-0711/ccl/compiler/X86/x86-lap.lisp

    r8017 r8867  
    218218     (record-source-file ',name 'x86-lap)
    219219     ',name))
     220
     221(define-definition-type x86-lap ()
     222  (:default-name-function symbol))
    220223
    221224(defun x86-lap-macroexpand-1 (form)
  • branches/working-0711/ccl/level-0/l0-def.lisp

    r6485 r8867  
    6767(%fhave 'fset #'bootstrapping-fset)
    6868
    69 (defun bootstrapping-record-source-file (fn &optional type)
    70   (declare (ignore fn type))
    71   nil)
    72 
    73 ;Redefined in l1-utils.
    74 (%fhave 'record-source-file #'bootstrapping-record-source-file)
    75 
    76 
    7769(setq *fasload-print* nil)
    7870(setq *save-doc-strings* t)
    7971
    80 
     72;;;;
    8173
    8274(%fhave '%defun-encapsulated-maybe ;Redefined in encapsulate
  • branches/working-0711/ccl/level-0/nfasload.lisp

    r8836 r8867  
    680680(deffaslop $fasl-toplevel-location (s)
    681681  (%cant-epush s)
    682   (let* ((location (%fasl-expr s)))
    683     (setq *loading-toplevel-location* location)))
     682  (setq *loading-toplevel-location* (%fasl-expr s)))
    684683
    685684(defvar *modules* nil)
  • branches/working-0711/ccl/level-1/l1-boot-2.lisp

    r8560 r8867  
    220220      (bin-load-provide "ARRAYS-FRY" "arrays-fry")
    221221      (bin-load-provide "APROPOS" "apropos")
     222      (bin-load-provide "SOURCE-FILES" "source-files")
    222223     
    223224      #+ppc-target
     
    266267      (bin-load-provide "EDIT-CALLERS" "edit-callers")
    267268      (bin-load-provide "DESCRIBE" "describe")
    268       (bin-load-provide "SOURCE-FILES" "source-files")
    269269      (bin-load-provide "COVER" "cover")
    270270      (bin-load-provide "MCL-COMPAT" "mcl-compat")
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r8853 r8867  
    636636      (add-reader-method class                     
    637637                         (ensure-generic-function reader)
    638                          dslotd))
     638                         dslotd)
     639      (record-source-file (ensure-generic-function reader)
     640                          'reader-method))
    639641    (dolist (writer (%slot-definition-writers dslotd))
    640642      (add-writer-method class
    641643                         (ensure-generic-function writer)
    642                          dslotd))))
     644                         dslotd)
     645      (record-source-file (ensure-generic-function writer)
     646                          'writer-method))))
    643647
    644648(defun remove-accessor-methods (class dslotds)
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r8421 r8867  
    2323;In fact, ALL functions must be defined before they're used!  How about that ?
    2424
    25 
    26 
    2725(setq %lisp-system-fixups% nil)
    28 
    29 
    30 (setq *warn-if-redefine-kernel* nil)
    31 
    32 (setq *warn-if-redefine* nil)
    33 (setq *record-source-file* t)
    34 
    35 ;;; Kludge for record-source-file bootstrapping
    3626
    3727; Set T by l1-boot.lisp
     
    3929
    4030(%fhave 'full-pathname (qlfun bootstrapping-full-pathname (name) name))
    41 
    42 (%fhave '%source-files (qlfun bootstrapping-%source-files (name)
    43                          (get name 'bootstrapping-source-files)))
    44 (%fhave '%set-source-files (qlfun bootstrapping-%set-source-files (name value)
    45                              (put name 'bootstrapping-source-files value)))
    46 
    47 
    48 
    49 
    5031
    5132; real one is  in setf.lisp
    5233(%fhave '%setf-method (qlfun bootstripping-setf-fsname (spec)
    5334                                   spec nil))
    54 
    55 ; this new thing breaks for case of a function being defined in non-file place
    56 ; use some euphemism for that such as t or "{No file}"
    57 ; something is broken (probably) here calling assq with garbage
    58 
    59 
    60 (defun source-file-or-files (symbol type setf-p method)
    61   (let ((source-files-info (%source-files symbol))   
    62         assoc-pair files)
    63     (cond ((null (consp source-files-info))
    64            (values source-files-info
    65                    nil
    66                    (if (and source-files-info (eq type 'function)(not setf-p)) source-files-info)))
    67           (t (setq assoc-pair (assq type (if setf-p
    68                                            (cdr (assq 'setf source-files-info))
    69                                            source-files-info)))
    70              (if (neq type 'method)
    71                (setq files assoc-pair)
    72                (setq files
    73                      (do* ((lst (cdr assoc-pair) (cdr lst))
    74                            (clst (car lst)(car lst)))
    75                           ((null lst) nil)
    76                        (when (consp clst)
    77                          (when (or (eq method (car clst))  ; method is a place holder for q's and s's
    78                                    (and (methods-congruent-p method (car clst))
    79                                         ; below avoids clutter
    80                                         (rplaca clst method)))
    81                            (return clst))))))
    82              (values source-files-info assoc-pair files)))))
    83 
    8435
    8536;;; warn if defining in no file iff previously defined in a file
     
    10455 (defun booted-probe-file (file)
    10556   (probe-file file)))
    106 
    107 #| (defmacro record-source-file (name type)
    108   `(%record-source-file ,name ,type #| (%source-file)|#)) |#
    109 
    110 (defun record-source-file (name def-type &optional (file-name *loading-file-source-file*)) 
    111   (let (symbol setf-p method old-file)
    112     (flet ((same-file (x y)
    113              (or (eq x y)
    114                  ;; funny because equal not defined before us
    115                  (and x
    116                       y
    117                       (or (equal x y)
    118                           (equal
    119                            (or (booted-probe-file x) (full-pathname x))
    120                            (or (booted-probe-file y) (full-pathname y))))))))
    121       (when (and *record-source-file* ) ;file-name)
    122         (when (and file-name (physical-pathname-p file-name))
    123           (setq file-name (namestring (back-translate-pathname file-name)))
    124           (cond ((equalp file-name *last-back-translated-name*)
    125                  (setq file-name *last-back-translated-name*))
    126                 (t (setq *last-back-translated-name* file-name))))
    127         (when (eq t def-type) (report-bad-arg def-type '(not (eql t))))
    128         (cond ((eq def-type 'method)
    129                (setq method name symbol (%method-name name) name nil))
    130               ((consp name)
    131                (cond ((neq (car name) 'setf)
    132                       (warn "record-source-file hates ~s" name))
    133                      (t (setq symbol name))))
    134               ((symbolp name) (setq symbol name)))
    135         (cond ((and (consp symbol)(eq (car symbol) 'setf))
    136                (let ((tem (%setf-method (cadr symbol))))
    137                  (if tem
    138                    (setq symbol tem)
    139                    (progn (setq symbol (cadr symbol))
    140                           (setq setf-p t))))))
    141         ;; assoc-pair is e.g. (function file1 ...)  or (class . file)
    142         ;; or (method (method-object file1 ...) ...) or (method
    143         ;; (method-object . file) ...)
    144         (when (symbolp symbol)          ; avoid boot problems - you thought
    145           (multiple-value-bind (source-files-info assoc-pair files)
    146               (source-file-or-files symbol def-type setf-p method)
    147             (setq old-file
    148                   (cond ((consp files)
    149                          (if (consp (cdr files)) (cadr files) (cdr files)))
    150                         (t files)))
    151             (unless
    152                 (if (or (not (consp files))(not (consp (cdr files))))
    153                   (same-file old-file file-name)
    154                   (do ((lst (cdr files)(cdr lst)))
    155                       ((null (consp lst)) nil)
    156                     (when (same-file file-name (car lst))
    157                       (rplaca lst (cadr files))
    158                       (rplaca (cdr files) file-name)
    159                       (return t))))
    160               (when (and *warn-if-redefine*
    161                          (neq def-type 'method) ; This should be more specific
    162                          (cond ((eq def-type 'function)
    163                                 (and (fboundp name) old-file))
    164                                (t old-file)))
    165                 (warn " ~S ~S previously defined in: ~A
    166          is now being redefined in: ~A~%"
    167                       def-type
    168                       name
    169                       (or old-file "{Not Recorded}")
    170                       (or file-name "{No file}")))
    171               (if (consp files)
    172                 (%rplacd files (cons file-name
    173                                      (if (consp (cdr files))(cdr files)(list (cdr files)))))
    174                
    175                 (if assoc-pair
    176                   (%rplacd assoc-pair (cons (if (eq def-type 'method)
    177                                               `(,method . , file-name)
    178                                               file-name)
    179                                             (if (consp (%cdr assoc-pair))
    180                                               (%cdr assoc-pair)
    181                                               (list (%cdr assoc-pair)))))
    182                   (%set-source-files
    183                    symbol
    184                    (cond ((and (eq def-type 'function)
    185                                (null setf-p)
    186                                (not (consp  source-files-info)))
    187                           (if (null old-file)
    188                             file-name
    189                             `((function ,file-name ,old-file))))
    190                          (t
    191                           (when (and source-files-info
    192                                      (not (consp source-files-info)))
    193                             (setq source-files-info `((function . , source-files-info))))
    194                           (let ((thing (if (neq def-type 'method)
    195                                          `(,def-type . ,file-name)
    196                                          `(,def-type (,method . ,file-name)))))
    197                             (cons (if setf-p `(setf ,thing) thing) source-files-info))))))))
    198             ))))))
    199 
    200 (record-source-file 'record-source-file 'function)
    201 
    20257
    20358(defun inherit-from-p (ob parent)
     
    796651        (report-bad-arg form '(satisfies constantp))))))
    797652
    798 ;;; avoid hanging onto beezillions of pathnames
    799 (defvar *last-back-translated-name* nil)
    800653(defvar *lfun-names*)
    801654
  • branches/working-0711/ccl/lib/method-combination.lisp

    r8668 r8867  
    197197           *method-combination-info*)
    198198  function)
     199
     200(define-definition-type method-combination-evaluator ()
     201  (:default-name-function symbol))
    199202
    200203(defmethod compute-effective-method ((generic-function standard-generic-function)
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r8851 r8867  
    448448              (require-type *fcomp-source-being-compiled* 'null)
    449449              (return))
    450             (when *fcomp-source-being-compiled*
    451               (fcomp-output-form $fasl-toplevel-location env *fcomp-source-being-compiled*))
     450            (when *fcomp-source-being-compiled*
     451              (fcomp-output-form $fasl-toplevel-location env *fcomp-source-being-compiled*))
    452452            (fcomp-form form env processing-mode)
    453453            (setq *fcomp-previous-position* *fcomp-stream-position*))))
  • branches/working-0711/ccl/lib/source-files.lisp

    r8421 r8867  
    1515;;;   http://opensource.franz.com/preamble.html
    1616
     17;;;; RECORD-SOURCE-FILE and FIND-DEFINITIONS-FOR-NAME allow us to map names to source-notes.
     18
     19;;;; A source-note is a ccl::source-note object, depeding on how much information we have available
     20;;;; at load time the source-note may be a complete source-note or it may just have the file-name.
     21
     22;;;; A thing is identified by its type and its name. A type is an instance of definition-type and
     23;;;; the name => atom | (list name*)
     24
    1725(in-package "CCL")
    1826
    19 #| (defun definition-source (object &object environment)
    20  
    21   (flet ((definition-note (lfun)
    22              (getf (getf lfun 'code-source-map) :definition-source-note)))
    23     (etypecase object
    24       (symbol (append (when (find-class object nil environment)
    25                         (definition-source (find-class object) environment))
    26                       (when (fboundp object)
    27                         (definition-source (symbol-function object) environment))
    28                       (when (boundp object)
    29                         (variable-definition-source object environment))))
    30       (standard-generic-function
    31          (append (list :generic-function (definition-note ))))))) |#
    32 
    33 #| (defun variable-definition-source (var-name)
    34   (gethash var-name %source-notes-for-varibales-and-constants%))
    35 
    36 (defvar %source-notes-for-varibales-and-constants%
    37   (make-hash-table :test #'eq :weak t :size 7000 :rehash-threshold .9)) |#
    38 
    39 (defvar %source-files% (let ((a (make-hash-table :test #'eq
    40                                                  :weak t
    41                                                  :size 7000
    42                                                  :rehash-threshold .9)))
    43                          (do-all-symbols (s)
    44                            (let ((f (get s 'bootstrapping-source-files)))
    45                              (when f
    46                                (setf (gethash s a) f)
    47                                (remprop s 'bootstrapping-source-files))))
    48                          a))
    49 
    50 (%fhave '%source-files (qlfun %source-files (name)
    51                          (gethash name %source-files%)))
    52 (%fhave '%set-source-files (qlfun %set-source-files (name value)
    53                              (puthash name %source-files% value)))
    54 
    55 ;;; modified version of %method-applicable-p - args are class names
    56 ;;; not instances
    57 (defun %my-method-applicable-p (method args cpls)
    58   (do ((specs (%method-specializers method) (cdr specs))
    59        (args args (cdr args))
    60        (cpls cpls (cdr cpls)))
    61       ((null specs) t)
    62     (declare (type list specs args cpls))
    63     (let ((spec (car specs)))
    64       (if (listp spec)
    65         (unless (equal (car args) spec)
    66           (return nil))
    67         (unless (memq spec (car cpls))
    68           (return nil))))))
    69 
    70 ;;; modified version of %compute-applicable-methods*
    71 ;;; omit errors and args are class names not instances
    72 ;;; returns a new list.
    73 (defun find-applicable-methods (name args qualifiers)
    74   (let ((gf (fboundp name)))
    75     (when (and gf (typep gf 'standard-generic-function))
    76       (let* ((methods (%gf-methods gf))
    77              (args-length (length args))
    78              (bits (lfun-bits (closure-function gf)))  ; <<
    79              arg-count res)
    80         (when methods
    81           (setq arg-count (length (%method-specializers (car methods))))
    82           (unless (or (logbitp $lfbits-rest-bit bits)
    83                       (logbitp $lfbits-keys-bit bits)
    84                       (<= args-length
    85                           (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
    86             (return-from find-applicable-methods))
    87           (cond
    88            ((null args)
    89             (dolist (m methods res)
    90               (when (or (eq qualifiers t)
    91                         (equal qualifiers (%method-qualifiers m)))
    92                 (push m res))))
    93            ((%i< args-length arg-count)
    94             (let (spectails)
    95               (dolist (m methods)
    96                 (let ((mtail (nthcdr args-length (%method-specializers m))))
    97                   (pushnew mtail spectails :test #'equal)))
    98               (dolist (tail spectails)
    99                 (setq res
    100                       (nconc res (find-applicable-methods
    101                                   name
    102                                   (append args (mapcar
    103                                                 #'(lambda (x) (if (consp x) x (class-name x)))
    104                                                 tail))
    105                                   qualifiers))))
    106               (if (%cdr spectails)
    107                 (delete-duplicates res :from-end t :test #'eq)
    108                 res)))
    109            (t
    110             (let ((cpls (make-list arg-count)))
    111               (declare (dynamic-extent cpls))
    112               (do ((args-tail args (cdr args-tail))
    113                    (cpls-tail cpls (cdr cpls-tail)))
    114                   ((null cpls-tail))
    115                 (declare (type list args-tail cpls-tail))
    116                 (let ((arg (car args-tail)) thing)
    117                   (if (consp arg)
    118                     (setq thing (class-of (cadr arg)))
    119                     (setq thing (find-class (or arg t) nil)))
    120                   (when thing
    121                     (setf (car cpls-tail)               
    122                           (%class-precedence-list thing)))))
    123               (dolist (m methods)
    124                 (when (%my-method-applicable-p m args cpls)
    125                   (push m res)))
    126               (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
    127                 (when (eq (generic-function-method-combination gf)
    128                           *standard-method-combination*)
    129                   ; around* (befores) (afters) primaries*
    130                   (setq methods (compute-method-list methods))
    131                   (when methods
    132                     (setq methods
    133                           (if (not (consp methods))
    134                             (list methods)
    135                             (let ((afters (cadr (member-if #'listp methods))))
    136                               (when afters (nremove afters methods))
    137                               (nconc
    138                                (mapcan #'(lambda (x)(if (listp x) x (cons x nil)))
    139                                        methods)
    140                                afters))))))
    141                 (if (and qualifiers (neq qualifiers t))
    142                   (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m))))
    143                              methods)
    144                   methods))))))))))
    145 
    146 ;;; Do this just in case record source file doesn't remember the right
    147 ;;; definition
    148 (defun methods-match-p (x y) 
    149   (or (eq x y)
    150       (and (typep x 'method)
    151            (typep y 'method)
    152            (equal (method-name x)
    153                   (method-name y))
    154            (equal (method-specializers x)
    155                   (method-specializers y))
    156            (equal (method-qualifiers x)
    157                   (method-qualifiers y)))))
    158 
    159 (defun source-files-like-em (classes qualifiers method)
    160   (and (equal (canonicalize-specializers classes)
    161               (%method-specializers method))
    162        (or (eq qualifiers t)
    163            (equal qualifiers (%method-qualifiers method)))))
    164 
    165 (defun parse-definition-spec (form)
    166   (let ((type t)
    167         name classes qualifiers)
    168     (cond
    169      ((consp form)
    170       (cond ((eq (car form) 'setf)
    171              (setq name form))
    172             (t (setq name (car form))
    173                (let ((last (car (last (cdr form)))))
    174                  (cond ((and (listp last)(or (null last)(neq (car last) 'eql)))
    175                         (setq classes last)
    176                         (setq qualifiers (butlast (cdr form))))
    177                        (t (setq classes (cdr form)))))                   
    178                (cond ((null qualifiers)
    179                       (setq qualifiers t))
    180                      ((equal qualifiers '(:primary))
    181                       (setq qualifiers nil))))))
    182      (t (setq name form)))
    183     (when (and (consp name)(eq (car name) 'setf))
    184         (setq name (or (%setf-method (cadr name)) name))) ; e.g. rplacd
    185     (when (not (or (symbolp name)
    186                    (setf-function-name-p name)))
    187       (return-from parse-definition-spec))
    188     (when (consp qualifiers)
    189       (mapc #'(lambda (q)
    190                 (when (listp q)
    191                   (return-from parse-definition-spec)))
    192           qualifiers))
    193     (when classes
    194       (mapc #'(lambda (c)
    195                 (when (not (and c (or (symbolp c)(and (consp c)(eq (car c) 'eql)))))
    196                   (return-from parse-definition-spec)))
    197             classes))           
    198     (when (or (consp classes)(consp qualifiers))(setq type 'method))
    199     (values type name classes qualifiers)))
    200 
    201 (defun edit-definition-p (name &optional (type t) &aux specializers qualifiers the-method)
    202   (when (consp name)
    203     (multiple-value-setq (type name specializers qualifiers)
    204       (parse-definition-spec name)))
    205   (when (and specializers (consp specializers)) (setq type 'method))
    206   ; might be a method-function whose name is the method
    207   (when (typep name 'function)(setq name (function-name name)))
    208   (when (typep name 'method)
    209      (setq qualifiers (%method-qualifiers name)
    210            specializers (mapcar #'(lambda (s)
    211                                     (if (typep s 'class)
    212                                       (class-name s)
    213                                       s))
    214                                 (%method-specializers name))
    215            the-method name
    216            name (%method-name name)
    217            type 'method))
    218   (let (files str newname)   
    219     (setq files (or (get-source-files-with-types&classes name type specializers qualifiers the-method)
    220                     (and
    221                      (not the-method)
    222                      (symbolp name)
    223                      (or (and
    224                           (setq str (symbol-name name))
    225                           (memq (schar str (1- (length str))) '(#\.  #\, #\:))
    226                           (setq newname
    227                                 (find-symbol (%substr str 0 (1- (length str)))
    228                                              (symbol-package name)))
    229                           (get-source-files-with-types&classes newname type specializers qualifiers))
    230 ))))         
    231   (when (and files newname) (setq name newname))
    232   (values files name type specializers qualifiers)))
    233 
    234 
    235 
    236 ;;; sym can be (setf blah)
    237 (defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
    238   (labels
    239     ((merge-types (l)
    240        (let ((ftype (car l)))
    241          (cond
    242           ((eq ftype 'setf) ; it's (setf (function . file))
    243            (let ((res (mapcan #'merge-types (cdr l))))
    244              (if (typep (caar res) 'method)
    245                res
    246                (mapcar #'(lambda (x)(cons 'setf (cdr x))) res))))
    247           ((or (eq type t)(eq ftype type))
    248            (let* ((foo #'(lambda (x)
    249                            (when x
    250                              ; if x is consp it's (<method> file file ..)
    251                              (cond
    252                               ((consp x)
    253                                (when (or (not (or classes qualifiers))
    254                                          (if the-method
    255                                            (methods-match-p (car x) the-method)
    256                                            (source-files-like-em classes qualifiers
    257                                                                  (car x))))
    258                                  (merge-class x)))
    259                               (t (list (cons ftype x))))))))
    260              (declare (dynamic-extent foo))
    261              (mapcan foo (if (consp (cdr l)) (cdr l)(list (cdr l)))))))))
    262      (merge-class (l)
    263        (if (consp (cdr l))
    264          (mapcan
    265           #'(lambda (x)
    266               (when x (list (cons (car l) x))))
    267           (cdr l))
    268          (list l))))
    269     (declare (dynamic-extent #'merge-types)(special *direct-methods-only*))
    270     (let (files)
    271       (when (and (not the-method)(eq type 'method) classes (not *direct-methods-only*))
    272         (let ((methods (find-applicable-methods sym classes qualifiers)))         
    273           (when methods           
    274             (setq files (mapcan
    275                          #'(lambda (m)
    276                              (or (edit-definition-p m)(list (list m))))
    277                          methods)))))
    278       (if files files
    279           (let (setf-p result)
    280             (if (and (consp sym)(eq (car sym) 'setf))
    281               (setq sym (cadr sym) setf-p t))
    282             (setq result (%source-files sym))
    283             (if (not (consp result))
    284               (setq result
    285                     (if (not setf-p)
    286                       (if (or (eq type t)(eq type 'function))
    287                         `((function . ,result)))))
    288               (if setf-p (setq result (list (assq 'setf result)))))
    289             (mapcan #'merge-types result))))))
     27 ;; Attempting to record-source while defining the source recording framework is a bad idea. When
     28 ;; we're done loading this file we re-enable source recording.
     29(setf *record-source-file* nil)
     30
     31;;;; * Mapping names of things to the text which defines the thing.
     32
     33(defvar *source-files* (make-hash-table)
     34  "Hash table which store source locations as per record-source-file.")
     35
     36(defvar *definition-types* '()
     37  "List of known definition-type objects.")
     38
     39;;;; ** Low level functions for maintaining the definition-source table.
     40
     41;;;; DEFINITION-SOURCE is part of the public API. However users of this API probably want to use
     42;;;; RECORD-SOURCE-FILE and FIND-DEFINITIONS-FOR-NAME instead.
     43
     44(defgeneric (setf definition-source)
     45    (source-note definition-type name)
     46  (:documentation "Records that the object named NAME of type DEFINITION-TYPE is stored at
     47SOURCE-NOTE.")
     48  (:method (source-note (definition-type-name symbol) name)
     49    "Convenience method, just calls (setf definition-source) with the definition-type object named
     50DEFINITION-TYPE-NAME."
     51    (setf (definition-source (definition-type-instance definition-type-name) name)
     52          source-note))
     53  (:method (source-note (definition-type definition-type) name)
     54    ;; NB: this setf function calls definition-source. Be careful in definition-source to not call
     55    ;; the setf method.
     56    (let ((effective-name (effective-name definition-type name))
     57          (existing-note (definition-source definition-type name)))
     58      (unless effective-name
     59        ;; should this be an error?
     60        (warn "Can not determine name of ~S for type ~S." name definition-type)
     61        (return-from definition-source source-note))
     62      (symbol-macrolet ((definitions
     63                            (gethash (definition-short-name definition-type effective-name) *source-files*)))
     64        (if existing-note
     65          (dolist (def definitions)
     66            (when (and (eq (first def) (definition-type-name definition-type))
     67                       (definition-name-equal-p (second def) effective-name))
     68              (setf (third def) source-note)))
     69          (push (list (definition-type-name definition-type) effective-name source-note)
     70                definitions)))
     71      source-note)))
     72
     73(defgeneric definition-source (definition-type name)
     74  (:documentation "Returns the source-note for the object of type DEFINITION-TYPE named NAME.")
     75  (:method ((definition-type-name symbol) (name t))
     76    "Convenience method, just calls definition-source after looking up the definition-type named by DEFINITION-TYPE-NAME."
     77    (definition-source (definition-type-instance definition-type-name) name))
     78  (:method ((definition-type definition-type) (name t))
     79    "Returns the source-note where the thing named NAME of type DEFINITION-TYPE was defined.
     80
     81If no such thing exists we return NIL."
     82    ;; nb: we're called by (setf definition-source).
     83    (let ((effective-name (effective-name definition-type name)))
     84      (when effective-name
     85        (third
     86         (find-if (lambda (def)
     87                    (and (eq (first def) (definition-type-name definition-type))
     88                         (definition-name-equal-p (second def) effective-name)))
     89                  (gethash (definition-short-name definition-type effective-name)
     90                           *source-files*)))))))
     91
     92(defun definition-name-equal-p (a b)
     93  "Returns T if A and B represent the same definition-name."
     94  (let ((seen '()))
     95    (labels ((rec (a b)
     96             (cond
     97               ((and (atom a) (atom b)) (eql a b))
     98               ((and (consp a) (consp b))
     99                (if (or (member a seen)
     100                        (member b seen))
     101                  (return-from definition-name-equal-p nil)
     102                  (prog1
     103                      (and (rec (car a) (car b))
     104                           (rec (cdr a) (cdr b)))
     105                    (push a seen)
     106                    (push b seen))))
     107               (t nil))))
     108      (rec a b))))
     109
     110;;;; ** Storing definitions for a name
     111
     112(defun record-source-file (name definition-type-name
     113                           &key (file-name *loading-file-source-file*)
     114                                (toplevel-source-note *loading-toplevel-location*))
     115  "Records where the thing of type DEFINITION-TYPE-NAME named NAME is stored.
     116
     117NAME is a definition-name; DEFINITION-TYPE-NAME is a symbol naming a definition-type-name (see
     118definition-type-instance) or a definition-type object; FILE-NAME is the file where this thing is
     119stored and TOPLEVEL-SOURCE-NOTE is the source-note. If TOPLEVEL-SOURCE-NOTE is non-NIL we use it and
     120ignore the FILE-NAME argument."
     121  (when (not *record-source-file*)
     122    (return-from record-source-file nil))
     123  (when (and (null file-name)
     124             (null toplevel-source-note))
     125    ;; no file-name, no toplevel-location, what is it we want to record?
     126    (return-from record-source-file nil))
     127  ;; bootstrapping
     128  (unless (member definition-type-name *definition-types* :key #'definition-type-name)
     129    (warn "No known definition-type named ~S." definition-type-name)
     130    (return-from record-source-file nil))
     131  (let* ((definition-type (definition-type-instance definition-type-name))
     132         (source-note (or toplevel-source-note ;; mb 2007-03-23: do we really want to ignore file-name?
     133                          (%make-source-note :file-name (truename file-name))))
     134         (existing-note (definition-source definition-type name)))
     135    (when (and *warn-if-redefine*
     136               (not (equal (full-pathname (source-note-file-name existing-note))
     137                           (full-pathname (source-note-file-name source-note)))))
     138      ;; have an existing definition in another file. warn.
     139      (warn "The ~S ~S, which was defined in ~S, is being redefined in ~S."
     140            definition-type-name (effective-name definition-type name)
     141            (source-note-file-name existing-note)
     142            (source-note-file-name source-note)))
     143    (setf (definition-source definition-type name) source-note)
     144    (list definition-type-name (effective-name definition-type name) source-note)))
     145
     146;;;; * Framework for definig definition-types
     147
     148(defun definition-type-full-name (type-name)
     149  "Given a definition-type-name returns the name of the class of definition-type representing that
     150name."
     151  (intern (concatenate 'string
     152                       (string type-name)
     153                       (string '#:-definition-type))))
     154
     155(defclass definition-type ()
     156    ((name :accessor definition-type-name :initarg :name))
     157  (:documentation "Super class of the definition-types.
     158
     159We only use definition-type objects for two things:
     160
     1611) To store their short name (so that users can write x86-lap instead of x86-lap-definition-type)
     162
     1632) To let us inherit behaviour (in particular effective-name). Example: WRITER-METHOD acts just like
     164FUNCTION but we want it to have a different name."))
     165
     166(defmethod make-load-form ((type definition-type) &optional env)
     167  (make-load-form-saving-slots type :slot-names '(name) :environment env))
     168
     169(defun definition-type-instance (definition-type-name)
     170  "Returns a definition-type object whose name if definition-type-name.
     171
     172DEFINITION-TYPE-NAME, a symbol, is the short name of the definition-type."
     173  (find definition-type-name *definition-types*
     174        :key #'definition-type-name))
     175
     176(defmacro define-definition-type (name supers &rest options)
     177  "Defines a new type named NAME for recording source information.
     178
     179OPTIONS can contain the keyword :default-name-function it which symbols are passed, unmodified, as
     180names."
     181  `(progn
     182     (defclass ,(definition-type-full-name name) ,(or supers '(definition-type))
     183         ()
     184       (:default-initargs :name ',name))
     185     ,@(loop for (key . arguments) in options
     186             when (eql key :default-name-function)
     187               collect `(define-definition-name-function ,name (,(first arguments)) ,(first arguments)))
     188     (register-definition-type ',name)
     189     ',name))
     190
     191(defun register-definition-type (name)
     192  (let ((name (definition-type-full-name name)))
     193    (setf *definition-types* (delete name *definition-types* :key #'definition-type-name))
     194    (push (make-instance name) *definition-types*)))
     195
     196(defgeneric effective-name (type name)
     197  (:documentation "Normalizes NAME into the standard name of objects of type TYPE. If NAME can not
     198name an object of type TYPE then we return NIL.
     199
     200This function also serves to test if we could ever find a thing of type TYPE with the name NAME.")
     201  (:method ((type definition-type) (name t))
     202    ;; by default nothing is a valid type name.
     203    nil))
     204
     205(defmacro define-definition-name-function (type-name (name-type) &body body)
     206  (let ((type-arg (gensym)))
     207    `(defmethod effective-name ((,type-arg ,(definition-type-full-name type-name))
     208                                (,name-type ,name-type))
     209       ,@body)))
     210
     211(defgeneric definition-short-name (type effective-name)
     212  (:documentation "Given an effective-name returns a single symbol which, approximetly, names this
     213THING.
     214
     215The values returned by this function are used as keys in *source-files*. We do this so that, since
     216names can be arbitrary lists, we don't need to search through every known name when looking for its
     217source but can look through the, hopefully short, lists of things with the same short-name.")
     218  (:method ((type definition-type) (name symbol))
     219    name))
     220
     221(defmacro define-definition-short-name (type-name (effective-name) &body body)
     222  "Defines a method on definition-short-name. TYPE-NAME is a short definition-name, EFFECTIVE-NAME
     223will be used as the argument to definition-short-name."
     224  (let ((type-arg (gensym)))
     225    `(defmethod definition-short-name ((,type-arg ,(definition-type-full-name type-name))
     226                                       ,effective-name)
     227       ,@body)))
     228
     229(defgeneric auxilliary-names (type name)
     230  (:documentation "Returns a list of (type name) which, when looking for NAME of type TYPE we might
     231also want to lookup.
     232
     233Poor man's apropos.")
     234  (:method ((type definition-type) (name t))
     235    '()))
     236
     237;;;; * Definition types
     238
     239(defun %assert-function-name-p (name)
     240  (unless (and (eql 'setf (first name)) (symbolp (second name)))
     241    (error "~S is not a valid function name." name)))
     242
     243;;;; ** function
     244
     245(define-definition-type function ()
     246  (:default-name-function symbol))
     247
     248(define-definition-short-name function (name)
     249  (if (symbolp name)
     250    name
     251    (second name)))
     252
     253(define-definition-name-function function (cons)
     254  (%assert-function-name-p cons)
     255  cons)
     256
     257(define-definition-name-function function (function)
     258  (function-name function))
     259
     260(defmethod auxilliary-names ((type function-definition-type) (name symbol))
     261  (append (list (list 'function `(setf ,name)))
     262          (when (and (fboundp name)
     263                     (generic-function-p (fdefinition name)))
     264            (loop
     265              for method in (generic-function-methods (fdefinition name))
     266              collect (list 'method (effective-name
     267                                     (definition-type-instance 'method)
     268                                     method))))
     269          (when (macro-function name)
     270            (list (list 'compiler-macro name)))))
     271
     272(define-definition-type generic-function (function-definition-type))
     273
     274(define-definition-type reader-method (function-definition-type))
     275
     276(define-definition-type writer-method (function-definition-type))
     277
     278;;;; ** type
     279
     280(define-definition-type type ())
     281
     282(defmethod effective-name ((type type-definition-type) (name t))
     283  "Anything is a valid name for a type"
     284  (let ((seen '()))
     285    (labels ((name-check (name)
     286               (typecase name
     287                 (symbol t)
     288                 (cons
     289                    (if (member name seen)
     290                      nil
     291                      (progn
     292                        (push (car name) seen)
     293                        (push (cdr name) seen)
     294                        (and (name-check (car name))
     295                             (name-check (cdr name)))))))))
     296      (if (name-check name)
     297        name
     298        nil))))
     299
     300;;;; ** class
     301
     302(define-definition-type class ()
     303  (:default-name-function symbol))
     304
     305(define-definition-name-function class (standard-class) (class-name standard-class))
     306
     307(define-definition-name-function class (built-in-class) (class-name built-in-class))
     308
     309(define-definition-name-function class (funcallable-standard-class) (class-name funcallable-standard-class))
     310
     311(defmethod auxilliary-names ((type class-definition-type) (name symbol))
     312  (list (list 'structure name)))
     313
     314;;;; ** structure
     315
     316(define-definition-type structure ()
     317  (:default-name-function symbol))
     318
     319(define-definition-name-function structure (structure-class) (class-name structure-class))
     320
     321(defmethod auxilliary-names ((type (eql 'structure)) (name symbol))
     322  (list (list 'class name)))
     323
     324;;;; ** method
     325
     326(define-definition-type method ())
     327
     328(define-definition-name-function method (cons) cons)
     329
     330(defun method-specializers-as-name-list (specializers)
     331  (loop
     332    for specializer in specializers
     333    collect (etypecase specializer
     334              (eql-specializer `(eql ,(eql-specializer-object specializer)))
     335              (structure-class (effective-name (definition-type-instance 'structure)
     336                                               specializer))
     337              (class (effective-name (definition-type-instance 'class)
     338                                     specializer))))  )
     339
     340(define-definition-name-function method (standard-method)
     341  (list* (effective-name (definition-type-instance 'function)
     342                         (method-generic-function standard-method))
     343         (method-qualifiers standard-method)
     344         (method-specializers-as-name-list (method-specializers standard-method))))
     345
     346(define-definition-short-name method (name)
     347  (definition-short-name (definition-type-instance 'function)
     348                         (first name)))
     349
     350(defun %find-method-from-definition-name (method-name)
     351  (destructuring-bind (gf-name qualifiers . specializers)
     352      method-name
     353    (loop
     354      with gf = (fdefinition gf-name)
     355      for this-method in (generic-function-methods gf)
     356      for these-qualifiers = (method-qualifiers this-method)
     357      for these-specializers = (method-specializers-as-name-list (method-specializers this-method))
     358      thereis (and (equal qualifiers these-qualifiers)
     359                   (equal specializers these-specializers)
     360                   this-method))))
     361
     362;;;; ** method-combination
     363
     364(define-definition-type method-combination ()
     365  (:default-name-function symbol))
     366
     367(define-definition-name-function method-combination (standard-method-combination)
     368  (method-combination-name standard-method-combination))
     369
     370;;;; ** constant
     371
     372(define-definition-type constant ()
     373  (:default-name-function symbol))
     374
     375(defmethod auxilliary-names ((type constant-definition-type) (name symbol))
     376  (list (list 'variable name)))
     377
     378;;;; ** variable
     379
     380(define-definition-type variable ()
     381  (:default-name-function symbol))
     382
     383(defmethod auxilliary-names ((type variable-definition-type) (name symbol))
     384  (list (list 'constant name)))
     385
     386;;;; ** compiler-macro
     387
     388(define-definition-type compiler-macro ()
     389  (:default-name-function symbol))
     390
     391(define-definition-short-name compiler-macro (name)
     392  (if (symbolp name)
     393    name
     394    (second name)))
     395
     396(define-definition-name-function compiler-macro (cons)
     397  (%assert-function-name-p cons)
     398  cons)
     399
     400;;;; * Finding definitions from a name
     401
     402(defun find-definitions-for-name (name)
     403  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
     404  (let ((definitions '()))
     405    (flet ((collect-def (type name)
     406             (let ((source (definition-source type name)))
     407               (when source
     408                 (push (list type name source) definitions)))))
     409      (dolist (definition-type *definition-types*)
     410        (collect-def (definition-type-name definition-type) name)
     411        (dolist (other-name (auxilliary-names definition-type name))
     412          (collect-def (first other-name) (second other-name))))
     413      (remove-duplicates definitions
     414                         :test (lambda (a b)
     415                                 (and (eql (first a) (first b))
     416                                      (definition-name-equal-p (second a) (second b))))))))
     417
     418;;;; * backwards compatability. find-definitions-for-name or definition-source is the preferred way
     419;;;; to lookup sources.
     420
     421(defun edit-definition-p (name &optional (type t))
     422  (get-source-files-with-types&classes name (definition-type-instance type)))
     423
     424(defun get-source-files-with-types&classes (name &optional (type-name t))
     425  "Returns the files where the object of type TYPE named SYM is defined.
     426
     427Returns a list of (TYPE . FILES). TYPE is either a symbol naming the type or, in the case of
     428methods, the method object.
     429
     430FILES is either a list of pathnames if there are multiple definitions or a single pathname."
     431  (let* ((definitions (case type-name
     432                        (function
     433                         (list* (definition-source 'function name)
     434                                (loop
     435                                  for (type-name name) in (auxilliary-names 'function name)
     436                                  when (definition-source type-name name)
     437                                    collect (definition-source type-name name))))
     438                        (t (find-definitions-for-name name)))))
     439    ;; convert the list of definitions to whet callers of get-source-files-with-types&classes expect.
     440    (mapcar (lambda (def)
     441              (destructuring-bind (type name source-note)
     442                  def
     443                (cons (if (eql 'method type)
     444                        (%find-method-from-definition-name name)
     445                        type)
     446                      (source-note-file-name source-note))))
     447            definitions)))
     448
     449(defun %source-files (name)
     450  (mapcar (lambda (def)
     451            (cons (first def) (source-note-file-name (third def))))
     452          (gethash name *source-files*)))
     453
     454;;;; * Done loading the r-s-f stuff. Do some housekeeping.
     455
     456(setf *record-source-file* t)
     457
     458;; Now that the real r-s-f framework is ready we can go back and fixup the early stuff. This early
     459;; stuff is everything that we wanted to register before having defined the registration/recording
     460;; framework itself. Look at l0-source-files.lisp for the dummy code we use which fills
     461;; *early-definition-types* and *early-source-files*.
     462
     463(loop
     464  while *early-definition-types*
     465  for type-name = (pop *early-definition-types*)
     466  do (register-definition-type type-name))
     467
     468(loop
     469  while *early-source-files*
     470  for (type name file-name source-note) = (pop *early-source-files*)
     471  do (record-source-file name type
     472                         :file-name file-name
     473                         :toplevel-source-note source-note))
Note: See TracChangeset for help on using the changeset viewer.