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) |
---|