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

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

Rollback r9356

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.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(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(define-definition-type structure-accessor (function-definition-type))
288
289;;;; ** type
290
291(define-definition-type type ())
292
293(defmethod effective-name ((type type-definition-type) (name t))
294  "Anything is a valid name for a type"
295  (let ((seen '()))
296    (labels ((name-check (name)
297               (typecase name
298                 (symbol t)
299                 (cons
300                    (if (member name seen)
301                      nil
302                      (progn
303                        (push (car name) seen)
304                        (push (cdr name) seen)
305                        (and (name-check (car name))
306                             (name-check (cdr name)))))))))
307      (if (name-check name)
308        name
309        nil))))
310
311;;;; ** class
312
313(define-definition-type class ()
314  (:default-name-function symbol))
315
316(define-definition-name-function class (standard-class) (class-name standard-class))
317
318(define-definition-name-function class (built-in-class) (class-name built-in-class))
319
320(define-definition-name-function class (funcallable-standard-class) (class-name funcallable-standard-class))
321
322(defmethod auxilliary-names ((type class-definition-type) (name symbol))
323  (list (list 'structure name)))
324
325;;;; ** structure
326
327(define-definition-type structure ()
328  (:default-name-function symbol))
329
330(define-definition-name-function structure (structure-class) (class-name structure-class))
331
332(defmethod auxilliary-names ((type (eql 'structure)) (name symbol))
333  (list (list 'class name)))
334
335;;;; ** method
336
337(define-definition-type method ())
338
339(define-definition-name-function method (cons) cons)
340
341(defun method-specializers-as-name-list (specializers)
342  (loop
343    for specializer in specializers
344    collect (etypecase specializer
345              (eql-specializer `(eql ,(eql-specializer-object specializer)))
346              (structure-class (effective-name (definition-type-instance 'structure)
347                                               specializer))
348              (class (effective-name (definition-type-instance 'class)
349                                     specializer))))  )
350
351(define-definition-name-function method (standard-method)
352  (list* (effective-name (definition-type-instance 'function)
353                         (method-generic-function standard-method))
354         (method-qualifiers standard-method)
355         (method-specializers-as-name-list (method-specializers standard-method))))
356
357(define-definition-short-name method (name)
358  (definition-short-name (definition-type-instance 'function)
359                         (first name)))
360
361(defun %find-method-from-definition-name (method-name)
362  (destructuring-bind (gf-name qualifiers . specializers)
363      method-name
364    (loop
365      with gf = (fdefinition gf-name)
366      for this-method in (generic-function-methods gf)
367      for these-qualifiers = (method-qualifiers this-method)
368      for these-specializers = (method-specializers-as-name-list (method-specializers this-method))
369      thereis (and (equal qualifiers these-qualifiers)
370                   (equal specializers these-specializers)
371                   this-method))))
372
373;;;; ** method-combination
374
375(define-definition-type method-combination ()
376  (:default-name-function symbol))
377
378(define-definition-name-function method-combination (standard-method-combination)
379  (method-combination-name standard-method-combination))
380
381;;;; ** constant
382
383(define-definition-type constant ()
384  (:default-name-function symbol))
385
386(defmethod auxilliary-names ((type constant-definition-type) (name symbol))
387  (list (list 'variable name)))
388
389;;;; ** variable
390
391(define-definition-type variable ()
392  (:default-name-function symbol))
393
394(defmethod auxilliary-names ((type variable-definition-type) (name symbol))
395  (list (list 'constant name)))
396
397;;;; ** conditions
398
399(define-definition-type condition (class-definition-type)
400  (:default-name-function symbol))
401
402;;;; ** callbacks
403
404;;;; Can't put this in l1-callbacks since it's loaded before clos.
405
406(define-definition-type callback (function-definition-type)
407  (:default-name-function symbol))
408
409;;;; * Finding definitions from a name
410
411(defun find-definitions-for-name (name)
412  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
413  (let ((definitions '()))
414    (flet ((collect-def (type name)
415             (let ((source (definition-source type name)))
416               (when source
417                 (push (list type name source) definitions)))))
418      (dolist (definition-type *definition-types*)
419        (collect-def (definition-type-name definition-type) name)
420        (dolist (other-name (auxilliary-names definition-type name))
421          (collect-def (first other-name) (second other-name))))
422      (remove-duplicates definitions
423                         :test (lambda (a b)
424                                 (and (eql (first a) (first b))
425                                      (definition-name-equal-p (second a) (second b))))))))
426
427;;;; * backwards compatability. find-definitions-for-name or definition-source is the preferred way
428;;;; to lookup sources.
429
430(defun edit-definition-p (name &optional (type t))
431  (if (and (typep name 'method)
432           (member type '(t method)))
433    (values (get-source-files-with-types&classes name (definition-type-instance type))
434            (function-name (method-generic-function name))
435            'method
436            (method-specializers-as-name-list (method-specializers name))
437            (method-qualifiers name))
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  "Finds the definitions of NAME.
467
468If NAME only names a function or macro returns the file the function is defined in.
469
470If NAME only names a generic-function returns a list of the form: ((METHOD . METHOD-PAIRS)). METHOD
471is the symbol METHOD pairs is a list of (METHOD-OBJECT . FILE-NAME).
472
473"
474  (loop
475    for (type name source-note) in (find-definitions-for-name name)
476    if (member type '(method 'reader-method 'writer-method))
477      collect (cons (%find-method-from-definition-name name)
478                    (source-note-file-name source-note))
479      into method-definitions
480    else
481      collect (cons (case type
482                      ((function macro) 'function)
483                      (callback         'defcallback)
484                      (t type))
485                    (source-note-file-name source-note))
486      into other-definitions
487    finally (return (values (cond
488                              ((and method-definitions other-definitions)
489                               (cons (cons 'method method-definitions)
490                                     other-definitions))
491                              (method-definitions (cons 'method method-definitions))
492                              (other-definitions
493                               (if (and (= 1 (length other-definitions))
494                                        (member (car (first other-definitions)) '(function compiler-macro macro)))
495                                 (cdr (first other-definitions))
496                                 other-definitions)))
497                            (if (or method-definitions other-definitions)
498                              t
499                              nil)))))
500
501;;;; * Done loading the r-s-f stuff. Do some housekeeping.
502
503;;; xload-level-0 has stored source file info on the plists of symbols
504;;; that have definitions in level-0;**;*.lisp, under the indicator
505;;; BOOTSRAPPING-SOURCE-FILES.  Remove those plist entries, and
506;;; add equivalent info to *early-source-files*.
507(let* ((path-notes ()))
508  (flet ((find-source-note (path)
509           (dolist (note path-notes
510                    (let* ((new (%make-source-note :file-name path)))
511                      (push new path-notes)
512                      new))
513             (when (eq (source-note-file-name note) path)
514               (return note)))))
515    (do-all-symbols (s)
516      (let* ((info (get s 'bootstrapping-source-files)))
517        (when info
518          (remprop s 'bootstrapping-source-files)
519          (when (atom info) (setq info `((function . ,info))))
520          (dolist (pair info)
521            (let* ((indicator (car pair))
522                   (path (cdr pair))
523                   (note (find-source-note path)))
524              (push (list indicator s note) *early-source-files*))))))))
525
526;; Now that the real r-s-f framework is ready we can go back and fixup the early stuff. This early
527;; stuff is everything that we wanted to register before having defined the registration/recording
528;; framework itself. Look at l0-source-files.lisp for the dummy code we use which fills
529;; *early-definition-types* and *early-source-files*.
530
531(loop
532  while *early-definition-types*
533  for type-name = (pop *early-definition-types*)
534  do (real-register-definition-type type-name))
535
536(loop
537  while *early-source-files*
538  for (type name source-note) = (pop *early-source-files*)
539  do (real-record-source-file name type source-note))
540
541(setf (fdefinition 'record-source-file) #'real-record-source-file
542      (fdefinition 'register-definition-type) #'real-register-definition-type)
Note: See TracBrowser for help on using the repository browser.