home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / lxref.l < prev    next >
Encoding:
Text File  |  1984-02-02  |  15.0 KB  |  508 lines
  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.  
  508.