source: trunk/source/lib/source-files.lisp @ 14401

Last change on this file since 14401 was 14401, checked in by rme, 9 years ago

Additional method on GET-OBJECT-SOURCES for closures, from Takehiko
Abe.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 32.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;; If we're reloading this file, don't want to be calling functions from here with
21;; only some of them redefined.  So revert to the bootstrapping version until the end.
22(fset 'record-source-file #'level-1-record-source-file)
23
24(defvar *source-files-lock* (make-lock "Source Files Lock"))
25
26(defvar *unique-setf-names* (make-hash-table :test #'eq))
27
28(defun canonical-maybe-setf-name (name)
29  (if (setf-function-name-p name)
30    (let ((tem (%setf-method (%cadr name))))
31      (if (non-nil-symbol-p tem) ;; e.g. (setf car) => set-car
32        tem
33        (or (gethash (%cadr name) *unique-setf-names*)
34            (setf (gethash (%cadr name) *unique-setf-names*) (list 'setf (%cadr name))))))
35    name))
36
37(defgeneric name-of (thing)
38  (:method ((thing t)) thing)
39  (:method ((thing method-function)) (name-of (%method-function-method thing)))
40  (:method ((thing function)) (name-of (function-name thing)))
41  (:method ((thing method)) `(:method ,(method-name thing) ,@(method-qualifiers thing) ,(method-specializers thing)))
42  (:method ((thing class)) (class-name thing))
43  (:method ((thing method-combination)) (method-combination-name thing))
44  (:method ((thing package)) (package-name thing))
45  (:method ((thing eql-specializer)) `(eql ,(eql-specializer-object thing))))
46
47;; This used to be weak, but the keys are symbols-with-definitions, so why bother.
48;; Set a high rehash threshold because space matters more than speed here.
49;; Do not use lock-free hash tables, because they optimize reads at the expense of
50;; writes/rehashes.  Writes/rehashes affect file-compilation speed, which matters.
51(defvar %source-files% (make-hash-table :test #'eq
52                                        :size 14000
53                                        :rehash-size 1.8 ;; compensate for high threshold
54                                        :rehash-threshold .95
55                                        :lock-free nil))
56
57
58
59(defvar *direct-methods-only* t
60  "If true, method name source location lookup will find direct methods only.  If false,
61   include all applicable methods")
62
63
64;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
65;;
66;; Definition types
67;;
68;; Definition types are uniquely identified by a symbol, but are implemented as
69;; classes so they can inherit/customize behavior.  They have no instances other
70;; than the class prototype, which is used to invoke methods.
71;;
72
73(defgeneric definition-type-name (def-type)
74  (:documentation "The preferred user-visible name of the def-type.  Used for
75error messages etc.  The default method returns the name specified in
76define-definition-type."))
77
78(defclass definition-type ()
79  ((name :allocation :class :reader definition-type-name :initform t))
80  (:documentation "Superclass of all definition types"))
81
82(defgeneric definition-base-name (def-type def)
83  ;; Note that a def can have multiple base names, but each one needs a different def-type
84  (:documentation "Return the name that, when the user asks for all definitions of that
85name, this def should be included.  Typically this is a symbol.  It's used as a key in
86an EQ hash table, so must return EQ values for equivalent definitions.
87The default method returns the rightmost atom in name")
88  (:method ((dt definition-type) name)
89    (while (consp name)
90      (let ((x (last name)))
91        (setq name (or (cdr x) (car x)))))
92    name))
93
94(defgeneric definition-same-p (def-type def1 def2)
95  (:documentation "Returns true if the two definitions are equivalent, i.e. one should
96replace the other.  The default method calls EQUAL.")
97  (:method ((dt definition-type) name1 name2)
98    (equal name1 name2)))
99
100(defgeneric definition-bound-p (def-type def)
101  (:documentation "Returns true if def is currently defined.  Used to decide whether to issue
102redefinition warnings.  The default method returns T.")
103  (:method ((dt definition-type) name)
104    (declare (ignore name))
105    t))
106
107;;;;;;;;;;
108
109(defvar *definition-types* ()
110  "alist of all known definition type names and their class prototypes")
111
112(defmethod print-object ((dt definition-type) stream)
113  (if *print-escape*
114    (let ((definedp (class-name (class-of dt))))
115      (print-unreadable-object (dt stream :type definedp :identity t)
116        (unless definedp
117          (format stream "#:~s " 'definition-type)) ;; subtly indicate it's a subclass...
118        (format stream "~s" (definition-type-name dt))))
119    (format stream "~s" (definition-type-name dt))))
120
121(defmethod name-of ((thing definition-type))
122  (definition-type-name thing))
123
124(defmacro define-definition-type (name supers)
125  "Defines a class named name-DEFINITION-TYPE and registers it as the class of
126definition type NAME"
127  (let ((class-name (intern (%str-cat (symbol-name name) "-DEFINITION-TYPE"))))
128    `(progn
129       (defclass ,class-name ,(or supers '(definition-type))
130         ((name :allocation :class :initform ',name)))
131       (record-source-file ',name 'definition-type)
132       (register-definition-type (find-class ',class-name) '(,name)))))
133
134(defun register-definition-type (class names)
135  (let ((instance (class-prototype class)))
136    (with-lock-grabbed (*source-files-lock*)
137      ;; If had a previous definition, the defclass will signal any duplicate
138      ;; definition warnings, so here just silently replace previous one.
139      (without-interrupts
140        (setq *definition-types*
141              (remove instance *definition-types* :key #'cdr)))
142      (loop for name in names
143            unless (without-interrupts
144                     (unless (assq name *definition-types*)
145                       (push (cons name instance) *definition-types*)))
146              do (error "There is already a different definition type ~s named ~s"
147                        (cdr (assq name *definition-types*))
148                        name)))
149    ;; Return instance for use in make-load-form
150    instance))
151
152(defun auto-create-definition-type (name)
153  ;; Use an anonymous class, so this means can't write methods on it.
154  ;; If you want to write methods on it, use define-definition-type first.
155  (let* ((super (find-class 'definition-type))
156         (new-class (make-instance (class-of super)
157                      :direct-superclasses (list super)
158                      :direct-slots `((:name name
159                                       :allocation :class
160                                       :initform ',name
161                                       :initfunction ,(constantly name))))))
162    (register-definition-type new-class (list name))
163    (class-prototype new-class)))
164
165(defmethod definition-type-instance ((dt definition-type) &key (if-does-not-exist :error))
166  (if (rassoc dt *definition-types* :test #'eq)
167    dt
168    (ecase if-does-not-exist
169      ((nil) nil)
170      ((:error) (error "~s is not a known definition-type" dt)))))
171
172(defmethod definition-type-instance ((name symbol) &key (if-does-not-exist :error))
173  (or (cdr (assq name *definition-types*))
174      (ecase if-does-not-exist
175        ((nil) nil)
176        ((:error) (error "~s is not a known definition-type" name))
177        ((:create) (auto-create-definition-type name)))))
178
179(defmethod definition-type-instance ((class class) &key (if-does-not-exist :error))
180  (definition-type-instance (class-prototype class) :if-does-not-exist if-does-not-exist))
181
182(defmethod make-load-form ((dt definition-type) &optional env)
183  (declare (ignore env))
184  (let ((names (loop for (name . instance) in *definition-types*
185                     when (eq dt instance) collect name)))
186    `(register-definition-type ',(class-of dt) ',names)))
187
188
189(register-definition-type (find-class 'definition-type) '(t))
190
191(defparameter *t-definition-type* (definition-type-instance 't))
192
193(define-definition-type function ())
194
195(defparameter *function-definition-type* (definition-type-instance 'function))
196
197(defmethod definition-base-name ((dt function-definition-type) name)
198  (while (and (consp name) (not (setf-function-name-p name)))
199    (let ((x (last name)))
200      (or (setq name (cdr x))
201          ;; Try to detect the (:internal .... <hairy-method-name>) case
202          (when (and (setq name (car x))
203                     ;;check for plausible method name
204                     (setq x (method-def-parameters name))
205                     (neq x 'setf)
206                     (not (keywordp x)))
207            (setq name x)))))
208  (canonical-maybe-setf-name name))
209
210(defmethod definition-bound-p ((dt function-definition-type) name)
211  (and (or (symbolp name) (setf-function-name-p name))
212       (or (fboundp name)
213           ;; treat long-form setf expanders like macros.
214           (and (consp name) (functionp (%setf-method (cadr name)))))))
215
216(define-definition-type macro (function-definition-type))
217
218(define-definition-type compiler-macro (macro-definition-type))
219
220(define-definition-type symbol-macro (macro-definition-type))
221
222(define-definition-type setf-expander (macro-definition-type))
223
224(define-definition-type generic-function (function-definition-type))
225
226(define-definition-type method ())
227
228(defparameter *method-definition-type* (definition-type-instance 'method))
229
230(defmethod definition-base-name ((dt method-definition-type) (name cons))
231  (if (setf-function-name-p name)
232    (canonical-maybe-setf-name name)
233    (definition-base-name *function-definition-type* (car name))))
234
235;; defmethod passes the actual method into record-source-file
236(defmethod definition-base-name ((dt method-definition-type) (method method))
237  (definition-base-name dt (method-name method)))
238
239(defmethod definition-base-name ((dt method-definition-type) (fn method-function))
240  (definition-base-name dt (function-name fn)))
241
242(defmethod definition-same-p ((dt method-definition-type) m1 m2)
243  (multiple-value-bind (n1 q1 s1) (method-def-parameters m1)
244    (multiple-value-bind (n2 q2 s2) (method-def-parameters m2)
245      (and (definition-same-p *function-definition-type* n1 n2)
246           (equal q1 q2)
247           (eql (length s1) (length s2))
248           (every #'(lambda (s1 s2)
249                      (or (equal s1 s2)
250                          (progn
251                            (when (symbolp s2) (rotatef s1 s2))
252                            (and (symbolp s1)
253                                 (classp s2)
254                                 (or (eq (find-class s1 nil) s2)
255                                     (eq s1 (class-name s2)))))))
256                  s1 s2)))))
257
258(defmethod definition-bound-p ((dt method-definition-type) meth &aux fn)
259  (when (setq fn (method-def-parameters meth))
260    (loop for m in (and (setq fn (fboundp fn))
261                        (typep fn 'generic-function)
262                        (generic-function-methods fn))
263          thereis (definition-same-p dt meth m))))
264
265(define-definition-type reader-method (method-definition-type))
266
267(define-definition-type writer-method (method-definition-type))
268
269(define-definition-type callback (function-definition-type))
270
271(define-definition-type structure-accessor (function-definition-type))
272
273(define-definition-type type ())
274
275(define-definition-type class ())
276
277(defmethod definition-bound-p ((dt class-definition-type) name)
278  (and (non-nil-symbol-p name) (find-class name nil)))
279
280(define-definition-type condition (class-definition-type))
281
282(define-definition-type structure ())
283
284(define-definition-type definition-type ())
285
286(defmethod definition-bound-p ((dt definition-type-definition-type) name)
287  (definition-type-instance name :if-does-not-exist nil))
288
289(define-definition-type method-combination ())
290
291(define-definition-type variable ())
292
293(defmethod definition-bound-p ((dt variable-definition-type) name)
294  (and (non-nil-symbol-p name) (boundp name)))
295
296(define-definition-type constant (variable-definition-type))
297
298(define-definition-type package ())
299
300(defmethod definition-base-name ((dt package-definition-type) name)
301  (if (or (stringp name) (non-nil-symbol-p name))
302    (intern (string name) :keyword)
303    name))
304
305(defmethod definition-bound-p ((dt package-definition-type) name)
306  (and (or (stringp name) (symbolp name))
307       (find-package (string name))))
308
309(defmethod definition-same-p ((dt package-definition-type) d1 d2)
310  (and (or (stringp d1) (symbolp d1))
311       (or (stringp d2) (symbolp d2))
312       (equal (string d1) (string d2))))
313
314
315;;;;;;;;;;;
316
317(declaim (inline default-definition-type))
318
319(defun default-definition-type (name)
320  (if (typep name 'method)
321    *method-definition-type*
322    *function-definition-type*))
323
324;; remember & reuse last few (TYPE . file) entries
325(let ((cache (make-list 10 :initial-element nil)))
326  (defun type-file-cons (type files)
327    (loop for prev = nil then p for p = cache then (cdr p)
328          do (when (or (and (eq type (caar p)) (equal files (cdar p)))
329                       (and (null (cdr p))
330                            (setf (car p) (cons type files))))
331               (when prev ;; move to front unless already there
332                 (setf (cdr prev) (cdr p))
333                 (setf (cdr p) cache)
334                 (setq cache p))
335               (return (car p))))))
336
337(defun %source-file-entries (key)
338  (let ((data (gethash key %source-files%)))
339    (if (and (listp data)
340             (listp (%cdr data)))
341      data
342      (list data))))
343
344(defun %set-source-file-entries (key list &aux data)
345  (setf (gethash key %source-files%)
346        (if (and list
347                 (null (cdr list))
348                 ;; One element, but make sure can recognize it.
349                 (not (and (listp (%car list))
350                           (listp (%cdar data)))))
351          (car list)
352          list)))
353
354(defun make-def-source-entry (key type name files)
355  (setq files (if (or (%cdr files) (listp (%car files))) files (%car files)))
356  (cond ((eq type (default-definition-type name))
357         (if (and (eq name key) (atom files))
358           files
359           (cons name files)))
360        ((eq name key)
361         (type-file-cons type files))
362        (t
363         (cons (cons type name) files))))
364
365(defun decode-def-source-entry (key entry)
366  (if (atom entry)
367    (and entry (values (default-definition-type key) key (list entry)))
368    (let* ((file-or-files (%cdr entry))
369           (files (if (consp file-or-files) file-or-files (list file-or-files))))
370      (cond ((typep (%car entry) 'definition-type)
371             (values (%car entry) key files))
372            ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
373             (values (%caar entry) (%cdar entry) files))
374            (t
375             (values (default-definition-type (%car entry)) (%car entry) files))))))
376
377(defun def-source-entry.name (key entry)
378  (assert (not (null entry)))
379  (cond ((atom entry) key)
380        ((typep (%car entry) 'definition-type) key)
381        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
382         (%cdar entry))
383        (t
384         (%car entry))))
385
386(defun def-source-entry.type (key entry)
387  (cond ((atom entry) (default-definition-type key))
388        ((typep (%car entry) 'definition-type) (%car entry))
389        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
390         (%caar entry))
391        (t
392         (default-definition-type (%car entry)))))
393
394(defun def-source-entry.sources (key entry)
395  (declare (ignore key))
396  (cond ((consp entry)
397         (if (consp (%cdr entry)) (%cdr entry) (list (%cdr entry))))
398        (entry (list entry))
399        (t nil)))
400
401
402;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
403;;;
404
405
406;; Some objects (specifically functions) have source location information associated with the
407;; object itself, in addition to any source locations associated with its definition.  This
408;; allows us to find source for, e.g., anonymous functions.
409(defgeneric get-object-sources (thing)
410  ;; returns a list of entries ((a-type . a-name) source . previous-sources)
411  (:method ((thing t)) nil)
412  (:method ((fn function))
413    (let ((source (function-source-note fn)))
414      (when source
415        (list (list* (cons *function-definition-type* (or (name-of fn) fn)) source nil)))))
416  (:method ((fn method-function))
417    (let ((source (function-source-note fn)))
418      (when source
419        (list (list* (cons *method-definition-type* (%method-function-method fn)) source nil)))))
420  (:method ((m method))
421    (get-object-sources (method-function m)))
422  (:method ((fn compiled-lexical-closure))
423    (get-object-sources (closure-function fn))))
424
425(defun find-definition-sources (name &optional (type t))
426  "Returns a list of entries ((a-type . a-name) source . previous-sources), where
427a-type is a subtype of TYPE, and a-name is either NAME or it's a special case of
428NAME (e.g. if NAME is the name of generic function, a-name could be a method of NAME).
429
430If NAME is not a cons or symbol, it's assumed to be an object (e.g. class or
431function) whose source location we try to heuristically locate, usually by looking up
432the sources of its name.
433
434If NAME is a method name and *DIRECT-METHODS-ONLY* is false, will also locate all
435applicable methods.
436
437The returned list is guaranteed freshly consed (ie suitable for nconc'ing)."
438
439  (let* ((dt-class (class-of (definition-type-instance type)))
440         (matches (get-object-sources name)))
441    (if matches
442      (setq matches (delete-if-not (lambda (info) (typep (caar info) dt-class)) matches))
443      ;; No intrinsic source info for the thing itself, look it up by name.
444      (let (seen-dts implicit-type implicit-dt-class implicit-name)
445        (typecase name
446          (method
447             (setq implicit-type 'method implicit-name name))
448          (method-function
449             (setq implicit-type 'method implicit-name (%method-function-method name)))
450          (function
451             (setq implicit-type 'function implicit-name (name-of name)))
452          (method-combination
453             (setq implicit-type 'method-combination implicit-name (name-of name)))
454          (package
455             (setq implicit-type 'package implicit-name (name-of name)))
456          (class
457             (setq implicit-type 'class implicit-name (name-of name)))
458          (t
459           (locally
460               (declare (ftype function xref-entry-p xref-entry-full-name xref-entry-type))
461             (if (and (find-class 'xref-entry nil)
462                      (xref-entry-p name))
463               (setq implicit-type (xref-entry-type name) implicit-name (xref-entry-full-name name))
464               (setq implicit-type t implicit-name name)))))
465        (setq implicit-dt-class (class-of (definition-type-instance implicit-type)))
466        (with-lock-grabbed (*source-files-lock*)
467          (loop for (nil . dt) in *definition-types*
468                when (and (typep dt dt-class) (typep dt implicit-dt-class) (not (memq dt seen-dts)))
469                  do (let* ((key (definition-base-name dt implicit-name))
470                            (all (%source-file-entries key)))
471                       (push dt seen-dts)
472                       (loop for entry in all
473                             when (and (eq dt (def-source-entry.type key entry))
474                                       (or (eq implicit-name key) ;; e.g. all methods on a gf
475                                           (definition-same-p dt implicit-name (def-source-entry.name key entry))))
476                               do (multiple-value-bind (type name files)
477                                      (decode-def-source-entry key entry)
478                                    (push (cons (cons type name) files) matches))))))))
479
480    ;; include indirect applicable methods.  Who uses this case?
481    (when (and (eq type 'method)
482               (not (typep name 'method))
483               (not *direct-methods-only*))
484      (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name)
485        (when sym
486          (loop for m in (find-applicable-methods sym specializers qualifiers)
487                unless (definition-same-p *method-definition-type* m name)
488                  do (setq matches (nconc (find-definition-sources m 'method) matches))))))
489    matches))
490
491;;; backward compatibility
492
493;;; modified version of %method-applicable-p - args are class names
494;;; not instances
495(defun %my-method-applicable-p (method args cpls)
496  (do* ((specs (%method-specializers method) (%cdr specs))
497        (args args (%cdr args))
498        (cpls cpls (%cdr cpls)))
499      ((null args) t)
500    (let ((spec (%car specs))
501          (arg (%car args)))
502      (if (typep spec 'eql-specializer)
503        (if (consp arg)
504          (unless (eql (cadr arg) (eql-specializer-object spec))
505            (return nil))
506          (if (typep (eql-specializer-object spec) arg)
507            ;(unless (eq arg *null-class*) (return :undecidable))
508            t  ;; include if it's at all possible it might be applicable.
509            (return nil)))
510        (unless (memq spec (%car cpls))
511          (return nil))))))
512
513;;; modified version of %compute-applicable-methods*
514;;; omit errors and args are class names not instances
515;;; returns a new list.
516(defun find-applicable-methods (name args qualifiers)
517  (let ((gf (fboundp name)))
518    (when (and gf (typep gf 'standard-generic-function))
519      (let* ((methods (or (%gf-methods gf)
520                          (return-from find-applicable-methods nil)))
521             (arg-count (length (%method-specializers (car methods))))
522             (args-length (length args))
523             (bits (inner-lfun-bits gf))
524             res)
525        (unless (or (logbitp $lfbits-rest-bit bits)
526                    (logbitp $lfbits-restv-bit bits)
527                    (logbitp $lfbits-keys-bit bits)
528                    (<= args-length 
529                        (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
530                                        ;(error "Too many args for ~s" gf)
531          (return-from find-applicable-methods))
532        (when (< arg-count args-length)
533          (setq args (subseq args 0 (setq args-length arg-count))))
534        (setq args (mapcar (lambda (arg)
535                             (typecase arg
536                               (eql-specializer `(eql ,(eql-specializer-object arg)))
537                               (class arg)
538                               (symbol (or (find-class (or arg t) nil)
539                                           ;;(error "Invalid class name ~s" arg)
540                                           (return-from find-applicable-methods)))
541                               (t
542                                  (unless (and (consp arg) (eql (car arg) 'eql) (null (cddr arg)))
543                                    ;;(error "Invalid specializer ~s" arg)
544                                    (return-from find-applicable-methods))
545                                  arg)))
546                           args))
547        (let ((cpls (make-list args-length)))
548          (declare (dynamic-extent cpls))
549          (do ((args-tail args (cdr args-tail))
550               (cpls-tail cpls (cdr cpls-tail)))
551              ((null cpls-tail))
552            (declare (type list args-tail cpls-tail))
553            (let ((arg (car args-tail)))
554              (setf (car cpls-tail)
555                    (%class-precedence-list (if (consp arg)
556                                              (class-of (cadr arg))
557                                              arg)))))
558          (dolist (m methods)
559            (when (%my-method-applicable-p m args cpls)
560              (push m res)))
561          (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
562            (when (eq (generic-function-method-combination gf)
563                      *standard-method-combination*)
564                                        ; around* (befores) (afters) primaries*
565              (setq methods (compute-method-list methods))
566              (when methods
567                (setq methods
568                      (if (not (consp methods))
569                        (list methods)
570                        (let ((afters (cadr (member-if #'listp methods))))
571                          (when afters (nremove afters methods))
572                          (nconc
573                           (mapcan #'(lambda (x)(if (listp x) x (cons x nil)))
574                                   methods)
575                           afters))))))
576            (if (and qualifiers (neq qualifiers t))
577              (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m))))
578                         methods)
579              methods)))))))
580
581;;; Do this just in case record source file doesn't remember the right
582;;; definition
583(defun methods-match-p (x y) 
584  (or (eq x y)
585      (and (typep x 'method)
586           (typep y 'method)
587           (equal (method-name x)
588                  (method-name y))
589           (equal (method-specializers x)
590                  (method-specializers y))
591           (equal (method-qualifiers x)
592                  (method-qualifiers y)))))
593
594(defun edit-definition-p (name &optional (type t)) ;exported
595  (let ((specs (get-source-files-with-types name type)))
596    (when (and (null specs)
597               (symbolp name))
598      (let* ((str (symbol-name name))
599             (len (length str)))
600        (when (and (> len 0) (memq (char str (1- len)) '(#\. #\, #\:)))
601          (let ((newsym (find-symbol (%substr str 0 (1- len)) (symbol-package name))))
602            (when newsym
603              (setq specs (get-source-files-with-types newsym type)))))))
604    specs))
605
606(defun get-source-files-with-types (name &optional (type t))
607  (let ((list (find-definition-sources name type)))
608    ;; Convert to old format, (type-or-name . file)
609    (loop for ((dt . full-name) . sources) in list
610          as spec = (if (eq full-name name) (definition-type-name dt) full-name)
611          nconc (mapcan (lambda (s)
612                          (when s (list (cons spec (source-note-filename s)))))
613                        sources))))
614
615
616;; For ilisp.
617(defun %source-files (name)
618  (let ((type-list ())
619        (meth-list ()))
620    (loop for ((dt . full-name) . sources) in (find-definition-sources name t)
621          as files = (mapcan #'(lambda (s)
622                                 (and s (setq s (source-note-filename s)) (list s)))
623                             sources)
624          when files
625            do (if (typep dt 'method-definition-type)
626                 (dolist (file files)
627                   (push (cons full-name file) meth-list))
628                 (push (cons (definition-type-name dt) files) type-list)))
629    (when meth-list
630      (push (cons 'method meth-list) type-list))
631    type-list))
632
633;; For CVS slime as of 11/15/2008.
634(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
635  (let* ((name (or the-method
636                   (and (or (eq type 'method) classes qualifiers)
637                        `(sym ,@qualifiers ,classes))
638                   sym)))
639    (get-source-files-with-types name type)))
640
641
642;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
643;;; record-source-file
644
645;; Returns nil if not a method/method name
646(defun method-def-parameters (m)
647  (when (typep m 'method-function)
648    (setq m (%method-function-method m)))
649  (if (typep m 'method)
650    (values (method-name m)
651            (method-qualifiers m)
652            (method-specializers m))
653    (let (name quals specs data last)
654      (when (consp m)
655        (when (eq (car m) :method) (setq m (cdr m)))
656        ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn))
657        (setq data (cdr m) last (last data))
658        (when (null (cdr last))
659          (setq last (car last))
660          (if (and (listp last) (neq (car last) 'eql))
661            (setq quals (butlast data) specs last)
662            (setq specs data))
663          (setq name (car m))
664          (when (and (or (non-nil-symbol-p name) (setf-function-name-p name))
665                     (every #'(lambda (q) (not (listp q))) quals)
666                     (every #'(lambda (s)
667                                (or (non-nil-symbol-p s)
668                                    (classp s)
669                                    (and (consp s)
670                                         (consp (cdr s))
671                                        (null (cddr s))
672                                         (eq (car s) 'eql))))
673                            specs))
674            (values name quals specs)))))))
675
676(defmethod record-definition-source ((dt definition-type) name source)
677  (let* ((key (definition-base-name dt name))
678         (all (%source-file-entries key))
679         (e-loc nil)
680         (e-files nil))
681    (loop for ptr on all as entry = (car ptr)
682          do (when (and (eq dt (def-source-entry.type key entry))
683                        (definition-same-p dt name (def-source-entry.name key entry)))
684               (setq e-files (def-source-entry.sources key entry))
685               (let ((old (flet ((same-file (x y)
686                                   (setq x (source-note-filename x))
687                                   (setq y (source-note-filename y))
688                                   (or (equal x y)
689                                       (and x
690                                            y
691                                            (or (stringp x) (pathnamep x))
692                                            (or (stringp y) (pathnamep y))
693                                            (equal
694                                             (or (probe-file x) (full-pathname x))
695                                             (or (probe-file y) (full-pathname y)))))))
696                            (member source e-files :test #'same-file))))
697                 (when (and old (neq source (car e-files))) ;; move to front
698                   (setq e-files (cons source (remove (car old) e-files :test #'eq)))))
699               (return (setq e-loc ptr))))
700    (unless (and e-files (eq source (car e-files)))
701      ;; Never previously defined in this file
702      (when (and (car e-files)            ; don't warn if last defined interactively
703                 *warn-if-redefine*
704                 (definition-bound-p dt name))
705        (warn "~A ~S previously defined in: ~A is now being redefined in: ~A~%"
706              (definition-type-name dt)
707              name
708              (source-note-filename (car e-files))
709              (or (source-note-filename source) "{No file}")))
710      (setq e-files (cons source e-files)))
711    (let ((entry (make-def-source-entry key dt name e-files)))
712      (if e-loc
713        (setf (car e-loc) entry)
714        (push entry all))
715      (%set-source-file-entries key all))
716    name))
717
718(defmethod record-definition-source ((dt method-definition-type) (m method) source)
719  ;; In cases of non-toplevel method definitions, as in the expansion of defgeneric,
720  ;; the method function note has more specific info than *loading-toplevel-location*.
721  (call-next-method dt m (or (function-source-note (method-function m)) source)))
722
723;;; avoid hanging onto beezillions of pathnames
724(defparameter *last-back-translated-name* (cons nil nil))
725
726;; Define the real record-source-file, which will be the last defn handled by the
727;; bootstrapping record-source-file, so convert all queued up data right afterwards.
728(progn
729
730(defun record-source-file (name def-type &optional (source (or *loading-toplevel-location*
731                                                               *loading-file-source-file*)))
732  (when (and source *record-source-file*)
733    (with-lock-grabbed (*source-files-lock*)
734      (let ((file-name (source-note-filename source)))
735        (when file-name
736          (unless (equalp file-name (car *last-back-translated-name*))
737            (setf (car *last-back-translated-name*) file-name)
738            (setf (cdr *last-back-translated-name*)
739                  (if (physical-pathname-p file-name)
740                    (namestring (back-translate-pathname file-name))
741                    file-name)))
742          (setq file-name (cdr *last-back-translated-name*))
743          (if (source-note-p source)
744            (setf (source-note-filename source) file-name)
745            (setq source file-name))))
746      (when (eq def-type 't) (report-bad-arg def-type '(not (eql t))))
747      (record-definition-source (definition-type-instance def-type
748                                    :if-does-not-exist :create)
749                                name
750                                source))))
751
752;; Collect level-0 source file info
753(do-all-symbols (s)
754  (let ((f (get s 'bootstrapping-source-files)))
755    (when f
756      (if (consp f)
757        (destructuring-bind ((type . source)) f
758          (when source (record-source-file s type source)))
759        (record-source-file s 'function f))
760      (remprop s 'bootstrapping-source-files))))
761
762;; Collect level-1 source file info
763(when (consp *record-source-file*)
764  (let ((list (nreverse (shiftf *record-source-file* t))))
765    (while list
766      (apply #'record-source-file (pop list)))))
767)
Note: See TracBrowser for help on using the repository browser.