Return to lxref.l CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt

Annotation of 43BSDTahoe/ucb/lisp/liszt/lxref.l, revision 1.1

1.1     ! root        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: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.