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

Last change on this file since 12335 was 12335, checked in by gz, 10 years ago

In find-applicable-methods: allow args to be classes, not just class names

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