source: branches/working-0711/ccl/lib/source-files.lisp @ 12408

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods.

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

  • 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) 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 (method-name thing) ,@(method-qualifiers thing) ,(method-specializers 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           (locally
456               (declare (ftype function xref-entry-p xref-entry-full-name xref-entry-type))
457             (if (and (find-class 'xref-entry nil)
458                      (xref-entry-p name))
459               (setq implicit-type (xref-entry-type name) implicit-name (xref-entry-full-name name))
460               (setq implicit-type t implicit-name name)))))
461        (setq implicit-dt-class (class-of (definition-type-instance implicit-type)))
462        (with-lock-grabbed (*source-files-lock*)
463          (loop for (nil . dt) in *definition-types*
464                when (and (typep dt dt-class) (typep dt implicit-dt-class) (not (memq dt seen-dts)))
465                  do (let* ((key (definition-base-name dt implicit-name))
466                            (all (%source-file-entries key)))
467                       (push dt seen-dts)
468                       (loop for entry in all
469                             when (and (eq dt (def-source-entry.type key entry))
470                                       (or (eq implicit-name key) ;; e.g. all methods on a gf
471                                           (definition-same-p dt implicit-name (def-source-entry.name key entry))))
472                               do (multiple-value-bind (type name files)
473                                      (decode-def-source-entry key entry)
474                                    (push (cons (cons type name) files) matches))))))))
475
476    ;; include indirect applicable methods.  Who uses this case?
477    (when (and (eq type 'method)
478               (not (typep name 'method))
479               (not *direct-methods-only*))
480      (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name)
481        (when sym
482          (loop for m in (find-applicable-methods sym specializers qualifiers)
483                unless (definition-same-p *method-definition-type* m name)
484                  do (setq matches (nconc (find-definition-sources m 'method) matches))))))
485    matches))
486
487;;; backward compatibility
488
489;;; modified version of %method-applicable-p - args are class names
490;;; not instances
491(defun %my-method-applicable-p (method args cpls)
492  (do* ((specs (%method-specializers method) (%cdr specs))
493        (args args (%cdr args))
494        (cpls cpls (%cdr cpls)))
495      ((null args) t)
496    (let ((spec (%car specs))
497          (arg (%car args)))
498      (if (typep spec 'eql-specializer)
499        (if (consp arg)
500          (unless (eql (cadr arg) (eql-specializer-object spec))
501            (return nil))
502          (if (typep (eql-specializer-object spec) arg)
503            ;(unless (eq arg *null-class*) (return :undecidable))
504            t  ;; include if it's at all possible it might be applicable.
505            (return nil)))
506        (unless (memq spec (%car cpls))
507          (return nil))))))
508
509;;; modified version of %compute-applicable-methods*
510;;; omit errors and args are class names not instances
511;;; returns a new list.
512(defun find-applicable-methods (name args qualifiers)
513  (let ((gf (fboundp name)))
514    (when (and gf (typep gf 'standard-generic-function))
515      (let* ((methods (or (%gf-methods gf)
516                          (return-from find-applicable-methods nil)))
517             (arg-count (length (%method-specializers (car methods))))
518             (args-length (length args))
519             (bits (inner-lfun-bits gf))
520             res)
521        (unless (or (logbitp $lfbits-rest-bit bits)
522                    (logbitp $lfbits-restv-bit bits)
523                    (logbitp $lfbits-keys-bit bits)
524                    (<= args-length 
525                        (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
526                                        ;(error "Too many args for ~s" gf)
527          (return-from find-applicable-methods))
528        (when (< arg-count args-length)
529          (setq args (subseq args 0 (setq args-length arg-count))))
530        (setq args (mapcar (lambda (arg)
531                             (typecase arg
532                               (eql-specializer `(eql ,(eql-specializer-object arg)))
533                               (class arg)
534                               (symbol (or (find-class (or arg t) nil)
535                                           ;;(error "Invalid class name ~s" arg)
536                                           (return-from find-applicable-methods)))
537                               (t
538                                  (unless (and (consp arg) (eql (car arg) 'eql) (null (cddr arg)))
539                                    ;;(error "Invalid specializer ~s" arg)
540                                    (return-from find-applicable-methods))
541                                  arg)))
542                           args))
543        (let ((cpls (make-list args-length)))
544          (declare (dynamic-extent cpls))
545          (do ((args-tail args (cdr args-tail))
546               (cpls-tail cpls (cdr cpls-tail)))
547              ((null cpls-tail))
548            (declare (type list args-tail cpls-tail))
549            (let ((arg (car args-tail)))
550              (setf (car cpls-tail)
551                    (%class-precedence-list (if (consp arg)
552                                              (class-of (cadr arg))
553                                              arg)))))
554          (dolist (m methods)
555            (when (%my-method-applicable-p m args cpls)
556              (push m res)))
557          (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
558            (when (eq (generic-function-method-combination gf)
559                      *standard-method-combination*)
560                                        ; around* (befores) (afters) primaries*
561              (setq methods (compute-method-list methods))
562              (when methods
563                (setq methods
564                      (if (not (consp methods))
565                        (list methods)
566                        (let ((afters (cadr (member-if #'listp methods))))
567                          (when afters (nremove afters methods))
568                          (nconc
569                           (mapcan #'(lambda (x)(if (listp x) x (cons x nil)))
570                                   methods)
571                           afters))))))
572            (if (and qualifiers (neq qualifiers t))
573              (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m))))
574                         methods)
575              methods)))))))
576
577;;; Do this just in case record source file doesn't remember the right
578;;; definition
579(defun methods-match-p (x y) 
580  (or (eq x y)
581      (and (typep x 'method)
582           (typep y 'method)
583           (equal (method-name x)
584                  (method-name y))
585           (equal (method-specializers x)
586                  (method-specializers y))
587           (equal (method-qualifiers x)
588                  (method-qualifiers y)))))
589
590(defun edit-definition-p (name &optional (type t)) ;exported
591  (let ((specs (get-source-files-with-types name type)))
592    (when (and (null specs)
593               (symbolp name))
594      (let* ((str (symbol-name name))
595             (len (length str)))
596        (when (and (> len 0) (memq (char str (1- len)) '(#\. #\, #\:)))
597          (let ((newsym (find-symbol (%substr str 0 (1- len)) (symbol-package name))))
598            (when newsym
599              (setq specs (get-source-files-with-types newsym type)))))))
600    specs))
601
602(defun get-source-files-with-types (name &optional (type t))
603  (let ((list (find-definition-sources name type)))
604    ;; Convert to old format, (type-or-name . file)
605    (loop for ((dt . full-name) . sources) in list
606          as spec = (if (eq full-name name) (definition-type-name dt) full-name)
607          nconc (mapcan (lambda (s)
608                          (when s (list (cons spec (source-note-filename s)))))
609                        sources))))
610
611
612;; For ilisp.
613(defun %source-files (name)
614  (let ((type-list ())
615        (meth-list ()))
616    (loop for ((dt . full-name) . sources) in (find-definition-sources name t)
617          as files = (mapcan #'(lambda (s)
618                                 (and s (setq s (source-note-filename s)) (list s)))
619                             sources)
620          when files
621            do (if (typep dt 'method-definition-type)
622                 (dolist (file files)
623                   (push (cons full-name file) meth-list))
624                 (push (cons (definition-type-name dt) files) type-list)))
625    (when meth-list
626      (push (cons 'method meth-list) type-list))
627    type-list))
628
629;; For CVS slime as of 11/15/2008.
630(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
631  (let* ((name (or the-method
632                   (and (or (eq type 'method) classes qualifiers)
633                        `(sym ,@qualifiers ,classes))
634                   sym)))
635    (get-source-files-with-types name type)))
636
637
638;;; For ITA slime
639
640#+ccl-0711
641(defun find-definitions-for-name (name &optional (type-name t))
642  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
643  (declare (ignore name type-name))
644  (cerror "Don't find any definitions" "Obsolete slime version, upgrade to latest")
645  nil)
646
647#+ccl-0711
648(defun find-definitions-of-thing (thing)
649  (declare (ignore thing))
650  (cerror "Don't find any definitions" "Obsolete slime version, upgrade to latest")
651  nil)
652
653;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
654;;; record-source-file
655
656;; Returns nil if not a method/method name
657(defun method-def-parameters (m)
658  (when (typep m 'method-function)
659    (setq m (%method-function-method m)))
660  (if (typep m 'method)
661    (values (method-name m)
662            (method-qualifiers m)
663            (method-specializers m))
664    (let (name quals specs data last)
665      (when (consp m)
666        (when (eq (car m) :method) (setq m (cdr m)))
667        ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn))
668        (setq data (cdr m) last (last data))
669        (when (null (cdr last))
670          (setq last (car last))
671          (if (and (listp last) (neq (car last) 'eql))
672            (setq quals (butlast data) specs last)
673            (setq specs data))
674          (setq name (car m))
675          (when (and (or (non-nil-symbol-p name) (setf-function-name-p name))
676                     (every #'(lambda (q) (not (listp q))) quals)
677                     (every #'(lambda (s)
678                                (or (non-nil-symbol-p s)
679                                    (classp s)
680                                    (and (consp s)
681                                         (consp (cdr s))
682                                        (null (cddr s))
683                                         (eq (car s) 'eql))))
684                            specs))
685            (values name quals specs)))))))
686
687(defmethod record-definition-source ((dt definition-type) name source)
688  (let* ((key (definition-base-name dt name))
689         (all (%source-file-entries key))
690         (e-loc nil)
691         (e-files nil))
692    (loop for ptr on all as entry = (car ptr)
693          do (when (and (eq dt (def-source-entry.type key entry))
694                        (definition-same-p dt name (def-source-entry.name key entry)))
695               (setq e-files (def-source-entry.sources key entry))
696               (let ((old (flet ((same-file (x y)
697                                   (setq x (source-note-filename x))
698                                   (setq y (source-note-filename y))
699                                   (or (equal x y)
700                                       (and x
701                                            y
702                                            (or (stringp x) (pathnamep x))
703                                            (or (stringp y) (pathnamep y))
704                                            (equal
705                                             (or (probe-file x) (full-pathname x))
706                                             (or (probe-file y) (full-pathname y)))))))
707                            (member source e-files :test #'same-file))))
708                 (when (and old (neq source (car e-files))) ;; move to front
709                   (setq e-files (cons source (remove (car old) e-files :test #'eq)))))
710               (return (setq e-loc ptr))))
711    (unless (and e-files (eq source (car e-files)))
712      ;; Never previously defined in this file
713      (when (and (car e-files)            ; don't warn if last defined interactively
714                 *warn-if-redefine*
715                 (definition-bound-p dt name))
716        (warn "~A ~S previously defined in: ~A is now being redefined in: ~A~%"
717              (definition-type-name dt)
718              name
719              (source-note-filename (car e-files))
720              (or (source-note-filename source) "{No file}")))
721      (setq e-files (cons source e-files)))
722    (let ((entry (make-def-source-entry key dt name e-files)))
723      (if e-loc
724        (setf (car e-loc) entry)
725        (push entry all))
726      (%set-source-file-entries key all))
727    name))
728
729(defmethod record-definition-source ((dt method-definition-type) (m method) source)
730  ;; In cases of non-toplevel method definitions, as in the expansion of defgeneric,
731  ;; the method function note has more specific info than *loading-toplevel-location*.
732  (call-next-method dt m (or (function-source-note (method-function m)) source)))
733
734;;; avoid hanging onto beezillions of pathnames
735(defparameter *last-back-translated-name* (cons nil nil))
736
737;; Define the real record-source-file, which will be the last defn handled by the
738;; bootstrapping record-source-file, so convert all queued up data right afterwards.
739(progn
740
741(defun record-source-file (name def-type &optional (source (or *loading-toplevel-location*
742                                                               *loading-file-source-file*)))
743  (when (and source *record-source-file*)
744    (with-lock-grabbed (*source-files-lock*)
745      (let ((file-name (source-note-filename source)))
746        (when file-name
747          (unless (equalp file-name (car *last-back-translated-name*))
748            (setf (car *last-back-translated-name*) file-name)
749            (setf (cdr *last-back-translated-name*)
750                  (if (physical-pathname-p file-name)
751                    (namestring (back-translate-pathname file-name))
752                    file-name)))
753          (setq file-name (cdr *last-back-translated-name*))
754          (if (source-note-p source)
755            (setf (source-note-filename source) file-name)
756            (setq source file-name))))
757      (when (eq def-type 't) (report-bad-arg def-type '(not (eql t))))
758      (record-definition-source (definition-type-instance def-type
759                                    :if-does-not-exist :create)
760                                name
761                                source))))
762
763;; Collect level-0 source file info
764(do-all-symbols (s)
765  (let ((f (get s 'bootstrapping-source-files)))
766    (when f
767      (if (consp f)
768        (destructuring-bind ((type . source)) f
769          (when source (record-source-file s type source)))
770        (record-source-file s 'function f))
771      (remprop s 'bootstrapping-source-files))))
772
773;; Collect level-1 source file info
774(when (consp *record-source-file*)
775  (let ((list (nreverse (shiftf *record-source-file* t))))
776    (while list
777      (apply #'record-source-file (pop list)))))
778)
Note: See TracBrowser for help on using the repository browser.