source: branches/qres/ccl/lib/source-files.lisp @ 13565

Last change on this file since 13565 was 13565, checked in by gz, 9 years ago

replace ccl-0711 feature with ccl-qres

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