"$Header: lxref.l,v 1.2 84/02/03 08:04:37 jkf Exp $")
;------ lxref: lisp cross reference program
; 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
; lxref can be run from the command level
; 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
; 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
; i-home : list of files this function was declared in. In 1-1 corresp
; i-callers: list of functions calling this function
; insure we have plenty of space to grow into
(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
anno-off-marker liszt-internal
(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
(let ((args (command-line-args))
; readtable should be the same as it was when liszt wrote
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")
(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)))
(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)))
then (process-annotate-file (car ii))
else (process-xref-file (car ii))))
(if (not anno-mode) (generate-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
(defun process-xref-file (name)
(if debug-mode then (msg "process-xref-file: " name N))
(setq fname (nreverse (exploden name)))
(If (and (eq #/l (car fname)) (eq #/. (cadr fname)))
then (setq fname (implode (nreverse (cons #/x (cdr fname)))))
; 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))))
then (If (eq 'File (car filenm))
then (setq filenm (cadr filenm))
elseif (eq 'Chome (car filenm))
elseif (eq 'Doc (car filenm))
then (setq docseen t) (process-Doc p)
else (illegal-file name))
else (illegal-file name))
;--- process-File :: process an xref file from liszt
(defun process-File (p filenm)
(let ((readtable xref-readtable))
(do ((jj (read p) (read p))
(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)))
(If (not (get callee i-seen)) then (putprop callee t i-seen)
(push (cons caller filenm) (get callee i-callers))))))
(do ((jj (read p) (read p))
(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).
(do ((jj (read p) (read p))
(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)))
(cond ((> (setq width (+ wid width)) 78.)
(setq width (+ 8 wid)))))
; determine type of function
(cond ((bcdp fcn) (getdisc fcn))
(defun generate-xref-file ()
(setq funcs (sort funcs 'alphalessp))
; now print out the cross reference
(name) (home) (type) (callers) (Chome) (Doc) (clength))
callers (get name i-callers)
(If (lessp (setq clength (length callers)) ignorelevel)
then (setq callers (sortcar callers 'alphalessp)))
(do ((xx Chome (cdr xx)))
(setq home (cons (concat "<C-code>:" (caar xx))
type (cons (cadar xx) type)))
then (setq home (If (getd name)
(ncons (typeit (getd name))))
elseif (memq name liszt-internal)
then '(liszt-internal-function)
elseif (get name 'autoload)
then (list (concat "autoload: "
else (patom "Mult def: ")
(mapcar '(lambda (typ hom)
then (If Doc then (msg " [Doc: " (If (cdr Doc) then Doc
else (msg " [**undoc**]")))
(If (null callers) then (msg " *** Unreferenced ***"))
((not (lessp clength ignorelevel))
(t (do ((jj callers (cdr jj))
; only print name if in same file
(cond ((memq (cdar jj) home)
(terprchk (+ (flatc calle) 2))
(t (terprchk (+ (flatc calle) 6 (flatc (cdar jj))))
(If (cdr jj) then (patom ", ")))))
;--- process-annotate-file :: anotate a file
(defun process-annotate-file (filename)
; 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))
; now mv the original filename to #dfilename
; and the annotated file to the original file
(let ((oldcopy (concat "#." filename)))
(progn (if (probef oldcopy)
then (sys:unlink oldcopy))
(sys:link filename oldcopy)
(sys:link filen filename)
then (msg "An error occured while mving files around "
"files possibly affected "
filename oldcopy filen)))))))
;.. process-annotate-file
(defun anno-it (inp outp)
(do ((xx (read-a-line inp) (read-a-line inp))
(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)
(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))
(defun read-a-line (port)
(ch (tyi port) (tyi port)))
(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
then (setq oversize-line t)
(rplacx 0 inp-buffer (1+ i))
;--- write-a-line :: write the given buffer and check for oversize-line
(defun write-a-line (buf oport iport)
then (oversize-check oport iport t)
(tyo (cxr i buf) oport)))
(defun flush-a-line (oport iport)
(oversize-check oport iport nil))
;.. flush-a-line, write-a-line
(defun oversize-check (oport iport printp)
then (do ((ch (tyi iport) (tyi iport)))
((or (eq ch #\eof) (eq ch #\newline))
(cond ((and printp (eq ch #\newline))
(if printp then (tyo ch oport)))))
(defun anno-check (buffer outp)
(if (match buffer 1 '(#\lpar #/d #/e #/f))
(if (setq funcname (find-func buffer))
(let ((recd (get funcname i-callers)))
then (printrcd recd outp)))))))
;--- printrcd :: print a description
(defun printrcd (fcns port)
(let ((functions (sortcar fcns 'alphalessp)))
(print-rec functions port 0)))
(defun print-rec (fcns p wide)
then (let ((size (flatc (caar fcns))))
(if (>& (+ size wide 2) 78)
then (mapc '(lambda (x) (tyo x p)) callby-marker)
(setq wide (length callby-marker)))
(print-rec (cdr fcns) p (+ wide size 2)))
;--- match :: try to locate pattern in buffer
; start at 'start' in buf.
;.. anno-check, anno-it, match
(defun match (buf start pattern)
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
; first locate first space or tab
((or (setq die (not (<& i max)))
(memq (cxr i buf) '(#\space #\tab)))
then nil ; can find it, so give up
else ; find first non blank
((or (setq die (not (<& ii max)))
(not (memq (cxr ii buf) '(#\space #\tab))))
(if (or die (eq (cxr ii buf) #\lpar))
else ; fid first sep or left paren
(do ((iii (1+ ii) (1+ iii)))
'(#\space #\tab #\lpar)))
(implode-fun buf ii (1- iii)))))))))))
;--- implode-fun :: return implode of everything between from and to in buf
(defun implode-fun (buf from to)
(do ((xx (1- to) (1- xx))
(res (list (cxr to buf)) (cons (cxr xx buf) res)))
(implode (cons (cxr from buf) res)))))
projects / unix-history / blob