source: trunk/source/lib/xref.lisp @ 14423

Last change on this file since 14423 was 13066, checked in by rme, 10 years ago

Change "OpenMCL" to "Clozure CL" in comments and docstrings.

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