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

Last change on this file since 8929 was 8929, checked in by mb, 12 years ago

Fix ccl::%source-files handling of methods.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 21.2 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(setf (fdefinition 'record-source-file) #'early-record-source-file
20      (fdefinition 'register-definition-type) #'early-register-definition-type)
21
22;;;; * Mapping names of things to the text which defines the thing.
23
24;;;; RECORD-SOURCE-FILE stores the mapping between a thing and its
25;;;; location. FIND-DEFINITIONS-FOR-NAME allows us to find all the known places where a thing is
26;;;; defined.
27
28;;;; A source-note is a ccl::source-note object, depending on how much information we have available
29;;;; at load time the source-note may be a complete source-note or it may just have the file-name.
30
31;;;; A thing is identified by its type and its name. A type is an instance of definition-type and
32;;;; the name => atom | (list name*)
33
34;;;; * Global tables which store the mappings.
35
36(defvar *source-files* (make-hash-table)
37  "Hash table which store source locations as per record-source-file.")
38
39(defvar *definition-types* '()
40  "List of known definition-type objects.")
41
42;;;; ** Low level functions for maintaining the definition-source table.
43
44;;;; DEFINITION-SOURCE is part of the public API. However users of this API probably want to use
45;;;; RECORD-SOURCE-FILE and FIND-DEFINITIONS-FOR-NAME instead.
46
47(defgeneric (setf definition-source)
48    (source-note definition-type name)
49  (:documentation "Records that the object named NAME of type DEFINITION-TYPE is stored at
50SOURCE-NOTE.")
51  (:method (source-note (definition-type-name symbol) name)
52    "Convenience method, just calls (setf definition-source) with the definition-type object named
53DEFINITION-TYPE-NAME."
54    (setf (definition-source (definition-type-instance definition-type-name) name)
55          source-note))
56  (:method (source-note (definition-type definition-type) name)
57    ;; NB: this setf function calls definition-source. Be careful in definition-source to not call
58    ;; the setf method.
59    (let ((effective-name (effective-name definition-type name))
60          (existing-note (definition-source definition-type name)))
61      (unless effective-name
62        ;; should this be an error?
63        (warn "Can not determine name of ~S for type ~S." name definition-type)
64        (return-from definition-source source-note))
65      (symbol-macrolet ((definitions
66                            (gethash (definition-short-name definition-type effective-name) *source-files*)))
67        (if existing-note
68          (dolist (def definitions)
69            (when (and (eq (first def) (definition-type-name definition-type))
70                       (definition-name-equal-p (second def) effective-name))
71              (setf (third def) source-note)))
72          (push (list (definition-type-name definition-type) effective-name source-note)
73                definitions)))
74      source-note)))
75
76(defgeneric definition-source (definition-type name)
77  (:documentation "Returns the source-note for the object of type DEFINITION-TYPE named NAME.")
78  (:method ((definition-type-name symbol) (name t))
79    "Convenience method, just calls definition-source after looking up the definition-type named by DEFINITION-TYPE-NAME."
80    (definition-source (definition-type-instance definition-type-name) name))
81  (:method ((definition-type definition-type) (name t))
82    "Returns the source-note where the thing named NAME of type DEFINITION-TYPE was defined.
83
84If no such thing exists we return NIL."
85    ;; nb: we're called by (setf definition-source).
86    (let ((effective-name (effective-name definition-type name)))
87      (when effective-name
88        (third
89         (find-if (lambda (def)
90                    (and (eq (first def) (definition-type-name definition-type))
91                         (definition-name-equal-p (second def) effective-name)))
92                  (gethash (definition-short-name definition-type effective-name)
93                           *source-files*)))))))
94
95;; defined as a function in l0-source-files.lisp
96(fmakunbound 'remove-definition-source)
97(defgeneric remove-definition-source (definition-type name)
98  (:method ((definition-type-name symbol) name)
99    (remove-definition-source (definition-type-instance definition-type-name) name))
100  (:method ((definition-type definition-type) name)
101    (symbol-macrolet ((definitions
102                          (gethash (definition-short-name definition-type effective-name) *source-files*)))
103      (let ((effective-name (effective-name definition-type name)))
104        (setf definitions (delete-if (lambda (def)
105                                       (and (eq (first def) (definition-type-name definition-type))
106                                            (definition-name-equal-p (second def) effective-name)))
107                                     definitions))
108        (when (null definitions)
109          (remhash (definition-short-name definition-type effective-name) *source-files*))))
110    *source-files*))
111
112(defun definition-name-equal-p (a b)
113  "Returns T if A and B represent the same definition-name."
114  (let ((seen '()))
115    (labels ((rec (a b)
116             (cond
117               ((and (atom a) (atom b)) (eql a b))
118               ((and (consp a) (consp b))
119                (when (or (member a seen)
120                          (member b seen))
121                  (return-from definition-name-equal-p nil))
122                (push a seen)
123                (push b seen)
124                (and (rec (car a) (car b))
125                     (rec (cdr a) (cdr b))))
126               (t nil))))
127      (rec a b))))
128
129;;;; ** Storing definitions for a name
130
131(defun real-record-source-file (name definition-type-name &optional (toplevel-source-note *loading-toplevel-location*))
132  "Records where the thing of type DEFINITION-TYPE-NAME named NAME is stored.
133
134NAME is a definition-name; DEFINITION-TYPE-NAME is a symbol naming a definition-type-name (see
135definition-type-instance) or a definition-type object; TOPLEVEL-SOURCE-NOTE is the source-note."
136  (if toplevel-source-note
137    (let* ((definition-type (definition-type-instance definition-type-name))
138           (source-note  toplevel-source-note)
139           (existing-note (definition-source definition-type name)))
140      (when (and *warn-if-redefine*
141                 (not (equal (full-pathname (source-note-file-name existing-note))
142                             (full-pathname (source-note-file-name source-note)))))
143        ;; have an existing definition in another file. warn.
144        (warn "The ~S ~S, which was defined in ~S, is being redefined in ~S."
145              definition-type-name (effective-name definition-type name)
146              (source-note-file-name existing-note)
147              (source-note-file-name source-note)))
148      (setf (definition-source definition-type name) source-note)
149      (list definition-type-name (effective-name definition-type name) source-note))
150    (remove-definition-source definition-type-name name)))
151
152;;;; * Framework for definig definition-types
153
154(defun definition-type-full-name (type-name)
155  "Given a definition-type-name returns the name of the class of definition-type representing that
156name."
157  (intern (concatenate 'string 
158                       (string type-name)
159                       (string '#:-definition-type))))
160
161(defclass definition-type ()
162    ((name :accessor definition-type-name :initarg :name))
163  (:documentation "Super class of the definition-types.
164
165We only use definition-type objects for two things:
166
1671) To store their short name (so that users can write x86-lap instead of x86-lap-definition-type)
168
1692) To let us inherit behaviour (in particular effective-name). Example: WRITER-METHOD acts just like
170FUNCTION but we want it to have a different name."))
171
172(defmethod make-load-form ((type definition-type) &optional env)
173  (make-load-form-saving-slots type :slot-names '(name) :environment env))
174
175(defun definition-type-instance (definition-type-name)
176  "Returns a definition-type object whose name if definition-type-name.
177
178DEFINITION-TYPE-NAME, a symbol, is the short name of the definition-type."
179  (or (find definition-type-name *definition-types*
180            :key #'definition-type-name)
181      (error "No definition type named ~S." definition-type-name)))
182
183(defmacro define-definition-type (name supers &rest options)
184  "Defines a new type named NAME for recording source information.
185
186OPTIONS can contain the keyword :default-name-function it which symbols are passed, unmodified, as
187names."
188  `(progn
189     (defclass ,(definition-type-full-name name) ,(or supers '(definition-type))
190         ()
191       (:default-initargs :name ',name))
192     ,@(loop for (key . arguments) in options
193             when (eql key :default-name-function)
194               collect `(define-definition-name-function ,name (,(first arguments)) ,(first arguments)))
195     (register-definition-type ',name)
196     ',name))
197
198(defun real-register-definition-type (name)
199  (let ((name (definition-type-full-name name)))
200    (setf *definition-types* (delete name *definition-types* :key #'definition-type-name))
201    (push (make-instance name) *definition-types*)))
202
203(defgeneric effective-name (type name)
204  (:documentation "Normalizes NAME into the standard name of objects of type TYPE. If NAME can not
205name an object of type TYPE then we return NIL.
206
207This function also serves to test if we could ever find a thing of type TYPE with the name NAME.")
208  (:method ((type definition-type) (name t))
209    ;; by default nothing is a valid type name.
210    nil))
211
212(defmacro define-definition-name-function (type-name (name-type) &body body)
213  (let ((type-arg (gensym)))
214    `(defmethod effective-name ((,type-arg ,(definition-type-full-name type-name))
215                                (,name-type ,name-type))
216       ,@body)))
217
218(defgeneric definition-short-name (type effective-name)
219  (:documentation "Given an effective-name returns a single symbol which, approximetly, names this
220THING.
221
222The values returned by this function are used as keys in *source-files*. We do this so that, since
223names can be arbitrary lists, we don't need to search through every known name when looking for its
224source but can look through the, hopefully short, lists of things with the same short-name.")
225  (:method ((type definition-type) (name symbol))
226    name))
227
228(defmacro define-definition-short-name (type-name (effective-name) &body body)
229  "Defines a method on definition-short-name. TYPE-NAME is a short definition-name, EFFECTIVE-NAME
230will be used as the argument to definition-short-name."
231  (let ((type-arg (gensym)))
232    `(defmethod definition-short-name ((,type-arg ,(definition-type-full-name type-name))
233                                       ,effective-name)
234       ,@body)))
235
236(defgeneric auxilliary-names (type name)
237  (:documentation "Returns a list of (type name) which, when looking for NAME of type TYPE we might
238also want to lookup.
239
240Poor man's apropos.")
241  (:method ((type definition-type) (name t))
242    '()))
243
244;;;; * Definition types
245
246;;;; ** function
247
248(define-definition-type function ()
249  (:default-name-function symbol))
250
251(define-definition-short-name function (name)
252  (if (symbolp name)
253    name
254    (second name)))
255
256(define-definition-name-function function (cons)
257  (validate-function-name cons)
258  cons)
259
260(define-definition-name-function function (function)
261  (function-name function))
262
263(defmethod auxilliary-names ((type function-definition-type) (name symbol))
264  (append (list (list 'function `(setf ,name)))
265          (when (and (fboundp name)
266                     (generic-function-p (fdefinition name)))
267            (loop
268              for method in (generic-function-methods (fdefinition name))
269              collect (list 'method (effective-name
270                                     (definition-type-instance 'method)
271                                     method))))
272          (when (macro-function name)
273            (list (list 'compiler-macro name)))))
274
275;;;; *** function like things
276
277(define-definition-type macro (function-definition-type))
278
279(define-definition-type compiler-macro (function-definition-type))
280
281(define-definition-type generic-function (function-definition-type))
282
283(define-definition-type reader-method (function-definition-type))
284
285(define-definition-type writer-method (function-definition-type))
286
287;;;; ** type
288
289(define-definition-type type ())
290
291(defmethod effective-name ((type type-definition-type) (name t))
292  "Anything is a valid name for a type"
293  (let ((seen '()))
294    (labels ((name-check (name)
295               (typecase name
296                 (symbol t)
297                 (cons
298                    (if (member name seen)
299                      nil
300                      (progn
301                        (push (car name) seen)
302                        (push (cdr name) seen)
303                        (and (name-check (car name))
304                             (name-check (cdr name)))))))))
305      (if (name-check name)
306        name
307        nil))))
308
309;;;; ** class
310
311(define-definition-type class ()
312  (:default-name-function symbol))
313
314(define-definition-name-function class (standard-class) (class-name standard-class))
315
316(define-definition-name-function class (built-in-class) (class-name built-in-class))
317
318(define-definition-name-function class (funcallable-standard-class) (class-name funcallable-standard-class))
319
320(defmethod auxilliary-names ((type class-definition-type) (name symbol))
321  (list (list 'structure name)))
322
323;;;; ** structure
324
325(define-definition-type structure ()
326  (:default-name-function symbol))
327
328(define-definition-name-function structure (structure-class) (class-name structure-class))
329
330(defmethod auxilliary-names ((type (eql 'structure)) (name symbol))
331  (list (list 'class name)))
332
333;;;; ** method
334
335(define-definition-type method ())
336
337(define-definition-name-function method (cons) cons)
338
339(defun method-specializers-as-name-list (specializers)
340  (loop
341    for specializer in specializers
342    collect (etypecase specializer
343              (eql-specializer `(eql ,(eql-specializer-object specializer)))
344              (structure-class (effective-name (definition-type-instance 'structure)
345                                               specializer))
346              (class (effective-name (definition-type-instance 'class)
347                                     specializer))))  )
348
349(define-definition-name-function method (standard-method)
350  (list* (effective-name (definition-type-instance 'function)
351                         (method-generic-function standard-method))
352         (method-qualifiers standard-method)
353         (method-specializers-as-name-list (method-specializers standard-method))))
354
355(define-definition-short-name method (name)
356  (definition-short-name (definition-type-instance 'function)
357                         (first name)))
358
359(defun %find-method-from-definition-name (method-name)
360  (destructuring-bind (gf-name qualifiers . specializers)
361      method-name
362    (loop
363      with gf = (fdefinition gf-name)
364      for this-method in (generic-function-methods gf)
365      for these-qualifiers = (method-qualifiers this-method)
366      for these-specializers = (method-specializers-as-name-list (method-specializers this-method))
367      thereis (and (equal qualifiers these-qualifiers)
368                   (equal specializers these-specializers)
369                   this-method))))
370
371;;;; ** method-combination
372
373(define-definition-type method-combination ()
374  (:default-name-function symbol))
375
376(define-definition-name-function method-combination (standard-method-combination)
377  (method-combination-name standard-method-combination))
378
379;;;; ** constant
380
381(define-definition-type constant ()
382  (:default-name-function symbol))
383
384(defmethod auxilliary-names ((type constant-definition-type) (name symbol))
385  (list (list 'variable name)))
386
387;;;; ** variable
388
389(define-definition-type variable ()
390  (:default-name-function symbol))
391
392(defmethod auxilliary-names ((type variable-definition-type) (name symbol))
393  (list (list 'constant name)))
394
395;;;; ** conditions
396
397(define-definition-type condition (class-definition-type)
398  (:default-name-function symbol))
399
400;;;; ** callbacks
401
402;;;; Can't put this in l1-callbacks since it's loaded before clos.
403
404(define-definition-type callback (function-definition-type)
405  (:default-name-function symbol))
406
407;;;; * Finding definitions from a name
408
409(defun find-definitions-for-name (name)
410  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
411  (let ((definitions '()))
412    (flet ((collect-def (type name)
413             (let ((source (definition-source type name)))
414               (when source
415                 (push (list type name source) definitions)))))
416      (dolist (definition-type *definition-types*)
417        (collect-def (definition-type-name definition-type) name)
418        (dolist (other-name (auxilliary-names definition-type name))
419          (collect-def (first other-name) (second other-name))))
420      (remove-duplicates definitions
421                         :test (lambda (a b)
422                                 (and (eql (first a) (first b))
423                                      (definition-name-equal-p (second a) (second b))))))))
424
425;;;; * backwards compatability. find-definitions-for-name or definition-source is the preferred way
426;;;; to lookup sources.
427
428(defun edit-definition-p (name &optional (type t))
429  (if (and (typep name 'method)
430           (member type '(t method)))
431    (values (get-source-files-with-types&classes name (definition-type-instance type))
432            (function-name (method-generic-function name))
433            'method
434            (method-specializers-as-name-list (method-specializers name))
435            (method-qualifiers name))
436    (get-source-files-with-types&classes name (definition-type-instance type))))
437
438(defun get-source-files-with-types&classes (name &optional (type-name t))
439  "Returns the files where the object of type TYPE named SYM is defined.
440
441Returns a list of (TYPE . FILES). TYPE is either a symbol naming the type or, in the case of
442methods, the method object.
443
444FILES is either a list of pathnames if there are multiple definitions or a single pathname."
445  (let* ((definitions (case type-name
446                        (function
447                         (list* (definition-source 'function name)
448                                (loop
449                                  for (type-name name) in (auxilliary-names 'function name)
450                                  when (definition-source type-name name)
451                                    collect (definition-source type-name name))))
452                        (t (find-definitions-for-name name)))))
453    ;; convert the list of definitions to whet callers of get-source-files-with-types&classes expect.
454    (mapcar (lambda (def)
455              (destructuring-bind (type name source-note)
456                  def
457                (cons (if (eql 'method type)
458                        (%find-method-from-definition-name name)
459                        type)
460                      (source-note-file-name source-note))))
461            definitions)))
462
463(defun %source-files (name)
464  (mapcar (lambda (def)
465            (let ((def-type (first def))
466                  (file (source-note-file-name (third def))))
467              (cons (if (eql 'method def-type)
468                      (%find-method-from-definition-name (second def))
469                      def-type)
470                    file)))
471          (gethash name *source-files*)))
472
473;;;; * Done loading the r-s-f stuff. Do some housekeeping.
474
475;;; xload-level-0 has stored source file info on the plists of symbols
476;;; that have definitions in level-0;**;*.lisp, under the indicator
477;;; BOOTSRAPPING-SOURCE-FILES.  Remove those plist entries, and
478;;; add equivalent info to *early-source-files*.
479(let* ((path-notes ()))
480  (flet ((find-source-note (path)
481           (dolist (note path-notes
482                    (let* ((new (%make-source-note :file-name path)))
483                      (push new path-notes)
484                      new))
485             (when (eq (source-note-file-name note) path)
486               (return note)))))
487    (do-all-symbols (s)
488      (let* ((info (get s 'bootstrapping-source-files)))
489        (when info
490          (remprop s 'bootstrapping-source-files)
491          (when (atom info) (setq info `((function . ,info))))
492          (dolist (pair info)
493            (let* ((indicator (car pair))
494                   (path (cdr pair))
495                   (note (find-source-note path)))
496              (push (list indicator s note) *early-source-files*))))))))
497
498;; Now that the real r-s-f framework is ready we can go back and fixup the early stuff. This early
499;; stuff is everything that we wanted to register before having defined the registration/recording
500;; framework itself. Look at l0-source-files.lisp for the dummy code we use which fills
501;; *early-definition-types* and *early-source-files*.
502
503(loop
504  while *early-definition-types*
505  for type-name = (pop *early-definition-types*)
506  do (real-register-definition-type type-name))
507
508(loop
509  while *early-source-files*
510  for (type name source-note) = (pop *early-source-files*)
511  do (real-record-source-file name type source-note))
512
513(setf (fdefinition 'record-source-file) #'real-record-source-file
514      (fdefinition 'register-definition-type) #'real-register-definition-type)
Note: See TracBrowser for help on using the repository browser.