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

Last change on this file since 11067 was 11067, checked in by gz, 12 years ago

Move parse-definition-spec to xref.lisp. Record-source-file for setf-expanders and long-form defsetf. Make compiler-macro-definition-type be a subtype of macro-definition-type, ditto for symbol-macro and setf-expander. Add find-definitions-for-name.

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