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