source: branches/working-0711/ccl/lib/xref.lisp @ 11413

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

who-calls fix from trunk (r11388)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.6 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL; indent-tabs-mode: nil -*-
2;;;
3;;;   Copyright (C) 2003 Oliver Markovic <entrox@entrox.org>
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(eval-when (:compile-toplevel :load-toplevel :execute)
20  (export '(*RECORD-XREF-INFO*
21            *LOAD-XREF-INFO*
22            XREF-ENTRY
23            XREF-ENTRY-NAME
24            XREF-ENTRY-TYPE
25            XREF-ENTRY-METHOD-QUALIFIERS
26            XREF-ENTRY-METHOD-SPECIALIZERS
27            XREF-ENTRY-P
28            XREF-ENTRY-EQUAL
29            DISCARD-ALL-XREF-INFO
30            GET-RELATION
31            MACROS-CALLED-BY
32            START-XREF
33            STOP-XREF
34            WHO-BINDS
35            WHO-CALLS
36            WHO-DIRECTLY-CALLS
37            WHO-INDIRECTLY-CALLS
38            WHO-REFERENCES
39            WHO-SETS
40            WHO-USES
41            WITH-XREF
42            XREF-DESCRIBE)))
43
44(defpackage "CROSS-REFERENCE"
45  (:use "CL")
46  (:nicknames "XREF")
47  (:import-from "CCL"
48                "*RECORD-XREF-INFO*"
49                "*LOAD-XREF-INFO*"
50                "XREF-ENTRY"
51                "XREF-ENTRY-NAME"
52                "XREF-ENTRY-TYPE"
53                "XREF-ENTRY-METHOD-QUALIFIERS"
54                "XREF-ENTRY-METHOD-SPECIALIZERS"
55                "XREF-ENTRY-P"
56                "XREF-ENTRY-EQUAL"
57                "DISCARD-ALL-XREF-INFO"
58                "GET-RELATION"
59                "MACROS-CALLED-BY"
60                "START-XREF"
61                "STOP-XREF"
62                "WHO-BINDS"
63                "WHO-CALLS"
64                "WHO-DIRECTLY-CALLS"
65                "WHO-INDIRECTLY-CALLS"
66                "WHO-REFERENCES"
67                "WHO-SETS"
68                "WHO-USES"
69                "WITH-XREF"
70                "XREF-DESCRIBE")
71  (:export "*RECORD-XREF-INFO*"
72           "*LOAD-XREF-INFO*"
73           "XREF-ENTRY"
74           "XREF-ENTRY-NAME"
75           "XREF-ENTRY-TYPE"
76           "XREF-ENTRY-METHOD-QUALIFIERS"
77           "XREF-ENTRY-METHOD-SPECIALIZERS"
78           "XREF-ENTRY-P"
79           "XREF-ENTRY-EQUAL"
80           "DISCARD-ALL-XREF-INFO"
81           "GET-RELATION"
82           "MACROS-CALLED-BY"
83           "START-XREF"
84           "STOP-XREF"
85           "WHO-BINDS"
86           "WHO-CALLS"
87           "WHO-DIRECTLY-CALLS"
88           "WHO-INDIRECTLY-CALLS"
89           "WHO-REFERENCES"
90           "WHO-SETS"
91           "WHO-USES"
92           "WITH-XREF"
93           "XREF-DESCRIBE"))
94
95
96;; *RECORD-XREF-INFO* -- external
97;;
98;; Cross-referencing information will only be recorded if this flag
99;; is set. It is usually set/unset by START-XREF/STOP-XREF
100(defvar *record-xref-info* nil
101  "Flag indicating wether cross-referencing information should be recorded.")
102
103;; *LOAD-XREF-INFO* -- external
104;;
105;; FIXME: We don't save any information yet...
106(defvar *load-xref-info* nil
107  "Flag indicating wether cross-referencing information should be loaded
108from FASLs.")
109
110
111
112;; START-XREF -- external
113;;
114(defun start-xref ()
115  "Start recording cross-referencing information while compiling."
116  (setf *record-xref-info* t)
117  (setf *load-xref-info* t)
118  t)
119
120;; STOP-XREF -- external
121;;
122(defun stop-xref ()
123  "Stop recording cross-referencing information while compiling."
124  (setf *record-xref-info* nil)
125  (setf *load-xref-info* nil)
126  nil)
127
128;; WITH-XREF -- external
129;;
130(defmacro with-xref (&body body)
131  "Execute BODY with cross-referencing turned on."
132  (let ((return-value (gensym "RETURN-VALUE")))
133    `(let ((*record-xref-info* t)
134           (*load-xref-info* t)
135           (,return-value nil))
136       (setf ,return-value (progn ,@body))
137       ,return-value)))
138
139
140;; XREF-ENTRY -- external
141;;
142(defstruct (xref-entry
143            (:constructor %make-xref-entry)
144            (:print-function %print-xref-entry))
145  name
146  type
147  (method-qualifiers nil)
148  (method-specializers nil))
149
150;; %PRINT-XREF-ENTRY -- internal
151;;
152(defun %print-xref-entry (struct stream d)
153  (declare (ignore d))
154  (if *print-readably*
155      (format stream "#S(xref::xref-entry :name '~A :type '~A :method-qualifiers ~A :method-specializers ~A)"
156              (xref-entry-name struct)
157              (xref-entry-type struct)
158              (xref-entry-method-qualifiers struct)
159              (xref-entry-method-specializers struct))
160    (print-unreadable-object (struct stream :type t)
161      (format stream "~A ~A~@[ ~A~]~@[ ~A~]"
162              (xref-entry-name struct)
163              (xref-entry-type struct)
164              (xref-entry-method-qualifiers struct)
165              (xref-entry-method-specializers struct)))))
166
167;; MAKE-XREF-ENTRY -- internal
168;;
169;; Takes a simple input form and makes a XREF-ENTRY from it. The input is
170;; assumed to be a function, macro or variable when a simple symbol is passed,
171;; or a method when it is a cons. Since this needs to also handle the ouput
172;; from CCL::CALLERS, there is additional hackery trying to do the right thing.
173(defun make-xref-entry (input relation)
174  (etypecase input
175    (symbol
176     (let ((type (ecase relation
177                   ((:direct-calls :indirect-calls) 'function)
178                   ((:binds :sets :references) 'variable)
179                   ((:macro-calls) 'macro))))
180       (%make-xref-entry :name input :type type)))
181    (method
182     (let ((name (method-name input))
183           (qualifiers (method-qualifiers input))
184           (specializers (canonicalize-specializers (method-specializers input))))
185       (%make-xref-entry :name name :type 'method
186                         :method-qualifiers (unless (eql qualifiers t) qualifiers)
187                         :method-specializers specializers)))
188    (cons
189     (case (car input)
190       ((ppc-lap-macro compiler-macro-function)
191        (%make-xref-entry :name (cadr input) :type (car input)))
192       ((:internal)
193        (make-xref-entry (car (last input)) relation))
194       (t
195        (multiple-value-bind (type name specializers qualifiers)
196            (parse-definition-spec input)
197          (%make-xref-entry :name name :type type
198                            :method-qualifiers (unless (eql qualifiers t) qualifiers)
199                            :method-specializers specializers)))))))
200
201(defun parse-definition-spec (form)
202  (let ((type t)
203        name classes qualifiers)
204    (cond
205     ((consp form)
206      (cond ((eq (car form) 'setf)
207             (setq name form))
208            (t (setq name (car form))
209               (let ((last (car (last (cdr form)))))
210                 (cond ((and (listp last)(or (null last)(neq (car last) 'eql)))
211                        (setq classes last)
212                        (setq qualifiers (butlast (cdr form))))
213                       (t (setq classes (cdr form)))))                   
214               (cond ((null qualifiers)
215                      (setq qualifiers t))
216                     ((equal qualifiers '(:primary))
217                      (setq qualifiers nil))))))
218     (t (setq name form)))
219    (when (and (consp name)(eq (car name) 'setf))
220        (setq name (or (%setf-method (cadr name)) name))) ; e.g. rplacd
221    (when (not (or (symbolp name)
222                   (setf-function-name-p name)))
223      (return-from parse-definition-spec))
224    (when (consp qualifiers)
225      (mapc #'(lambda (q)
226                (when (listp q)
227                  (return-from parse-definition-spec)))
228          qualifiers))
229    (when classes
230      (mapc #'(lambda (c)
231                (when (not (and c (or (symbolp c)(and (consp c)(eq (car c) 'eql)))))
232                  (return-from parse-definition-spec)))
233            classes))           
234    (when (or (consp classes)(consp qualifiers))(setq type 'method))
235    (values type name classes qualifiers)))
236
237;; XREF-ENTRY-EQUAL -- external
238;;
239;; Simply compares all slots.
240(defun xref-entry-equal (entry1 entry2)
241  (and (eql (xref-entry-name entry1) (xref-entry-name entry2))
242       (eql (xref-entry-type entry1) (xref-entry-type entry2))
243       (equal (xref-entry-method-qualifiers entry1)
244              (xref-entry-method-qualifiers entry2))
245       (equal (xref-entry-method-specializers entry1)
246              (xref-entry-method-specializers entry2))))
247
248;; %DB-KEY-FROM-XREF-ENTRY -- internal
249;;
250;; This is mostly the inverse to MAKE-XREF-ENTRY, since it takes an entry
251;; and returns either a symbol (for functions, macros and variables) or a
252;; list in the form (METHOD-NAME QUALIFIERS (SPECIALIZERS)) for a method.
253;; These are used as keys in the database hash-tables.
254(defun %db-key-from-xref-entry (entry)
255  (if (eql (xref-entry-type entry) 'method)
256      `(,(xref-entry-name entry)
257        ,@(xref-entry-method-qualifiers entry)
258        ,(xref-entry-method-specializers entry))
259    (xref-entry-name entry)))
260
261;; edit-definition-p needs this - what is it for?
262(defvar *direct-methods-only* nil)
263
264;; %SOURCE-FILE-FOR-XREF-ENTRY -- internal
265;;
266(defun %source-file-for-xref-entry (entry)
267  (multiple-value-bind (files name type specializers qualifiers)
268      (edit-definition-p (%db-key-from-xref-entry entry)
269                         (if (eql (xref-entry-type entry) 'macro)
270                             'function
271                           (xref-entry-type entry)))
272    (declare (ignore name type specializers qualifiers))
273    (let ((filename (if (consp files) (cdar files) files)))
274      (when filename
275        (truename filename)))))
276
277
278;; MAKE-XREF-DATABASE -- internal
279;;
280;; This returns a fresh cross-referencing "database". It's a simple association
281;; list with two hash-tables per entry. The CAR hash holds the direct entries
282;; e.g. KEY calls/references/etc VALUE, while the CDR holds inverse hash (KEY
283;; is called/referenced/etc by VALUE.
284(defun make-xref-database ()
285  (list :binds (cons (make-hash-table :test #'equal)
286                     (make-hash-table :test #'equal))
287        :references (cons (make-hash-table :test #'equal)
288                          (make-hash-table :test #'equal))
289        :sets (cons (make-hash-table :test #'equal)
290                    (make-hash-table :test #'equal))
291        :direct-calls (cons (make-hash-table :test #'equal)
292                            (make-hash-table :test #'equal))
293        :indirect-calls (cons (make-hash-table :test #'equal)
294                              (make-hash-table :test #'equal))
295        :macro-calls (cons (make-hash-table :test #'equal)
296                           (make-hash-table :test #'equal))))
297
298;; *XREF-DATABASE* -- internal
299;;
300;; The one and only cross-referencing database.
301(defvar *xref-database* (make-xref-database))
302
303
304;; %XREF-TABLE -- internal
305;;
306;; Returns the appropriate table for a given relation.
307(defun %xref-table (relation inversep)
308  (if inversep
309      (cdr (getf *xref-database* relation))
310    (car (getf *xref-database* relation))))
311
312
313;; DISCARD-ALL-XREF-INFO -- external
314;;
315(defun discard-all-xref-info ()
316  "Clear the cross-referencing database."
317  (setf *xref-database* (make-xref-database))
318  t)
319
320
321;; %ADD-XREF-ENTRY -- internal
322;;
323;; The compiler adds cross-referencing information by calling this
324;; (see NX-RECORD-XREF-INFO).
325(defun %add-xref-entry (relation name1 name2)
326  (when (and *record-xref-info* relation name1 name2)
327    (pushnew (make-xref-entry name2 relation)
328             (gethash name1 (%xref-table relation nil))
329             :test #'xref-entry-equal)
330    (pushnew (make-xref-entry name1 relation)
331             (gethash name2 (%xref-table relation t))
332             :test #'xref-entry-equal)
333    t))
334
335
336
337
338;; %DISCARD-XREF-INFO-FOR-FUNCTION -- internal
339;;
340;; This rather expensive operation removes all traces of a given function
341;; from the cross-referencing database. It needs to be called whenever a
342;; function gets redefined, so we don't pick up stale xref entries.
343(defun %discard-xref-info-for-function (func)
344  ;; need to go through every possible relation
345  (dolist (relation '(:direct-calls :indirect-calls :macro-calls
346                      :binds :references :sets))
347    ;; get a list of the places to which the func points to...
348    (dolist (entry (gethash func (%xref-table relation nil)))
349      (let ((key (%db-key-from-xref-entry entry)))
350        ;; ... and remove it from there
351        (setf (gethash key (%xref-table relation t))
352              (delete func (gethash key (%xref-table relation t))))))
353    ;; the non-inverse case is easy
354    (remhash func (%xref-table relation nil))))
355
356
357;; GET-RELATION -- external
358;;
359;; FIXME: Implement filtering by files.
360;;        And what the heck should errorp do?
361(defun get-relation (relation name1 name2 &key in-files in-functions exhaustive errorp)
362  "Returns a list of matches for RELATION between NAME1 and NAME2. Results can
363be filtered by passing a list of files in IN-FILES or functions in IN-FUNCTIONS.
364If EXHAUSTIVE is true, it will also look for callers for which no xref information
365is present by looping through all defined functions in memory."
366  (when (and (eql name1 :wild) (eql name2 :wild))
367    (error "Only one wildcard allowed in a cross-reference query"))
368  (ecase relation
369    ((:binds :references :sets :direct-calls :indirect-calls :macro-calls)
370     (let ((lookup-table (%xref-table relation nil))
371           (inverse-lookup-table (%xref-table relation t)))
372       (let ((matches (if (eql name1 :wild)
373                          (%do-wild-xref-lookup name2 inverse-lookup-table
374                                                in-files in-functions)
375                        (if (eql name2 :wild)
376                            (%do-wild-xref-lookup name1 lookup-table
377                                                  in-files in-functions)
378                          (%do-simple-xref-lookup name1 name2 lookup-table
379                                                  in-files in-functions)))))
380         ;; search all lfuns if exhaustive is t
381         (when (and exhaustive (eql name1 :wild) (or (eql relation :direct-calls)
382                                                     (eql relation :indirect-calls)))
383           (dolist (caller (callers name2))
384             (pushnew (make-xref-entry caller relation)
385                      matches
386                      :test #'xref-entry-equal)))
387         matches)))
388    (:calls
389     (let ((direct-calls (get-relation :direct-calls name1 name2
390                                       :in-files in-files :in-functions in-functions
391                                       :exhaustive exhaustive :errorp errorp))
392           (indirect-calls (get-relation :indirect-calls name1 name2
393                                         :in-files in-files :in-functions in-functions
394                                         :exhaustive exhaustive :errorp errorp))
395           (macro-calls (get-relation :macro-calls name1 name2
396                                      :in-files in-files :in-functions in-functions
397                                      :exhaustive exhaustive :errorp errorp)))
398       (if (or (eql name1 :wild) (eql name2 :wild))
399           ;; need to weed out possible duplicates here
400           (let ((matches nil))
401             (dolist (c direct-calls) (pushnew c matches))
402             (dolist (c indirect-calls) (pushnew c matches))
403             (dolist (c macro-calls) (pushnew c matches))
404             matches)
405         (when (or direct-calls indirect-calls macro-calls)
406           name2))))
407    (:uses
408     (let ((binds (get-relation :binds name1 name2 :in-files in-files
409                                :in-functions in-functions :errorp errorp
410                                :exhaustive exhaustive))
411           (references (get-relation :binds name1 name2 :in-files in-files
412                                     :in-functions in-functions :errorp errorp
413                                     :exhaustive exhaustive))
414           (sets (get-relation :sets name1 name2 :in-files in-files
415                               :in-functions in-functions :errorp errorp
416                               :exhaustive exhaustive)))
417       (if (or (eql name1 :wild) (eql name2 :wild))
418           (concatenate 'list binds references sets)
419         (when (or binds references sets)
420           name2))))))
421
422;; %DO-WILD-XREF-LOOKUP -- internal
423;;
424;; Does a wild lookup into the xref database and returns a list of matches.
425;;
426;; FIXME: implement filtering by files
427(defun %do-wild-xref-lookup (name table in-files in-functions)
428  (declare (ignore in-files))
429  (multiple-value-bind (value foundp) (gethash name table)
430    (declare (ignore foundp))
431    (if in-functions
432        (remove-if (lambda (x) (not (find x in-functions))) value)
433      value)))
434
435;; %DO-SIMPLE-XREF-LOOKUP -- internal
436;;
437;; Does a simple lookup into the xref database and returns NAME2 if a relation
438;; between NAME1 and NAME2 exists.
439;;
440;; FIXME: implement filtering by files
441(defun %do-simple-xref-lookup (name1 name2 table in-files in-functions)
442  (declare (ignore in-files))
443  (when (some (lambda (x)
444                (when in-functions
445                  (find x in-functions))
446                (eql x name2))
447              (gethash name1 table))
448    name2))
449
450
451(defun %print-xref-entries (entries stream verbose)
452  (dolist (entry entries)
453    (if (eql (xref-entry-type entry) 'method)
454        ;; print qualifiers and specializers if it's a method
455        (format stream "~5,5T~A ~@[~A ~]~A~%"
456                (xref-entry-name entry)
457                (xref-entry-method-qualifiers entry)
458                (xref-entry-method-specializers entry))
459      (format stream "~5,5T~A~%" (xref-entry-name entry)))
460    ;; print extra information when verbose
461    (when verbose
462      (format stream "~5,5T  Type: ~A~%" (xref-entry-type entry))
463      (let ((file (%source-file-for-xref-entry entry)))
464        (format stream "~5,5T  File: ~A~%~%" (if file file "not recorded"))))))
465
466
467;; WHO-DIRECTLY-CALLS -- external
468;;
469(defun who-directly-calls (name &key inverse in-files in-functions verbose
470                                (stream *standard-output*))
471  "Prints information about direct callers of NAME. If INVERSE is true,
472it will print direct callees of NAME instead."
473  (let ((callers/callees (if inverse
474                             (get-relation :direct-calls name :wild 
475                                           :in-files in-files
476                                           :in-functions in-functions)
477                           (get-relation :direct-calls :wild name
478                                         :in-files in-files
479                                         :in-functions in-functions
480                                         :exhaustive t))))
481    (format stream "~%~T")
482    (if callers/callees
483        (progn
484          (format stream "~A ~:[is directly called by~;directly calls~]:~%"
485                  name inverse)
486          (%print-xref-entries callers/callees stream verbose))
487      (format stream "No direct ~:[callers~;callees~] of ~A were found in the database~%"
488              inverse name)))
489  (values))
490
491;; WHO-INDIRECTLY-CALLS -- external
492;;
493;; FIXME: Implement this (we can't currently detect indirect calls).
494(defun who-indirectly-calls (name &key inverse in-files in-functions verbose
495                                  (stream *standard-output*))
496  "Prints information about indirect callers of NAME. If INVERSE is true,
497it will print indirect callees of NAME instead."
498  (let ((callers/callees (if inverse
499                             (get-relation :indirect-calls name :wild 
500                                           :in-files in-files
501                                           :in-functions in-functions)
502                           (get-relation :indirect-calls :wild name
503                                         :in-files in-files
504                                         :in-functions in-functions))))
505    (format stream "~%~T")
506    (if callers/callees
507        (progn
508          (format stream "~A ~:[is indirectly called by~;indirectly calls~]:~%"
509                  name inverse)
510          (%print-xref-entries callers/callees stream verbose))
511      (format stream "No indirect ~:[callers~;callees~] of ~A were found in the database~%"
512              inverse name)))
513  (values))
514
515;; MACROS-CALLED-BY -- external
516;;
517(defun macros-called-by (name &key inverse in-files in-functions verbose
518                              (stream *standard-output*))
519  "Prints information about macros which get called by NAME. If INVERSE is true,
520it will list all functions which macroexpand NAME instead."
521    (let ((callers/callees (if (not inverse)
522                             (get-relation :macro-calls name :wild 
523                                           :in-files in-files
524                                           :in-functions in-functions)
525                           (get-relation :macro-calls :wild name
526                                         :in-files in-files
527                                         :in-functions in-functions))))
528    (format stream "~%~T")
529    (if callers/callees
530        (progn
531          (format stream "~A ~:[is macro called by~;macro calls~]:~%"
532                name (not inverse))
533          (%print-xref-entries callers/callees stream verbose))
534      (format stream "No macro ~:[callers~;callees~] of ~A were found in the database~%"
535              (not inverse) name)))
536    (values))
537
538;; WHO-CALLS -- external
539;;
540(defun who-calls (name &key inverse in-files in-functions verbose
541                       (stream *standard-output*))
542  "Shorthand for WHO-DIRECTLY-CALLS, WHO-INDIRECTLY-CALLS and
543MACROS-CALLED-BY."
544  (who-directly-calls name :inverse inverse :stream stream :verbose verbose
545                           :in-files in-files :in-functions in-functions)
546  (who-indirectly-calls name :inverse inverse :stream stream :verbose verbose
547                             :in-files in-files :in-functions in-functions)
548  (macros-called-by name :inverse (not inverse) :stream stream :verbose verbose
549                         :in-files in-files :in-functions in-functions)
550  (values))
551
552
553;; WHO-BINDS -- external
554;;
555(defun who-binds (name &key inverse in-files in-functions verbose
556                       (stream *standard-output*))
557  "Prints a list of functions which bind NAME. If INVERSE is true, it will
558print a list of variables bound by NAME instead."
559  (let ((bindings (if inverse
560                      (get-relation :binds name :wild :in-files in-files
561                                    :in-functions in-functions)
562                    (get-relation :binds :wild name :in-files in-files
563                                  :in-functions in-functions))))
564    (format stream "~%~T")
565    (if bindings
566        (progn
567          (format stream "~A ~:[is bound by;~binds~]:" name inverse)
568          (%print-xref-entries bindings stream verbose))
569      (format stream "No ~:[bindings of~;symbols bound by~] ~A were found in the database~%"
570              inverse name)))
571  (values))
572
573;; WHO-REFERENCES -- external
574;;
575(defun who-references (name &key inverse in-files in-functions verbose
576                            (stream *standard-output*))
577  "Prints a list of functions which reference NAME. If INVERSE is true, it will
578print a list of variables referenced by NAME instead."
579  (let ((references (if inverse
580                        (get-relation :references name :wild :in-files in-files
581                                      :in-functions in-functions)
582                      (get-relation :references :wild name :in-files in-files
583                                    :in-functions in-functions))))
584    (format stream "~%~T")
585    (if references
586        (progn
587          (format stream "~A ~:[is referenced by~;references~]:~%" name inverse)
588          (%print-xref-entries references stream verbose))
589      (format stream "No ~:[references to~;symbols referenced by~] ~A were found in the database~%"
590              inverse name)))
591  (values))
592
593;; WHO-SETS -- external
594;;
595(defun who-sets (name &key inverse in-files in-functions verbose
596                      (stream *standard-output*))
597    "Prints a list of functions which set NAME. If INVERSE is true, it will
598print a list of variables set by NAME instead."
599  (let ((sets (if inverse
600                  (get-relation :sets name :wild :in-files in-files
601                                :in-functions in-functions)
602                (get-relation :sets :wild name :in-files in-files
603                              :in-functions in-functions))))
604    (format stream "~%~T")
605    (if sets
606        (progn
607          (format stream "~A ~:[is set by~;sets~]:~%" name inverse)
608          (%print-xref-entries sets stream verbose))
609      (format stream "No ~:[settings of~;symbols set by~] ~A were found in the database~%"
610              inverse name)))
611  (values))
612
613;; WHO-USES -- external
614;;
615(defun who-uses (name &key inverse in-files in-functions verbose
616                      (stream *standard-output*))
617  "Shorthand for WHO-BINDS, WHO-REFERENCES and WHO-SETS."
618  (who-binds name :inverse inverse :stream stream :verbose verbose
619                  :in-files in-files :in-functions in-functions)
620
621  (who-references name :inverse inverse :stream stream :verbose verbose
622                       :in-files in-files :in-functions in-functions)
623
624  (who-sets name :inverse inverse :stream stream :verbose verbose
625                 :in-files in-files :in-functions in-functions)
626  (values))
627
628
629;; XREF-DESCRIBE -- external
630;;
631(defun xref-describe (name &key verbose)
632  "Prints relevant cross-referencing information about NAME."
633  (if (fboundp name)
634      (progn
635        (who-calls name :stream *terminal-io* :verbose verbose)
636        (who-calls name :inverse t :stream *terminal-io* :verbose verbose)
637        (who-uses name :inverse t :stream *terminal-io* :verbose verbose))
638      (who-uses name :stream *terminal-io* :verbose verbose))
639  (values))
640
641
642;;; Hook into the OpenMCL compiler frontend, by pointing a couple
643;;; of its variables at our functions.
644(setq ccl::*nx-discard-xref-info-hook* #'%discard-xref-info-for-function)
645(setq ccl::*nx-add-xref-entry-hook* #'%add-xref-entry)
646
647(provide :xref)
Note: See TracBrowser for help on using the repository browser.