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

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

Some changes in support of Slime:

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

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

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, return object for eql-specializer

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