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