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

Last change on this file since 8890 was 8890, checked in by gb, 12 years ago

Pull the boootstrapping/level-0 stuff off of plists, so that level-0
definitions have source info again.

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