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

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

some definition-type fixes from r11054

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.6 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 :initform t))
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(defmethod definition-base-name ((dt function-definition-type) name)
195  (while (and (consp name) (not (setf-function-name-p name)))
196    (let ((x (last name)))
197      (or (setq name (cdr x))
198          ;; Try to detect the (:internal .... <hairy-method-name>) case
199          (when (and (setq name (car x))
200                     ;;check for plausible method name
201                     (setq x (method-def-parameters name))
202                     (neq x 'setf)
203                     (not (keywordp x)))
204            (setq name x)))))
205  (canonical-maybe-setf-name name))
206
207(defmethod definition-bound-p ((dt function-definition-type) name)
208  (and (or (symbolp name) (setf-function-name-p name))
209       (or (fboundp name)
210           ;; treat long-form setf expanders like macros.
211           (and (consp name) (functionp (%setf-method (cadr name)))))))
212
213(define-definition-type macro (function-definition-type))
214
215(define-definition-type compiler-macro (macro-definition-type))
216
217(define-definition-type symbol-macro (macro-definition-type))
218
219(define-definition-type setf-expander (macro-definition-type))
220
221(define-definition-type generic-function (function-definition-type))
222
223(define-definition-type method ())
224
225(defparameter *method-definition-type* (definition-type-instance 'method))
226
227(defmethod definition-base-name ((dt method-definition-type) (name cons))
228  (if (setf-function-name-p name)
229    (canonical-maybe-setf-name name)
230    (definition-base-name *function-definition-type* (car name))))
231
232;; defmethod passes the actual method into record-source-file
233(defmethod definition-base-name ((dt method-definition-type) (method method))
234  (definition-base-name dt (method-name method)))
235
236(defmethod definition-same-p ((dt method-definition-type) m1 m2)
237  (multiple-value-bind (n1 q1 s1) (method-def-parameters m1)
238    (multiple-value-bind (n2 q2 s2) (method-def-parameters m2)
239      (and (definition-same-p *function-definition-type* n1 n2)
240           (equal q1 q2)
241           (eql (length s1) (length s2))
242           (every #'(lambda (s1 s2)
243                      (or (equal s1 s2)
244                          (progn
245                            (when (symbolp s2) (rotatef s1 s2))
246                            (and (symbolp s1)
247                                 (classp s2)
248                                 (or (eq (find-class s1 nil) s2)
249                                     (eq s1 (class-name s2)))))))
250                  s1 s2)))))
251
252(defmethod definition-bound-p ((dt method-definition-type) meth &aux fn)
253  (when (setq fn (method-def-parameters meth))
254    (loop for m in (and (setq fn (fboundp fn))
255                        (typep fn 'generic-function)
256                        (generic-function-methods fn))
257          thereis (definition-same-p dt meth m))))
258
259(define-definition-type reader-method (method-definition-type))
260
261(define-definition-type writer-method (method-definition-type))
262
263(define-definition-type callback (function-definition-type))
264
265(define-definition-type structure-accessor (function-definition-type))
266
267(define-definition-type type ())
268
269(define-definition-type class ())
270
271(defmethod definition-bound-p ((dt class-definition-type) name)
272  (and (non-nil-symbol-p name) (find-class name nil)))
273
274(define-definition-type condition (class-definition-type))
275
276(define-definition-type structure ())
277
278(define-definition-type definition-type ())
279
280(defmethod definition-bound-p ((dt definition-type-definition-type) name)
281  (definition-type-instance name :if-does-not-exist nil))
282
283(define-definition-type method-combination ())
284
285(define-definition-type variable ())
286
287(defmethod definition-bound-p ((dt variable-definition-type) name)
288  (and (non-nil-symbol-p name) (boundp name)))
289
290(define-definition-type constant (variable-definition-type))
291
292(define-definition-type package ())
293
294(defmethod definition-base-name ((dt package-definition-type) name)
295  (if (or (stringp name) (non-nil-symbol-p name))
296    (intern (string name) :keyword)
297    name))
298
299(defmethod definition-bound-p ((dt package-definition-type) name)
300  (and (or (stringp name) (symbolp name))
301       (find-package (string name))))
302
303(defmethod definition-same-p ((dt package-definition-type) d1 d2)
304  (and (or (stringp d1) (symbolp d1))
305       (or (stringp d2) (symbolp d2))
306       (equal (string d1) (string d2))))
307
308
309;;;;;;;;;;;
310
311(declaim (inline default-definition-type))
312
313(defun default-definition-type (name)
314  (if (typep name 'method)
315    *method-definition-type*
316    *function-definition-type*))
317
318;; remember & reuse last few (TYPE . file) entries
319(let ((cache (make-list 10 :initial-element nil)))
320  (defun type-file-cons (type files)
321    (loop for prev = nil then p for p = cache then (cdr p)
322          do (when (or (and (eq type (caar p)) (equal files (cdar p)))
323                       (and (null (cdr p))
324                            (setf (car p) (cons type files))))
325               (when prev ;; move to front unless already there
326                 (setf (cdr prev) (cdr p))
327                 (setf (cdr p) cache)
328                 (setq cache p))
329               (return (car p))))))
330
331(defun %source-file-entries (key)
332  (let ((data (gethash key %source-files%)))
333    (if (and (listp data)
334             (listp (%cdr data)))
335      data
336      (list data))))
337
338(defun %set-source-file-entries (key list &aux data)
339  (setf (gethash key %source-files%)
340        (if (and list
341                 (null (cdr list))
342                 ;; One element, but make sure can recognize it.
343                 (not (and (listp (%car list))
344                           (listp (%cdar data)))))
345          (car list)
346          list)))
347
348(defun make-def-source-entry (key type name files)
349  (setq files (if (or (%cdr files) (listp (%car files))) files (%car files)))
350  (cond ((eq type (default-definition-type name))
351         (if (and (eq name key) (atom files))
352           files
353           (cons name files)))
354        ((eq name key)
355         (type-file-cons type files))
356        (t
357         (cons (cons type name) files))))
358
359(defun decode-def-source-entry (key entry)
360  (if (atom entry)
361    (and entry (values (default-definition-type key) key (list entry)))
362    (let* ((file-or-files (%cdr entry))
363           (files (if (consp file-or-files) file-or-files (list file-or-files))))
364      (cond ((typep (%car entry) 'definition-type)
365             (values (%car entry) key files))
366            ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
367             (values (%caar entry) (%cdar entry) files))
368            (t
369             (values (default-definition-type (%car entry)) (%car entry) files))))))
370
371(defun def-source-entry.name (key entry)
372  (assert (not (null entry)))
373  (cond ((atom entry) key)
374        ((typep (%car entry) 'definition-type) key)
375        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
376         (%cdar entry))
377        (t
378         (%car entry))))
379
380(defun def-source-entry.type (key entry)
381  (cond ((atom entry) (default-definition-type key))
382        ((typep (%car entry) 'definition-type) (%car entry))
383        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
384         (%caar entry))
385        (t
386         (default-definition-type (%car entry)))))
387
388(defun def-source-entry.sources (key entry)
389  (declare (ignore key))
390  (cond ((consp entry)
391         (if (consp (%cdr entry)) (%cdr entry) (list (%cdr entry))))
392        (entry (list entry))
393        (t nil)))
394
395
396;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
397;;;
398
399
400(defun find-definition-sources (name &optional (type t))
401  "Returns a list of entries ((a-type . a-name) source . previous-sources), where
402a-type is a subtype of TYPE, and a-name is either NAME or it's a special case of
403NAME (e.g. if NAME is the name of generic function, a-name could be a method of NAME).
404The list is guaranteed freshly consed (ie suitable for nconc'ing)."
405  (let* ((dt (definition-type-instance type))
406         (dt-class (class-of dt))
407         (seen-dts nil)
408         (matches nil))
409    (with-lock-grabbed (*source-files-lock*)
410      (loop for (nil . dt) in *definition-types*
411            when (and (typep dt dt-class) (not (memq dt seen-dts)))
412              do (let* ((key (definition-base-name dt name))
413                        (all (%source-file-entries key)))
414                   (push dt seen-dts)
415                   (loop for entry in all
416                         when (and (eq dt (def-source-entry.type key entry))
417                                   (or (eq name key) ;; e.g. all methods on a gf
418                                       (definition-same-p dt name (def-source-entry.name key entry))))
419                           do (multiple-value-bind (type name files)
420                                  (decode-def-source-entry key entry)
421                                (push (cons (cons type name) files) matches))))))
422    matches))
423
424
425;;; backward compatibility
426
427;;; modified version of %method-applicable-p - args are class names
428;;; not instances
429(defun %my-method-applicable-p (method args cpls)
430  (do ((specs (%method-specializers method) (cdr specs))
431       (args args (cdr args))
432       (cpls cpls (cdr cpls)))
433      ((null specs) t)
434    (declare (type list specs args cpls))
435    (let ((spec (car specs)))
436      (if (listp spec)
437        (unless (equal (car args) spec)
438          (return nil))
439        (unless (memq spec (car cpls))
440          (return nil))))))
441
442;;; modified version of %compute-applicable-methods*
443;;; omit errors and args are class names not instances
444;;; returns a new list.
445(defun find-applicable-methods (name args qualifiers)
446  (let ((gf (fboundp name)))
447    (when (and gf (typep gf 'standard-generic-function))
448      (let* ((methods (%gf-methods gf))
449             (args-length (length args))
450             (bits (lfun-bits (closure-function gf)))  ; <<
451             arg-count res)
452        (when methods
453          (setq arg-count (length (%method-specializers (car methods))))
454          (unless (or (logbitp $lfbits-rest-bit bits)
455                      (logbitp $lfbits-keys-bit bits)
456                      (<= args-length 
457                          (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
458            (return-from find-applicable-methods))
459          (cond 
460           ((null args)
461            (dolist (m methods res)
462              (when (or (eq qualifiers t)
463                        (equal qualifiers (%method-qualifiers m))) 
464                (push m res))))
465           ((%i< args-length arg-count)
466            (let (spectails)
467              (dolist (m methods)
468                (let ((mtail (nthcdr args-length (%method-specializers m))))
469                  (pushnew mtail spectails :test #'equal)))
470              (dolist (tail spectails)
471                (setq res 
472                      (nconc res (find-applicable-methods 
473                                  name 
474                                  (append args (mapcar 
475                                                #'(lambda (x) (if (consp x) x (class-name x)))
476                                                tail))
477                                  qualifiers))))
478              (if (%cdr spectails)
479                (delete-duplicates res :from-end t :test #'eq)
480                res)))
481           (t 
482            (let ((cpls (make-list arg-count)))
483              (declare (dynamic-extent cpls))
484              (do ((args-tail args (cdr args-tail))
485                   (cpls-tail cpls (cdr cpls-tail)))
486                  ((null cpls-tail))
487                (declare (type list args-tail cpls-tail))
488                (let ((arg (car args-tail)) thing)
489                  (if (consp arg)
490                    (setq thing (class-of (cadr arg)))
491                    (setq thing (find-class (or arg t) nil)))
492                  (when thing
493                    (setf (car cpls-tail)               
494                          (%class-precedence-list thing)))))
495              (dolist (m methods)
496                (when (%my-method-applicable-p m args cpls)
497                  (push m res)))
498              (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
499                (when (eq (generic-function-method-combination gf)
500                          *standard-method-combination*)
501                  ; around* (befores) (afters) primaries*
502                  (setq methods (compute-method-list methods))
503                  (when methods
504                    (setq methods
505                          (if (not (consp methods))
506                            (list methods)
507                            (let ((afters (cadr (member-if #'listp methods))))
508                              (when afters (nremove afters methods))
509                              (nconc
510                               (mapcan #'(lambda (x)(if (listp x) x (cons x nil)))
511                                       methods)
512                               afters))))))
513                (if (and qualifiers (neq qualifiers t))
514                  (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m))))
515                             methods)
516                  methods))))))))))
517
518;;; Do this just in case record source file doesn't remember the right
519;;; definition
520(defun methods-match-p (x y) 
521  (or (eq x y)
522      (and (typep x 'method)
523           (typep y 'method)
524           (equal (method-name x)
525                  (method-name y))
526           (equal (method-specializers x)
527                  (method-specializers y))
528           (equal (method-qualifiers x)
529                  (method-qualifiers y)))))
530
531(defun edit-definition-p (name &optional (type t)) ;exported
532  (let ((specs (get-source-files-with-types name type)))
533    (when (and (null specs)
534               (symbolp name))
535      (let* ((str (symbol-name name))
536             (len (length str)))
537        (when (and (> len 0) (memq (char str (1- len)) '(#\. #\, #\:)))
538          (let ((newsym (find-symbol (%substr str 0 (1- len)) (symbol-package name))))
539            (when newsym
540              (setq specs (get-source-files-with-types newsym type)))))))
541    specs))
542
543(defun get-source-files-with-types (name &optional (type t))
544  (let ((list (find-definition-sources name type)))
545    (declare (special *direct-methods-only*))
546    ;; include indirect applicable methods.  Who uses this case?
547    (when (and (eq type 'method)
548               (not (typep name 'method))
549               (not *direct-methods-only*))
550      (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name)
551        (when sym
552          (loop for m in (find-applicable-methods sym specializers qualifiers)
553                unless (definition-same-p *method-definition-type* m name)
554                  do (setq list (nconc (find-definition-sources m 'method) list))))))
555    ;; Convert to old format, (type-or-name . file)
556    (loop for ((dt . full-name) . files) in list
557          as spec = (if (eq full-name name) (definition-type-name dt) full-name)
558          nconc (mapcan (lambda (file) (when file (list (cons spec file)))) files))))
559
560
561(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
562  (let* ((name (or the-method
563                   (and (or (eq type 'method) classes qualifiers)
564                        `(sym ,@qualifiers ,classes))
565                   sym)))
566    (get-source-files-with-types name type)))
567
568
569;; For ilisp.
570(defun %source-files (name)
571  (let ((type-list ())
572        (meth-list ()))
573    (loop for ((dt . full-name) . files) in (find-definition-sources name t)
574          do (if (typep dt 'method-definition-type)
575               (dolist (file files)
576                 (push (cons full-name file) meth-list))
577               (push (cons (definition-type-name dt) files) type-list)))
578    (when meth-list
579      (push (cons 'method meth-list) type-list))
580    type-list))
581
582;;; For swank.
583
584(defun find-definitions-for-name (name &optional (type-name t))
585  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
586  (let ((definitions ()))
587    (loop for ((dt . full-name) last-source . nil)
588            in (find-definition-sources name type-name)
589          do (when last-source
590               (push (list dt full-name last-source) definitions)))
591    definitions))
592
593(defun find-simple-definitions-for-name (name)
594  (let* ((result (find-definitions-for-name name)))
595    (dolist (pair result result)
596      (let* ((dt (car pair)))
597        (when (typep dt 'definition-type)
598          (setf (car pair) (definition-type-name dt)))))))
599
600;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601;;; record-source-file
602
603;; Returns nil if not a method/method name
604(defun method-def-parameters (m)
605  (if (typep m 'method)
606    (values (method-name m)
607            (method-qualifiers m)
608            (method-specializers m))
609    (let (name quals specs data last)
610      (when (consp m)
611        ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn))
612        (setq data (cdr m) last (last data))
613        (when (null (cdr last))
614          (setq last (car last))
615          (if (and (listp last) (neq (car last) 'eql))
616            (setq quals (butlast data) specs last)
617            (setq specs data))
618          (setq name (car m))
619          (when (and (or (non-nil-symbol-p name) (setf-function-name-p name))
620                     (every #'(lambda (q) (not (listp q))) quals)
621                     (every #'(lambda (s)
622                                (or (non-nil-symbol-p s)
623                                    (classp s)
624                                    (and (consp s)
625                                         (consp (cdr s))
626                                        (null (cddr s))
627                                         (eq (car s) 'eql))))
628                            specs))
629            (values name quals specs)))))))
630
631(defmethod record-definition-source ((dt definition-type) name file-name)
632  (let* ((key (definition-base-name dt name))
633         (all (%source-file-entries key))
634         (e-loc nil)
635         (e-files nil))
636    (loop for ptr on all as entry = (car ptr)
637          do (when (and (eq dt (def-source-entry.type key entry))
638                        (definition-same-p dt name (def-source-entry.name key entry)))
639               (setq e-files (def-source-entry.sources key entry))
640               (let ((old (flet ((same-file (x y)
641                                   (or (equal x y)
642                                       (and x
643                                            y
644                                            (equal
645                                             (or (probe-file x) (full-pathname x))
646                                             (or (probe-file y) (full-pathname y)))))))
647                            (member file-name e-files :test #'same-file))))
648                 (when (and old (neq file-name (car e-files))) ;; move to front
649                   (setq e-files (cons file-name (remove (car old) e-files :test #'eq)))))
650               (return (setq e-loc ptr))))
651    (unless (and e-files (eq file-name (car e-files)))
652      ;; Never previously defined in this file
653      (when (and (car e-files)            ; don't warn if last defined interactively
654                 *warn-if-redefine*
655                 (definition-bound-p dt name))
656        (warn "~A ~S previously defined in: ~A is now being redefined in: ~A~%"
657              (definition-type-name dt)
658              name
659              (car e-files)
660              (or file-name "{No file}")))
661      (setq e-files (cons file-name e-files)))
662    (let ((entry (make-def-source-entry key dt name e-files)))
663      (if e-loc
664        (setf (car e-loc) entry)
665        (push entry all))
666      (%set-source-file-entries key all))
667    name))
668
669;; Define the real record-source-file, which will be the last defn handled by the
670;; bootstrapping record-source-file, so convert all queued up data right afterwards.
671(progn
672
673(defun record-source-file (name def-type &optional (file-name *loading-file-source-file*))
674  (when *record-source-file*
675    (with-lock-grabbed (*source-files-lock*)
676      (when (and file-name (physical-pathname-p file-name))
677        (setq file-name (namestring (back-translate-pathname file-name)))
678        (cond ((equalp file-name *last-back-translated-name*)
679               (setq file-name *last-back-translated-name*))
680              (t (setq *last-back-translated-name* file-name))))
681      (when (eq def-type 't) (report-bad-arg def-type '(not (eql t))))
682      (record-definition-source (definition-type-instance def-type
683                                    :if-does-not-exist :create)
684                                name
685                                file-name))))
686
687;; Collect level-0 source file info
688(do-all-symbols (s)
689  (let ((f (get s 'bootstrapping-source-files)))
690    (when f
691      (setf (gethash s %source-files%) f)
692      (remprop s 'bootstrapping-source-files))))
693;; Collect level-1 source file info
694(when (consp *record-source-file*)
695  (let ((list (nreverse (shiftf *record-source-file* t))))
696    (while list
697      (apply #'record-source-file (pop list)))))
698)
Note: See TracBrowser for help on using the repository browser.