Context Navigation

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

Visit:

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
111	from 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
375	be filtered by passing a list of files in IN-FILES or functions in IN-FUNCTIONS.
376	If EXHAUSTIVE is true, it will also look for callers for which no xref information
377	is 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,
484	it 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,
509	it 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,
532	it 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
555	MACROS-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
570	print 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
590	print 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
610	print 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.

Download in other formats: