4.4BSD/usr/src/old/lisp/liszt/lxref.l
(setq rcs-lxref-ident
"$Header: lxref.l,v 1.2 84/02/03 08:04:37 jkf Exp $")
;------ lxref: lisp cross reference program
;-- author: j foderaro
; This program generates a cross reference listing of a set of one or
; more lisp files. It reads the output of cross reference files
; generated by the compiler. These files usually have the extension .x .
; the .x files are lisp readable. There format is:
; The first s-expression is (File <filename>) where <filename> is the
; name of the lisp source file.
; Then there is one s-expression for each function (including macros)
; which is defined in the file. The car of each expression is the function
; name, the cadr is the function type and the cddr is a list of those
; functions called
;
; lxref can be run from the command level
; % lxref foo.x bar.x
; or in this way
; % lxref
; -> (lxref foo.x bar.x)
;
; There is one option, that is changing the ignorelevel. If a function
; is called by more than ignorelevel functions then all those functions
; are listed, instead a summary of the number of calls is printed. This
; is useful for preventing the printing of massive lists for common
; system functions such as setq.
; To change the ignorelevel to 40 you would type:
;
; % lxref -40 foo.x bar.x
;
;; internal data structures used in lxref:
; funcs : list of functions mentioned either as caller or as callee
; on each function in funcs, the property list contains some of these
; indicators:
; i-seen : always contains t [this is so we can avoid (memq foo funcs)
; i-type : list of the types this function was declared as. In 1-1
; corresp with i-home
; i-home : list of files this function was declared in. In 1-1 corresp
; with i-type
; i-callers: list of functions calling this function
; insure we have plenty of space to grow into
(opval 'pagelimit 9999)
(declare (special xref-readtable width ignorefuncs ignorelevel readtable
user-top-level poport i-seen i-type i-callers docseen
i-Chome i-Doc i-home funcs
callby-marker debug-mode
anno-off-marker liszt-internal
anno-on-marker))
(setq ignorelevel 50)
(setq callby-marker (exploden ";.. ")
anno-off-marker (exploden ";.-")
anno-on-marker (exploden ";.+"))
; internal liszt functions
(setq liszt-internal '(Internal-bcdcall liszt-internal-do))
;--- xrefinit :: called automatically upon startup
;
(def xrefinit
(lambda nil
(let ((args (command-line-args))
(retval))
; readtable should be the same as it was when liszt wrote
; the xref file
(if args
then (signal 2 'exit) ; die on interrupt
(signal 15 'exit) ; die on sigterm
(setq user-top-level nil)
(let ((retval (car (errset (funcall 'lxref args)))))
(exit (if retval thenret else -1)))
else (patom "Lxref - lisp cross reference program")
(terpr poport)
(setq user-top-level nil)))))
(setq user-top-level 'xrefinit)
;--- lxref :: main function
;
(defun lxref fexpr (files)
(prog (p funcs i-seen i-home i-type i-callers filenm caller callee name
home type caller temp fname callers clength i-Chome i-Doc docseen
Chome Doc anno-mode debug-mode)
(setq xref-readtable (makereadtable t))
(setq i-seen (gensym) i-home (gensym) i-type (gensym)
i-callers (gensym) i-Chome (gensym) i-Doc (gensym))
; check for the ignorelevel option
; it must be the first option given.
;
(If (and files (eq #/- (getcharn (car files) 1)))
then (If (fixp
(setq temp (readlist (cdr (explode (car files))))))
then (setq ignorelevel temp)
(setq files (cdr files))))
; process all files. if a -a is seen, go into annotate mode.
; otherwise generate an xref file.
;
(do ((ii files (cdr ii)))
((null ii))
(if (eq '-d (car ii))
then (setq debug-mode t)
elseif anno-mode
then (process-annotate-file (car ii))
elseif (eq '-a (car ii))
then (setq anno-mode t)
else (process-xref-file (car ii))))
(if (not anno-mode) (generate-xref-file))
(return 0)))
;.. process-xref-file
(defun illegal-file (name)
(msg "File " name " is not a valid cross reference file" N))
;--- process-xref-file :: scan the information in an xref file
; if the name ends in .l then change it to .x
;
;.. lxref
(defun process-xref-file (name)
(if debug-mode then (msg "process-xref-file: " name N))
(let (p fname filenm)
; convert foo.l to foo.x
(setq fname (nreverse (exploden name)))
(If (and (eq #/l (car fname)) (eq #/. (cadr fname)))
then (setq fname (implode (nreverse (cons #/x (cdr fname)))))
else (setq fname name))
; now look for foo or foo.x
(If (and (null (errset (setq p (infile fname)) nil))
(null (errset (setq p (infile (concat fname ".x"))) nil)))
then (msg "Couldn't open " name N)
else (setq filenm (car (errset (read p))))
(If (dtpr filenm)
then (If (eq 'File (car filenm))
then (setq filenm (cadr filenm))
(process-File p filenm)
elseif (eq 'Chome (car filenm))
then (process-Chome p)
elseif (eq 'Doc (car filenm))
then (setq docseen t) (process-Doc p)
else (illegal-file name))
else (illegal-file name))
(close p))))
;--- process-File :: process an xref file from liszt
;
;.. process-xref-file
(defun process-File (p filenm)
(let ((readtable xref-readtable))
(do ((jj (read p) (read p))
(caller)
(callee))
((null jj) (close p))
(setq caller (car jj))
(If (not (get caller i-seen))
then (putprop caller t i-seen)
(push caller funcs)) ; add to global list
; remember home of this function (and allow multiple homes)
(push filenm (get caller i-home))
; remember type of this function (and allow multiple types)
(push (cadr jj) (get caller i-type))
; for each function the caller calls
(do ((kk (cddr jj) (cdr kk)))
((null kk))
(setq callee (car kk))
(If (not (get callee i-seen)) then (putprop callee t i-seen)
(push callee funcs))
(push (cons caller filenm) (get callee i-callers))))))
;.. process-xref-file
(defun process-Chome (p)
(do ((jj (read p) (read p))
(caller))
((null jj) (close p))
(setq caller (car jj))
(If (not (get caller i-seen))
then (putprop caller t i-seen)
(push caller funcs)) ; add to global list
; remember home of this function (and allow multiple homes)
(putprop caller (cons (cdr jj) (get caller i-Chome)) i-Chome)))
;--- process-Doc :: process a Doc file
;
; A doc file begins with an entry (Doc).
; subsequent entries are (Name File) and this means that function
; Name is defined in file File. This type of file is generated
; by a sed and awk script passing over the franz manual. (see the
; Makefile in the doc directory).
;
;.. process-xref-file
(defun process-Doc (p)
(do ((jj (read p) (read p))
(caller))
((null jj) (close p))
(setq caller (car jj))
(If (not (get caller i-seen))
then (putprop caller t i-seen)
(push caller funcs)) ; add to global list
; remember home of this function (and allow multiple homes)
(putprop caller (cons (cadr jj) (get caller i-Doc)) i-Doc)))
;.. generate-xref-file
(defun terprchk (wid)
(cond ((> (setq width (+ wid width)) 78.)
(terpr)
(patom " ")
(setq width (+ 8 wid)))))
; determine type of function
;.. generate-xref-file
(defun typeit (fcn)
(cond ((bcdp fcn) (getdisc fcn))
((dtpr fcn) (car fcn))))
;.. lxref
(defun generate-xref-file ()
; sort alphabetically
(setq funcs (sort funcs 'alphalessp))
; now print out the cross reference
(do ((ii funcs (cdr ii))
(name) (home) (type) (callers) (Chome) (Doc) (clength))
((null ii))
(setq name (car ii)
home (get name i-home)
type (get name i-type)
callers (get name i-callers)
Chome (get name i-Chome)
Doc (get name i-Doc))
(If (lessp (setq clength (length callers)) ignorelevel)
then (setq callers (sortcar callers 'alphalessp)))
(do ((xx Chome (cdr xx)))
((null xx))
(setq home (cons (concat "<C-code>:" (caar xx))
home)
type (cons (cadar xx) type)))
(If (null home)
then (setq home (If (getd name)
then (setq type
(ncons (typeit (getd name))))
'(Franz-initial)
elseif (memq name liszt-internal)
then '(liszt-internal-function)
elseif (get name 'autoload)
then (list (concat "autoload: "
(get name 'autoload)))
else '(Undefined))))
(patom name)
(patom " ")
(If (null (cdr type))
then (patom (car type))
(patom " ")
(patom (car home))
else (patom "Mult def: ")
(mapcar '(lambda (typ hom)
(patom typ)
(patom " in ")
(patom hom)
(patom ", "))
type
home))
(If docseen
then (If Doc then (msg " [Doc: " (If (cdr Doc) then Doc
else (car Doc)) "]")
else (msg " [**undoc**]")))
(If (null callers) then (msg " *** Unreferenced ***"))
(terpr)
(patom " ")
(cond ((null callers))
((not (lessp clength ignorelevel))
(patom "Called by ")
(print clength)
(patom " functions"))
(t (do ((jj callers (cdr jj))
(calle)
(width 8))
((null jj))
; only print name if in same file
(setq calle (caar jj))
(cond ((memq (cdar jj) home)
(terprchk (+ (flatc calle) 2))
(patom calle))
(t (terprchk (+ (flatc calle) 6 (flatc (cdar jj))))
(patom calle)
(patom " in ")
(patom (cdar jj))))
(If (cdr jj) then (patom ", ")))))
(terpr)
(terpr)
botloop ))
;--- annotate code
;--- process-annotate-file :: anotate a file
;
;.. lxref
(defun process-annotate-file (filename)
(let (sourcep outp)
; make sure file exists and write annotate file as a
; file with the prefix #,
(if (null (errset (setq sourcep (infile filename))))
then (msg "will ignore that file " N)
else ; will write to file.A (erasing the final l)
(let ((filen (concat "#," filename)))
(setq outp (outfile filen))
(anno-it sourcep outp)
(close outp)
(close sourcep)
; now mv the original filename to #dfilename
; and the annotated file to the original file
(let ((oldcopy (concat "#." filename)))
(if (null (errset
(progn (if (probef oldcopy)
then (sys:unlink oldcopy))
(sys:link filename oldcopy)
(sys:unlink filename)
(sys:link filen filename)
(sys:unlink filen))))
then (msg "An error occured while mving files around "
N
"files possibly affected "
filename oldcopy filen)))))))
;.. process-annotate-file
(defun anno-it (inp outp)
(do ((xx (read-a-line inp) (read-a-line inp))
(anno-it t))
((null xx))
(if (match xx 1 callby-marker) ; flush anno lines
then (flush-a-line outp inp)
elseif (match xx 1 anno-off-marker)
then (setq anno-it nil) ; ';#-' turns off annotating
(write-a-line xx outp inp)
elseif (match xx 1 anno-on-marker)
then (setq anno-it t)
(write-a-line xx outp inp)
else (if anno-it then (anno-check xx outp))
(write-a-line xx outp inp))))
;;; file reading code for annotate function
; lines are read with (read-a-line port). It will read up to the
; first 127 characters in the line, returning a hunk whose cxr 0 is the
; max(index) + 1 of the characters in the hunk. the oversize-line flag
; will be set if there are still more character to be read from this line.
;
; the line should be printed by calling (print-a-line buffer) or if it isn't
; to be printed, (flush-a-line) should be called (which will check the
; oversize-line flag and flush unread input too).
;
(declare (special inp-buffer oversize-line))
(setq inp-buffer (makhunk 128))
;.. anno-it
(defun read-a-line (port)
(setq oversize-line nil)
(do ((i 1 (1+ i))
(ch (tyi port) (tyi port)))
((or (eq #\newline ch)
(eq #\eof ch))
(if (or (eq #\newline ch) (>& i 1))
then (rplacx 0 inp-buffer i) ; store size
inp-buffer ; return buffer
else nil)) ; return nil upon eof
(rplacx i inp-buffer ch)
(if (>& i 126)
then (setq oversize-line t)
(rplacx 0 inp-buffer (1+ i))
(return inp-buffer))))
;--- write-a-line :: write the given buffer and check for oversize-line
;
;.. anno-it
(defun write-a-line (buf oport iport)
(do ((max (cxr 0 buf))
(i 1 (1+ i)))
((not (<& i max))
(if oversize-line
then (oversize-check oport iport t)
else (terpr oport)))
(tyo (cxr i buf) oport)))
;.. anno-it
(defun flush-a-line (oport iport)
(oversize-check oport iport nil))
;.. flush-a-line, write-a-line
(defun oversize-check (oport iport printp)
(if oversize-line
then (do ((ch (tyi iport) (tyi iport)))
((or (eq ch #\eof) (eq ch #\newline))
(cond ((and printp (eq ch #\newline))
(tyo ch oport))))
(if printp then (tyo ch oport)))))
;.. anno-it
(defun anno-check (buffer outp)
(if (match buffer 1 '(#\lpar #/d #/e #/f))
then (let (funcname)
(if (setq funcname (find-func buffer))
(let ((recd (get funcname i-callers)))
(if recd
then (printrcd recd outp)))))))
;--- printrcd :: print a description
;
;.. anno-check
(defun printrcd (fcns port)
(let ((functions (sortcar fcns 'alphalessp)))
(print-rec functions port 0)))
;.. print-rec, printrcd
(defun print-rec (fcns p wide)
(if fcns
then (let ((size (flatc (caar fcns))))
(if (>& (+ size wide 2) 78)
then (msg (P p) N )
(setq wide 0))
(if (=& wide 0)
then (mapc '(lambda (x) (tyo x p)) callby-marker)
(setq wide (length callby-marker)))
(if (not (=& wide 4))
then (msg (P p) ", ")
(setq wide (+ wide 2)))
(msg (P p) (caar fcns))
(print-rec (cdr fcns) p (+ wide size 2)))
else (msg (P p) N)))
;--- match :: try to locate pattern in buffer
; start at 'start' in buf.
;.. anno-check, anno-it, match
(defun match (buf start pattern)
(if (null pattern)
then t
elseif (and (<& start (cxr 0 buf))
(eq (car pattern) (cxr start buf)))
then (match buf (1+ start) (cdr pattern))))
;--- find-func :: locate function name on line
;
;.. anno-check
(defun find-func (buf)
; first locate first space or tab
(do ((i 1 (1+ i))
(max (cxr 0 buf))
(die))
((or (setq die (not (<& i max)))
(memq (cxr i buf) '(#\space #\tab)))
(if die
then nil ; can find it, so give up
else ; find first non blank
(do ((ii i (1+ ii)))
((or (setq die (not (<& ii max)))
(not (memq (cxr ii buf) '(#\space #\tab))))
(if (or die (eq (cxr ii buf) #\lpar))
then nil
else ; fid first sep or left paren
(do ((iii (1+ ii) (1+ iii)))
((or (not (<& iii max))
(memq (cxr iii buf)
'(#\space #\tab #\lpar)))
(implode-fun buf ii (1- iii)))))))))))
;--- implode-fun :: return implode of everything between from and to in buf
;
;.. find-func
(defun implode-fun (buf from to)
(do ((xx (1- to) (1- xx))
(res (list (cxr to buf)) (cons (cxr xx buf) res)))
((not (<& from xx))
(implode (cons (cxr from buf) res)))))