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

Last change on this file since 11420 was 11420, checked in by gz, 11 years ago

Remove obsolete bootstrapping code, fix indentation

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.7 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 function)) (name-of (function-name thing)))
39  (:method ((thing method)) (method-name thing))
40  (:method ((thing class)) (class-name thing))
41  (:method ((thing method-combination)) (method-combination-name thing))
42  (:method ((thing package)) (package-name thing)))
43
44;; This used to be weak, but the keys are symbols-with-definitions, so why bother.
45;; Set a high rehash threshold because space matters more than speed here.
46(defvar %source-files% (make-hash-table :test #'eq
47                                        :size 13000
48                                        :rehash-threshold .95))
49
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51;;
52;; Definition types
53;;
54;; Definition types are uniquely identified by a symbol, but are implemented as
55;; classes so they can inherit/customize behavior.  They have no instances other
56;; than the class prototype, which is used to invoke methods.
57;;
58
59(defgeneric definition-type-name (def-type)
60  (:documentation "The preferred user-visible name of the def-type.  Used for
61error messages etc.  The default method returns the name specified in
62define-definition-type."))
63
64(defclass definition-type ()
65  ((name :allocation :class :reader definition-type-name :initform t))
66  (:documentation "Superclass of all definition types"))
67
68(defgeneric definition-base-name (def-type def)
69  ;; Note that a def can have multiple base names, but each one needs a different def-type
70  (:documentation "Return the name that, when the user asks for all definitions of that
71name, this def should be included.  Typically this is a symbol.  It's used as a key in
72an EQ hash table, so must return EQ values for equivalent definitions.
73The default method returns the rightmost atom in name")
74  (:method ((dt definition-type) name)
75    (while (consp name)
76      (let ((x (last name)))
77        (setq name (or (cdr x) (car x)))))
78    name))
79
80(defgeneric definition-same-p (def-type def1 def2)
81  (:documentation "Returns true if the two definitions are equivalent, i.e. one should
82replace the other.  The default method calls EQUAL.")
83  (:method ((dt definition-type) name1 name2)
84    (equal name1 name2)))
85
86(defgeneric definition-bound-p (def-type def)
87  (:documentation "Returns true if def is currently defined.  Used to decide whether to issue
88redefinition warnings.  The default method returns T.")
89  (:method ((dt definition-type) name)
90    (declare (ignore name))
91    t))
92
93;;;;;;;;;;
94
95(defvar *definition-types* ()
96  "alist of all known definition type names and their class prototypes")
97
98(defmethod print-object ((dt definition-type) stream)
99  (if *print-escape*
100    (let ((definedp (class-name (class-of dt))))
101      (print-unreadable-object (dt stream :type definedp :identity t)
102        (unless definedp
103          (format stream "#:~s " 'definition-type)) ;; subtly indicate it's a subclass...
104        (format stream "~s" (definition-type-name dt))))
105    (format stream "~s" (definition-type-name dt))))
106
107(defmethod name-of ((thing definition-type))
108  (definition-type-name thing))
109
110(defmacro define-definition-type (name supers &rest options)
111  "Defines a class named name-DEFINITION-TYPE and registers it as the class of
112definition type NAME"
113  (loop with known-keys = '( ;; Backward compatibility
114                            #+ccl-0711 :default-name-function)
115        for (key . nil) in options
116        unless (memq key known-keys)
117          do (signal-program-error "Unknown option ~s" key))
118  (let ((class-name (intern (%str-cat (symbol-name name) "-DEFINITION-TYPE"))))
119    `(progn
120       (defclass ,class-name ,(or supers '(definition-type))
121         ((name :allocation :class :initform ',name)))
122       (record-source-file ',name 'definition-type)
123       (register-definition-type (find-class ',class-name) '(,name)))))
124
125(defun register-definition-type (class names)
126  (let ((instance (class-prototype class)))
127    (with-lock-grabbed (*source-files-lock*)
128      ;; If had a previous definition, the defclass will signal any duplicate
129      ;; definition warnings, so here just silently replace previous one.
130      (without-interrupts
131        (setq *definition-types*
132              (remove instance *definition-types* :key #'cdr)))
133      (loop for name in names
134            unless (without-interrupts
135                     (unless (assq name *definition-types*)
136                       (push (cons name instance) *definition-types*)))
137              do (error "There is already a different definition type ~s named ~s"
138                        (cdr (assq name *definition-types*))
139                        name)))
140    ;; Return instance for use in make-load-form
141    instance))
142
143(defun auto-create-definition-type (name)
144  ;; Use an anonymous class, so this means can't write methods on it.
145  ;; If you want to write methods on it, use define-definition-type first.
146  (let* ((super (find-class 'definition-type))
147         (new-class (make-instance (class-of super)
148                      :direct-superclasses (list super)
149                      :direct-slots `((:name name
150                                       :allocation :class
151                                       :initform ',name
152                                       :initfunction ,(constantly name))))))
153    (register-definition-type new-class (list name))
154    (class-prototype new-class)))
155
156(defmethod definition-type-instance ((dt definition-type) &key (if-does-not-exist :error))
157  (if (rassoc dt *definition-types* :test #'eq)
158    dt
159    (ecase if-does-not-exist
160      ((nil) nil)
161      ((:error) (error "~s is not a known definition-type" dt)))))
162
163(defmethod definition-type-instance ((name symbol) &key (if-does-not-exist :error))
164  (or (cdr (assq name *definition-types*))
165      (ecase if-does-not-exist
166        ((nil) nil)
167        ((:error) (error "~s is not a known definition-type" name))
168        ((:create) (auto-create-definition-type name)))))
169
170(defmethod definition-type-instance ((class class) &key (if-does-not-exist :error))
171  (definition-type-instance (class-prototype class) :if-does-not-exist if-does-not-exist))
172
173(defmethod make-load-form ((dt definition-type) &optional env)
174  (declare (ignore env))
175  (let ((names (loop for (name . instance) in *definition-types*
176                     when (eq dt instance) collect name)))
177    `(register-definition-type ',(class-of dt) ',names)))
178
179
180(register-definition-type (find-class 'definition-type) '(t))
181
182(defparameter *t-definition-type* (definition-type-instance 't))
183
184(define-definition-type function ())
185
186(defparameter *function-definition-type* (definition-type-instance 'function))
187
188(defmethod definition-base-name ((dt function-definition-type) name)
189  (while (and (consp name) (not (setf-function-name-p name)))
190    (let ((x (last name)))
191      (or (setq name (cdr x))
192          ;; Try to detect the (:internal .... <hairy-method-name>) case
193          (when (and (setq name (car x))
194                     ;;check for plausible method name
195                     (setq x (method-def-parameters name))
196                     (neq x 'setf)
197                     (not (keywordp x)))
198            (setq name x)))))
199  (canonical-maybe-setf-name name))
200
201(defmethod definition-bound-p ((dt function-definition-type) name)
202  (and (or (symbolp name) (setf-function-name-p name))
203       (or (fboundp name)
204           ;; treat long-form setf expanders like macros.
205           (and (consp name) (functionp (%setf-method (cadr name)))))))
206
207(define-definition-type macro (function-definition-type))
208
209(define-definition-type compiler-macro (macro-definition-type))
210
211(define-definition-type symbol-macro (macro-definition-type))
212
213(define-definition-type setf-expander (macro-definition-type))
214
215(define-definition-type generic-function (function-definition-type))
216
217(define-definition-type method ())
218
219(defparameter *method-definition-type* (definition-type-instance 'method))
220
221(defmethod definition-base-name ((dt method-definition-type) (name cons))
222  (if (setf-function-name-p name)
223    (canonical-maybe-setf-name name)
224    (definition-base-name *function-definition-type* (car name))))
225
226;; defmethod passes the actual method into record-source-file
227(defmethod definition-base-name ((dt method-definition-type) (method method))
228  (definition-base-name dt (method-name method)))
229
230(defmethod definition-base-name ((dt method-definition-type) (fn method-function))
231  (definition-base-name dt (function-name fn)))
232
233(defmethod definition-same-p ((dt method-definition-type) m1 m2)
234  (multiple-value-bind (n1 q1 s1) (method-def-parameters m1)
235    (multiple-value-bind (n2 q2 s2) (method-def-parameters m2)
236      (and (definition-same-p *function-definition-type* n1 n2)
237           (equal q1 q2)
238           (eql (length s1) (length s2))
239           (every #'(lambda (s1 s2)
240                      (or (equal s1 s2)
241                          (progn
242                            (when (symbolp s2) (rotatef s1 s2))
243                            (and (symbolp s1)
244                                 (classp s2)
245                                 (or (eq (find-class s1 nil) s2)
246                                     (eq s1 (class-name s2)))))))
247                  s1 s2)))))
248
249(defmethod definition-bound-p ((dt method-definition-type) meth &aux fn)
250  (when (setq fn (method-def-parameters meth))
251    (loop for m in (and (setq fn (fboundp fn))
252                        (typep fn 'generic-function)
253                        (generic-function-methods fn))
254          thereis (definition-same-p dt meth m))))
255
256(define-definition-type reader-method (method-definition-type))
257
258(define-definition-type writer-method (method-definition-type))
259
260(define-definition-type callback (function-definition-type))
261
262(define-definition-type structure-accessor (function-definition-type))
263
264(define-definition-type type ())
265
266(define-definition-type class ())
267
268(defmethod definition-bound-p ((dt class-definition-type) name)
269  (and (non-nil-symbol-p name) (find-class name nil)))
270
271(define-definition-type condition (class-definition-type))
272
273(define-definition-type structure ())
274
275(define-definition-type definition-type ())
276
277(defmethod definition-bound-p ((dt definition-type-definition-type) name)
278  (definition-type-instance name :if-does-not-exist nil))
279
280(define-definition-type method-combination ())
281
282(define-definition-type variable ())
283
284(defmethod definition-bound-p ((dt variable-definition-type) name)
285  (and (non-nil-symbol-p name) (boundp name)))
286
287(define-definition-type constant (variable-definition-type))
288
289(define-definition-type package ())
290
291(defmethod definition-base-name ((dt package-definition-type) name)
292  (if (or (stringp name) (non-nil-symbol-p name))
293    (intern (string name) :keyword)
294    name))
295
296(defmethod definition-bound-p ((dt package-definition-type) name)
297  (and (or (stringp name) (symbolp name))
298       (find-package (string name))))
299
300(defmethod definition-same-p ((dt package-definition-type) d1 d2)
301  (and (or (stringp d1) (symbolp d1))
302       (or (stringp d2) (symbolp d2))
303       (equal (string d1) (string d2))))
304
305
306;;;;;;;;;;;
307
308(declaim (inline default-definition-type))
309
310(defun default-definition-type (name)
311  (if (typep name 'method)
312    *method-definition-type*
313    *function-definition-type*))
314
315;; remember & reuse last few (TYPE . file) entries
316(let ((cache (make-list 10 :initial-element nil)))
317  (defun type-file-cons (type files)
318    (loop for prev = nil then p for p = cache then (cdr p)
319          do (when (or (and (eq type (caar p)) (equal files (cdar p)))
320                       (and (null (cdr p))
321                            (setf (car p) (cons type files))))
322               (when prev ;; move to front unless already there
323                 (setf (cdr prev) (cdr p))
324                 (setf (cdr p) cache)
325                 (setq cache p))
326               (return (car p))))))
327
328(defun %source-file-entries (key)
329  (let ((data (gethash key %source-files%)))
330    (if (and (listp data)
331             (listp (%cdr data)))
332      data
333      (list data))))
334
335(defun %set-source-file-entries (key list &aux data)
336  (setf (gethash key %source-files%)
337        (if (and list
338                 (null (cdr list))
339                 ;; One element, but make sure can recognize it.
340                 (not (and (listp (%car list))
341                           (listp (%cdar data)))))
342          (car list)
343          list)))
344
345(defun make-def-source-entry (key type name files)
346  (setq files (if (or (%cdr files) (listp (%car files))) files (%car files)))
347  (cond ((eq type (default-definition-type name))
348         (if (and (eq name key) (atom files))
349           files
350           (cons name files)))
351        ((eq name key)
352         (type-file-cons type files))
353        (t
354         (cons (cons type name) files))))
355
356(defun decode-def-source-entry (key entry)
357  (if (atom entry)
358    (and entry (values (default-definition-type key) key (list entry)))
359    (let* ((file-or-files (%cdr entry))
360           (files (if (consp file-or-files) file-or-files (list file-or-files))))
361      (cond ((typep (%car entry) 'definition-type)
362             (values (%car entry) key files))
363            ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
364             (values (%caar entry) (%cdar entry) files))
365            (t
366             (values (default-definition-type (%car entry)) (%car entry) files))))))
367
368(defun def-source-entry.name (key entry)
369  (assert (not (null entry)))
370  (cond ((atom entry) key)
371        ((typep (%car entry) 'definition-type) key)
372        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
373         (%cdar entry))
374        (t
375         (%car entry))))
376
377(defun def-source-entry.type (key entry)
378  (cond ((atom entry) (default-definition-type key))
379        ((typep (%car entry) 'definition-type) (%car entry))
380        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
381         (%caar entry))
382        (t
383         (default-definition-type (%car entry)))))
384
385(defun def-source-entry.sources (key entry)
386  (declare (ignore key))
387  (cond ((consp entry)
388         (if (consp (%cdr entry)) (%cdr entry) (list (%cdr entry))))
389        (entry (list entry))
390        (t nil)))
391
392
393;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
394;;;
395
396
397(defun find-definition-sources (name &optional (type t))
398  "Returns a list of entries ((a-type . a-name) source . previous-sources), where
399a-type is a subtype of TYPE, and a-name is either NAME or it's a special case of
400NAME (e.g. if NAME is the name of generic function, a-name could be a method of NAME).
401The list is guaranteed freshly consed (ie suitable for nconc'ing)."
402  (let* ((dt (definition-type-instance type))
403         (dt-class (class-of dt))
404         (seen-dts nil)
405         (matches nil))
406    (with-lock-grabbed (*source-files-lock*)
407      (loop for (nil . dt) in *definition-types*
408            when (and (typep dt dt-class) (not (memq dt seen-dts)))
409              do (let* ((key (definition-base-name dt name))
410                        (all (%source-file-entries key)))
411                   (push dt seen-dts)
412                   (loop for entry in all
413                         when (and (eq dt (def-source-entry.type key entry))
414                                   (or (eq name key) ;; e.g. all methods on a gf
415                                       (definition-same-p dt name (def-source-entry.name key entry))))
416                           do (multiple-value-bind (type name files)
417                                  (decode-def-source-entry key entry)
418                                (push (cons (cons type name) files) matches))))))
419    matches))
420
421
422;;; backward compatibility
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) . sources) in list
554          as spec = (if (eq full-name name) (definition-type-name dt) full-name)
555          nconc (mapcan (lambda (s)
556                          (when s (list (cons spec (source-note-filename s)))))
557                        sources))))
558
559
560;; For ilisp.
561(defun %source-files (name)
562  (let ((type-list ())
563        (meth-list ()))
564    (loop for ((dt . full-name) . sources) in (find-definition-sources name t)
565          as files = (mapcan #'(lambda (s)
566                                 (and s (setq s (source-note-filename s)) (list s)))
567                             sources)
568          when files
569            do (if (typep dt 'method-definition-type)
570                 (dolist (file files)
571                   (push (cons full-name file) meth-list))
572                 (push (cons (definition-type-name dt) files) type-list)))
573    (when meth-list
574      (push (cons 'method meth-list) type-list))
575    type-list))
576
577;; For CVS slime as of 11/15/2008.
578(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
579  (let* ((name (or the-method
580                   (and (or (eq type 'method) classes qualifiers)
581                        `(sym ,@qualifiers ,classes))
582                   sym)))
583    (get-source-files-with-types name type)))
584
585
586#|
587;; For working-0711 versions of slime, but this doesn't actually work since
588;; source-note representations are not compatible
589
590(defun find-definitions-for-name (name &optional (type-name t))
591  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
592  (let ((definitions ()))
593    (loop for ((dt . full-name) last-source . nil)
594            in (find-definition-sources name type-name)
595          do (when last-source
596               (push (list dt full-name last-source) definitions)))
597    definitions))
598
599(defun find-simple-definitions-for-name (name)
600  (let* ((result (find-definitions-for-name name)))
601    (dolist (pair result result)
602      (let* ((dt (car pair)))
603        (when (typep dt 'definition-type)
604          (setf (car pair) (definition-type-name dt)))))))
605|#
606
607;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
608;;; record-source-file
609
610;; Returns nil if not a method/method name
611(defun method-def-parameters (m)
612  (when (typep m 'method-function)
613    (setq m (%method-function-method m)))
614  (if (typep m 'method)
615    (values (method-name m)
616            (method-qualifiers m)
617            (method-specializers m))
618    (let (name quals specs data last)
619      (when (consp m)
620        ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn))
621        (setq data (cdr m) last (last data))
622        (when (null (cdr last))
623          (setq last (car last))
624          (if (and (listp last) (neq (car last) 'eql))
625            (setq quals (butlast data) specs last)
626            (setq specs data))
627          (setq name (car m))
628          (when (and (or (non-nil-symbol-p name) (setf-function-name-p name))
629                     (every #'(lambda (q) (not (listp q))) quals)
630                     (every #'(lambda (s)
631                                (or (non-nil-symbol-p s)
632                                    (classp s)
633                                    (and (consp s)
634                                         (consp (cdr s))
635                                        (null (cddr s))
636                                         (eq (car s) 'eql))))
637                            specs))
638            (values name quals specs)))))))
639
640(defmethod record-definition-source ((dt definition-type) name source)
641  (let* ((key (definition-base-name dt name))
642         (all (%source-file-entries key))
643         (e-loc nil)
644         (e-files nil))
645    (loop for ptr on all as entry = (car ptr)
646          do (when (and (eq dt (def-source-entry.type key entry))
647                        (definition-same-p dt name (def-source-entry.name key entry)))
648               (setq e-files (def-source-entry.sources key entry))
649               (let ((old (flet ((same-file (x y)
650                                   (setq x (source-note-filename x))
651                                   (setq y (source-note-filename y))
652                                   (or (equal x y)
653                                       (and x
654                                            y
655                                            (equal
656                                             (or (probe-file x) (full-pathname x))
657                                             (or (probe-file y) (full-pathname y)))))))
658                            (member source e-files :test #'same-file))))
659                 (when (and old (neq source (car e-files))) ;; move to front
660                   (setq e-files (cons source (remove (car old) e-files :test #'eq)))))
661               (return (setq e-loc ptr))))
662    (unless (and e-files (eq source (car e-files)))
663      ;; Never previously defined in this file
664      (when (and (car e-files)            ; don't warn if last defined interactively
665                 *warn-if-redefine*
666                 (definition-bound-p dt name))
667        (warn "~A ~S previously defined in: ~A is now being redefined in: ~A~%"
668              (definition-type-name dt)
669              name
670              (source-note-filename (car e-files))
671              (or (source-note-filename source) "{No file}")))
672      (setq e-files (cons source e-files)))
673    (let ((entry (make-def-source-entry key dt name e-files)))
674      (if e-loc
675        (setf (car e-loc) entry)
676        (push entry all))
677      (%set-source-file-entries key all))
678    name))
679
680;;; avoid hanging onto beezillions of pathnames
681(defparameter *last-back-translated-name* (cons nil nil))
682
683;; Define the real record-source-file, which will be the last defn handled by the
684;; bootstrapping record-source-file, so convert all queued up data right afterwards.
685(progn
686
687(defun record-source-file (name def-type &optional (source (or *loading-toplevel-location*
688                                                               *loading-file-source-file*)))
689  (when (and source *record-source-file*)
690    (with-lock-grabbed (*source-files-lock*)
691      (let ((file-name (source-note-filename source)))
692        (unless (equalp file-name (car *last-back-translated-name*))
693          (setf (car *last-back-translated-name*) file-name)
694          (setf (cdr *last-back-translated-name*)
695                (if (physical-pathname-p file-name)
696                  (namestring (back-translate-pathname file-name))
697                  file-name)))
698        (setq file-name (cdr *last-back-translated-name*))
699        (if (source-note-p source)
700          (setf (source-note-filename source) file-name)
701          (setq source file-name)))
702      (when (eq def-type 't) (report-bad-arg def-type '(not (eql t))))
703      (record-definition-source (definition-type-instance def-type
704                                    :if-does-not-exist :create)
705                                name
706                                source))))
707
708;; Collect level-0 source file info
709(do-all-symbols (s)
710  (let ((f (get s 'bootstrapping-source-files)))
711    (when f
712      (if (consp f)
713        (destructuring-bind ((type . source)) f
714          (when source (record-source-file s type source)))
715        (record-source-file s 'function f))
716      (remprop s 'bootstrapping-source-files))))
717
718;; Collect level-1 source file info
719(when (consp *record-source-file*)
720  (let ((list (nreverse (shiftf *record-source-file* t))))
721    (while list
722      (apply #'record-source-file (pop list)))))
723)
Note: See TracBrowser for help on using the repository browser.