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

Last change on this file since 8871 was 8871, checked in by mb, 11 years ago

Record source location for condition classe with the label CONDITION (instead of CLASS)

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