![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lxref.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt|
Return to lxref.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt |
1.1 root 1: (setq rcs-lxref-ident
2: "$Header: lxref.l,v 1.1 83/01/26 12:16:24 jkf Exp $")
3:
4: ;------ lxref: lisp cross reference program
5: ;-- author: j foderaro
6: ; This program generates a cross reference listing of a set of one or
7: ; more lisp files. It reads the output of cross reference files
8: ; generated by the compiler. These files usually have the extension .x .
9: ; the .x files are lisp readable. There format is:
10: ; The first s-expression is (File <filename>) where <filename> is the
11: ; name of the lisp source file.
12: ; Then there is one s-expression for each function (including macros)
13: ; which is defined in the file. The car of each expression is the function
14: ; name, the cadr is the function type and the cddr is a list of those
15: ; functions called
16: ;
17: ; lxref can be run from the command level
18: ; % lxref foo.x bar.x
19: ; or in this way
20: ; % lxref
21: ; -> (lxref foo.x bar.x)
22: ;
23: ; There is one option, that is changing the ignorelevel. If a function
24: ; is called by more than ignorelevel functions then all those functions
25: ; are listed, instead a summary of the number of calls is printed. This
26: ; is useful for preventing the printing of massive lists for common
27: ; system functions such as setq.
28: ; To change the ignorelevel to 40 you would type:
29: ;
30: ; % lxref -40 foo.x bar.x
31: ;
32: ;; internal data structures used in lxref:
33: ; funcs : list of functions mentioned either as caller or as callee
34: ; on each function in funcs, the property list contains some of these
35: ; indicators:
36: ; i-seen : always contains t [this is so we can avoid (memq foo funcs)
37: ; i-type : list of the types this function was declared as. In 1-1
38: ; corresp with i-home
39: ; i-home : list of files this function was declared in. In 1-1 corresp
40: ; with i-type
41: ; i-callers: list of functions calling this function
42:
43:
44:
45:
46:
47: ; insure we have plenty of space to grow into
48: (opval 'pagelimit 9999)
49:
50:
51: (declare (special xref-readtable width ignorefuncs ignorelevel readtable
52: user-top-level poport i-seen i-type i-callers docseen
53: i-Chome i-Doc i-home funcs
54: callby-marker debug-mode
55: anno-off-marker
56: anno-on-marker))
57:
58: (setq ignorelevel 50)
59: (setq callby-marker (exploden ";.. ")
60: anno-off-marker (exploden ";.-")
61: anno-on-marker (exploden ";.+"))
62:
63: ;--- xrefinit :: called automatically upon startup
64: ;
65: (def xrefinit
66: (lambda nil
67: (let ((args (command-line-args))
68: (retval))
69: ; readtable should be the same as it was when liszt wrote
70: ; the xref file
71: (if args
72: then (signal 2 'exit) ; die on interrupt
73: (signal 15 'exit) ; die on sigterm
74: (setq user-top-level nil)
75: (let ((retval (car (errset (funcall 'lxref args)))))
76: (exit (if retval thenret else -1)))
77: else (patom "Lxref - lisp cross reference program")
78: (terpr poport)
79: (setq user-top-level nil)))))
80:
81: (setq user-top-level 'xrefinit)
82:
83: ;--- lxref :: main function
84: ;
85: (defun lxref fexpr (files)
86: (prog (p funcs i-seen i-home i-type i-callers filenm caller callee name
87: home type caller temp fname callers clength i-Chome i-Doc docseen
88: Chome Doc anno-mode debug-mode)
89:
90: (setq xref-readtable (makereadtable t))
91: (setq i-seen (gensym) i-home (gensym) i-type (gensym)
92: i-callers (gensym) i-Chome (gensym) i-Doc (gensym))
93:
94: ; check for the ignorelevel option
95: ; it must be the first option given.
96: ;
97: (If (and files (eq #/- (getcharn (car files) 1)))
98: then (If (fixp
99: (setq temp (readlist (cdr (explode (car files))))))
100: then (setq ignorelevel temp)
101: (setq files (cdr files))))
102:
103: ; process all files. if a -a is seen, go into annotate mode.
104: ; otherwise generate an xref file.
105: ;
106: (do ((ii files (cdr ii)))
107: ((null ii))
108: (if (eq '-d (car ii))
109: then (setq debug-mode t)
110: elseif anno-mode
111: then (process-annotate-file (car ii))
112: elseif (eq '-a (car ii))
113: then (setq anno-mode t)
114: else (process-xref-file (car ii))))
115: (if (not anno-mode) (generate-xref-file))
116: (return 0)))
117:
118: ;.. process-xref-file
119: (defun illegal-file (name)
120: (msg "File " name " is not a valid cross reference file" N))
121:
122: ;--- process-xref-file :: scan the information in an xref file
123: ; if the name ends in .l then change it to .x
124: ;
125: ;.. lxref
126: (defun process-xref-file (name)
127: (if debug-mode then (msg "process-xref-file: " name N))
128: (let (p fname filenm)
129: ; convert foo.l to foo.x
130: (setq fname (nreverse (exploden name)))
131: (If (and (eq #/l (car fname)) (eq #/. (cadr fname)))
132: then (setq fname (implode (nreverse (cons #/x (cdr fname)))))
133: else (setq fname name))
134:
135: ; now look for foo or foo.x
136: (If (and (null (errset (setq p (infile fname)) nil))
137: (null (errset (setq p (infile (concat fname ".x"))) nil)))
138: then (msg "Couldn't open " name N)
139: else (setq filenm (car (errset (read p))))
140: (If (dtpr filenm)
141: then (If (eq 'File (car filenm))
142: then (setq filenm (cadr filenm))
143: (process-File p filenm)
144: elseif (eq 'Chome (car filenm))
145: then (process-Chome p)
146: elseif (eq 'Doc (car filenm))
147: then (setq docseen t) (process-Doc p)
148: else (illegal-file name))
149: else (illegal-file name))
150: (close p))))
151:
152:
153: ;--- process-File :: process an xref file from liszt
154: ;
155: ;.. process-xref-file
156: (defun process-File (p filenm)
157: (let ((readtable xref-readtable))
158: (do ((jj (read p) (read p))
159: (caller)
160: (callee))
161: ((null jj) (close p))
162: (setq caller (car jj))
163: (If (not (get caller i-seen))
164: then (putprop caller t i-seen)
165: (push caller funcs)) ; add to global list
166: ; remember home of this function (and allow multiple homes)
167: (push filenm (get caller i-home))
168:
169: ; remember type of this function (and allow multiple types)
170: (push (cadr jj) (get caller i-type))
171:
172: ; for each function the caller calls
173: (do ((kk (cddr jj) (cdr kk)))
174: ((null kk))
175: (setq callee (car kk))
176: (If (not (get callee i-seen)) then (putprop callee t i-seen)
177: (push callee funcs))
178: (push (cons caller filenm) (get callee i-callers))))))
179:
180: ;.. process-xref-file
181: (defun process-Chome (p)
182: (do ((jj (read p) (read p))
183: (caller))
184: ((null jj) (close p))
185: (setq caller (car jj))
186: (If (not (get caller i-seen))
187: then (putprop caller t i-seen)
188: (push caller funcs)) ; add to global list
189: ; remember home of this function (and allow multiple homes)
190: (putprop caller (cons (cdr jj) (get caller i-Chome)) i-Chome)))
191:
192: ;--- process-Doc :: process a Doc file
193: ;
194: ; A doc file begins with an entry (Doc).
195: ; subsequent entries are (Name File) and this means that function
196: ; Name is defined in file File. This type of file is generated
197: ; by a sed and awk script passing over the franz manual. (see the
198: ; Makefile in the doc directory).
199: ;
200: ;.. process-xref-file
201: (defun process-Doc (p)
202: (do ((jj (read p) (read p))
203: (caller))
204: ((null jj) (close p))
205: (setq caller (car jj))
206: (If (not (get caller i-seen))
207: then (putprop caller t i-seen)
208: (push caller funcs)) ; add to global list
209: ; remember home of this function (and allow multiple homes)
210: (putprop caller (cons (cadr jj) (get caller i-Doc)) i-Doc)))
211:
212: ;.. generate-xref-file
213: (defun terprchk (wid)
214: (cond ((> (setq width (+ wid width)) 78.)
215: (terpr)
216: (patom " ")
217: (setq width (+ 8 wid)))))
218:
219: ; determine type of function
220: ;.. generate-xref-file
221: (defun typeit (fcn)
222: (cond ((bcdp fcn) (getdisc fcn))
223: ((dtpr fcn) (car fcn))))
224:
225:
226: ;.. lxref
227: (defun generate-xref-file ()
228: ; sort alphabetically
229: (setq funcs (sort funcs 'alphalessp))
230:
231: ; now print out the cross reference
232: (do ((ii funcs (cdr ii))
233: (name) (home) (type) (callers) (Chome) (Doc) (clength))
234: ((null ii))
235: (setq name (car ii)
236: home (get name i-home)
237: type (get name i-type)
238: callers (get name i-callers)
239: Chome (get name i-Chome)
240: Doc (get name i-Doc))
241:
242: (If (lessp (setq clength (length callers)) ignorelevel)
243: then (setq callers (sortcar callers 'alphalessp)))
244:
245: (do ((xx Chome (cdr xx)))
246: ((null xx))
247: (setq home (cons (concat "<C-code>:" (caar xx))
248: home)
249: type (cons (cadar xx) type)))
250:
251: (If (null home)
252: then (setq home (If (getd name)
253: then (setq type
254: (ncons (typeit (getd name))))
255: '(Franz-initial)
256: else '(Undefined))))
257:
258: (patom name)
259: (patom " ")
260:
261:
262: (If (null (cdr type))
263: then (patom (car type))
264: (patom " ")
265: (patom (car home))
266: else (patom "Mult def: ")
267: (mapcar '(lambda (typ hom)
268: (patom typ)
269: (patom " in ")
270: (patom hom)
271: (patom ", "))
272: type
273: home))
274:
275:
276: (If docseen
277: then (If Doc then (msg " [Doc: " (If (cdr Doc) then Doc
278: else (car Doc)) "]")
279: else (msg " [**undoc**]")))
280: (If (null callers) then (msg " *** Unreferenced ***"))
281: (terpr)
282: (patom " ")
283: (cond ((null callers))
284: ((not (lessp clength ignorelevel))
285: (patom "Called by ")
286: (print clength)
287: (patom " functions"))
288: (t (do ((jj callers (cdr jj))
289: (calle)
290: (width 8))
291: ((null jj))
292: ; only print name if in same file
293: (setq calle (caar jj))
294: (cond ((memq (cdar jj) home)
295: (terprchk (+ (flatc calle) 2))
296: (patom calle))
297: (t (terprchk (+ (flatc calle) 6 (flatc (cdar jj))))
298: (patom calle)
299: (patom " in ")
300: (patom (cdar jj))))
301: (If (cdr jj) then (patom ", ")))))
302: (terpr)
303: (terpr)
304: botloop ))
305:
306:
307: ;--- annotate code
308:
309:
310:
311: ;--- process-annotate-file :: anotate a file
312: ;
313: ;.. lxref
314: (defun process-annotate-file (filename)
315: (let (sourcep outp)
316: ; make sure file exists and write annotate file as a
317: ; file with the prefix #,
318: (if (null (errset (setq sourcep (infile filename))))
319: then (msg "will ignore that file " N)
320: else ; will write to file.A (erasing the final l)
321: (let ((filen (concat "#," filename)))
322: (setq outp (outfile filen))
323: (anno-it sourcep outp)
324: (close outp)
325: ; now mv the original filename to #dfilename
326: ; and the annotated file to the original file
327: (let ((oldcopy (concat "#." filename)))
328: (if (null (errset
329: (progn (if (probef oldcopy)
330: then (sys:unlink oldcopy))
331: (sys:link filename oldcopy)
332: (sys:unlink filename)
333: (sys:link filen filename)
334: (sys:unlink filen))))
335: then (msg "An error occured while mving files around "
336: N
337: "files possibly affected "
338: filename oldcopy filen)))))))
339:
340:
341: ;.. process-annotate-file
342: (defun anno-it (inp outp)
343: (do ((xx (read-a-line inp) (read-a-line inp))
344: (anno-it t))
345: ((null xx))
346: (if (match xx 1 callby-marker) ; flush anno lines
347: then (flush-a-line outp inp)
348: elseif (match xx 1 anno-off-marker)
349: then (setq anno-it nil) ; ';#-' turns off annotating
350: (write-a-line xx outp inp)
351: elseif (match xx 1 anno-on-marker)
352: then (setq anno-it t)
353: (write-a-line xx outp inp)
354: else (if anno-it then (anno-check xx outp))
355: (write-a-line xx outp inp))))
356:
357:
358: ;;; file reading code for annotate function
359: ; lines are read with (read-a-line port). It will read up to the
360: ; first 127 characters in the line, returning a hunk whose cxr 0 is the
361: ; max(index) + 1 of the characters in the hunk. the oversize-line flag
362: ; will be set if there are still more character to be read from this line.
363: ;
364: ; the line should be printed by calling (print-a-line buffer) or if it isn't
365: ; to be printed, (flush-a-line) should be called (which will check the
366: ; oversize-line flag and flush unread input too).
367: ;
368: (declare (special inp-buffer oversize-line))
369:
370: (setq inp-buffer (makhunk 128))
371:
372: ;.. anno-it
373: (defun read-a-line (port)
374: (setq oversize-line nil)
375: (do ((i 1 (1+ i))
376: (ch (tyi port) (tyi port)))
377: ((or (eq #\newline ch)
378: (eq #\eof ch))
379: (if (or (eq #\newline ch) (>& i 1))
380: then (rplacx 0 inp-buffer i) ; store size
381: inp-buffer ; return buffer
382: else nil)) ; return nil upon eof
383: (rplacx i inp-buffer ch)
384: (if (>& i 126)
385: then (setq oversize-line t)
386: (rplacx 0 inp-buffer (1+ i))
387: (return inp-buffer))))
388:
389: ;--- write-a-line :: write the given buffer and check for oversize-line
390: ;
391: ;.. anno-it
392: (defun write-a-line (buf oport iport)
393: (do ((max (cxr 0 buf))
394: (i 1 (1+ i)))
395: ((not (<& i max))
396: (if oversize-line
397: then (oversize-check oport iport t)
398: else (terpr oport)))
399: (tyo (cxr i buf) oport)))
400:
401: ;.. anno-it
402: (defun flush-a-line (oport iport)
403: (oversize-check oport iport nil))
404:
405: ;.. flush-a-line, write-a-line
406: (defun oversize-check (oport iport printp)
407: (if oversize-line
408: then (do ((ch (tyi iport) (tyi iport)))
409: ((or (eq ch #\eof) (eq ch #\newline))
410: (cond ((and printp (eq ch #\newline))
411: (tyo ch oport))))
412: (if printp then (tyo ch oport)))))
413:
414:
415:
416: ;.. anno-it
417: (defun anno-check (buffer outp)
418: (if (match buffer 1 '(#\lpar #/d #/e #/f))
419: then (let (funcname)
420: (if (setq funcname (find-func buffer))
421: (let ((recd (get funcname i-callers)))
422: (if recd
423: then (printrcd recd outp)))))))
424:
425: ;--- printrcd :: print a description
426: ;
427: ;.. anno-check
428: (defun printrcd (fcns port)
429: (let ((functions (sortcar fcns 'alphalessp)))
430: (print-rec functions port 0)))
431:
432: ;.. print-rec, printrcd
433: (defun print-rec (fcns p wide)
434: (if fcns
435: then (let ((size (flatc (caar fcns))))
436: (if (>& (+ size wide 2) 78)
437: then (msg (P p) N )
438: (setq wide 0))
439: (if (=& wide 0)
440: then (mapc '(lambda (x) (tyo x p)) callby-marker)
441: (setq wide (length callby-marker)))
442: (if (not (=& wide 4))
443: then (msg (P p) ", ")
444: (setq wide (+ wide 2)))
445: (msg (P p) (caar fcns))
446: (print-rec (cdr fcns) p (+ wide size 2)))
447: else (msg (P p) N)))
448:
449:
450:
451: ;--- match :: try to locate pattern in buffer
452: ; start at 'start' in buf.
453: ;.. anno-check, anno-it, match
454: (defun match (buf start pattern)
455: (if (null pattern)
456: then t
457: elseif (and (<& start (cxr 0 buf))
458: (eq (car pattern) (cxr start buf)))
459: then (match buf (1+ start) (cdr pattern))))
460:
461: ;--- find-func :: locate function name on line
462: ;
463: ;.. anno-check
464: (defun find-func (buf)
465: ; first locate first space or tab
466: (do ((i 1 (1+ i))
467: (max (cxr 0 buf))
468: (die))
469: ((or (setq die (not (<& i max)))
470: (memq (cxr i buf) '(#\space #\tab)))
471: (if die
472: then nil ; can find it, so give up
473: else ; find first non blank
474: (do ((ii i (1+ ii)))
475: ((or (setq die (not (<& ii max)))
476: (not (memq (cxr ii buf) '(#\space #\tab))))
477: (if (or die (eq (cxr ii buf) #\lpar))
478: then nil
479: else ; fid first sep or left paren
480: (do ((iii (1+ ii) (1+ iii)))
481: ((or (not (<& iii max))
482: (memq (cxr iii buf)
483: '(#\space #\tab #\lpar)))
484: (implode-fun buf ii (1- iii)))))))))))
485:
486: ;--- implode-fun :: return implode of everything between from and to in buf
487: ;
488: ;.. find-func
489: (defun implode-fun (buf from to)
490: (do ((xx (1- to) (1- xx))
491: (res (list (cxr to buf)) (cons (cxr xx buf) res)))
492: ((not (<& from xx))
493: (implode (cons (cxr from buf) res)))))
494:
495:
496:
497:
498:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.