;------   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
;


; load in the macro package
(eval-when (eval compile)
  (cond ((null (get 'jkfmacs 'version)) (load 'jkfmacs))))

(defmacro Push (atm val)
  `(setq ,atm (cons ,val ,atm)))



; insure we have plenty of space to grow into
(opval 'pagelimit 9999)


(declare (special width ignorefuncs))
(setq ignorelevel 50)

(def xrefinit
  (lambda nil
	  (setq readtable (makereadtable t))
	  (cond ((greaterp (argv -1) 1)      ; build up list of args
		 (do ((i (1- (argv -1)) (1- i)) (arglis))
		     ((lessp i 1) 
		      (setq user-top-level nil)
		      (exit (apply 'lxref arglis)))
		     (setq arglis (cons (argv i) arglis))))
		(t (patom "Lxref - lisp cross reference program")
		   (terpr poport)
		   (setq user-top-level nil)))))

(setq user-top-level 'xrefinit)

(defun lxref fexpr (files)
 (prog (p funcs i-seen i-home i-type i-callers filenm caller callee name
	  home type caller tmp fname)
  (setq i-seen (gensym) i-home (gensym) i-type (gensym) i-callers (gensym))

  ; check for the only option permitted, that of changing the ignorelevel
  ;
  (If (and files (eq '- (car (setq tmp (explode (car files))))))
      then (If (not (fixp (setq ignorelevel (readlist (cdr tmp)))))
	       then (patom "bad ignorelevel count")
		    (exit 1))
	   (setq files (cdr files)))
  (do ((ii files (cdr ii)))
      ((null ii))
      ; open up xref file 
      (setq fname (nreverse (explodec (car ii))))
      (If (and (eq 'l (car fname) (eq '|.| (cadr fname))))
	  then (setq fname (implode (nreverse (cons 'x 
						    (cons '|.| 
							  (cddr fname))))))
	  else (setq fname (car ii)))
      (If (and (not (portp (setq p (car (errset (infile fname) nil)))))
	       (not (portp (setq p (car (errset (infile (concat fname ".x"))))))))
	  then (patom "Couldn't open ")
	       (patom (car ii))
	       (terpr)
	       (go bottom))

      ; first record should be (File filename)
      (setq filenm (car (errset (read p))))

      (If (and (dtpr filenm) (eq 'File (car filenm)))
	  then (setq filenm (cadr filenm))
	  else (patom "File ")
	       (patom (car ii))
	       (patom " is not a xref file")
	       (terpr)
	       (close p)
	       (go bottom))

     ;(patom "Processing ") (patom (car ii)) (terpr) (drain)

      ; for each function in the file
      (do ((jj (read p) (read p)))
	  ((null jj) (close p))
	  (setq caller (car jj))
	  (If (not (get caller i-seen))
	      then (putprop caller t i-seen)
		   (Push funcs caller))	; add to global list
	  ; remember home of this function (and allow multiple homes)
	  (putprop caller (cons filenm (get caller i-home)) i-home)

	  ; remember type of this function (and allow multiple types)
	  (putprop caller (cons (cadr jj) (get caller i-type)) 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 funcs callee))
	      (putprop callee 
		       (cons (cons caller filenm) 
			     (get callee i-callers)) 
		       i-callers)))
      bottom )

       ; sort alphabetically
      ; (patom "There are ") (print (length funcs)) (patom " functions ")
      ; (terpr)
        (setq funcs (sort funcs 'alphalessp))
      ;(patom "To sort required ") (print sort-compares) (patom "comparisons")
      ; (terpr)

       ; now print out the cross reference
       (do ((ii funcs (cdr ii)))
	   ((null ii))
	   (setq name (car ii)
		 home (get name i-home)
		 type (get name i-type)
		 callers (get name i-callers))

	   (If (lessp (setq clength (length callers)) ignorelevel) 
	       then (setq callers (sortcar callers 'alphalessp)))
	   (If (null home) 
	       then (setq home (If (getd name) 
				   then  (setq type (ncons (typeit (getd name))))
				         '(Franz-initial)
			           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))

	   
	   (terpr)
	   (patom "	")
	   (cond ((null callers)
		  (patom "*** Unreferenced ***"))
		 ((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 )
(return 0)))


(defun terprchk (wid)
  (cond ((> (setq width (+ wid width)) 80.) 
	 (terpr)
	 (patom "	")
	 (setq width (+ 8 wid)))))

; determine type of function
(defun typeit (fcn)
  (cond ((bcdp fcn) (getdisc fcn))
	((dtpr fcn) (car fcn))))


; set up read table to be the same as when liszt wrote the file
(setq readtable (makereadtable t))	; readtable same as original