Return to lxref.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt

Annotation of 42BSD/ucb/lisp/liszt/lxref.l, revision 1.1

1.1     ! root        1: (setq rcs-lxref-ident
        !             2:    "$Header: lxref.l,v 1.1 83/01/26 12:16:24 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
        !            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: ;--- xrefinit :: called automatically upon startup
        !            64: ;
        !            65: (def xrefinit
        !            66:    (lambda nil
        !            67:       (let ((args (command-line-args))
        !            68:            (retval))
        !            69:         ; readtable should be the same as it was when liszt wrote
        !            70:         ; the xref file
        !            71:         (if args
        !            72:            then (signal 2 'exit)       ; die on interrupt
        !            73:                 (signal 15 'exit)      ; die on sigterm
        !            74:                 (setq user-top-level nil)
        !            75:                 (let ((retval (car (errset (funcall 'lxref args)))))
        !            76:                    (exit (if retval thenret else -1)))
        !            77:            else (patom "Lxref - lisp cross reference program")
        !            78:                 (terpr poport)
        !            79:                 (setq user-top-level nil)))))
        !            80: 
        !            81: (setq user-top-level 'xrefinit)
        !            82: 
        !            83: ;--- lxref :: main function
        !            84: ;
        !            85: (defun lxref fexpr (files)
        !            86:    (prog (p funcs i-seen i-home i-type i-callers filenm caller callee name
        !            87:            home type caller temp fname callers clength i-Chome i-Doc docseen
        !            88:            Chome Doc anno-mode debug-mode)
        !            89: 
        !            90:       (setq xref-readtable (makereadtable t))
        !            91:       (setq i-seen (gensym) i-home (gensym) i-type (gensym)
        !            92:            i-callers (gensym) i-Chome (gensym) i-Doc (gensym))
        !            93: 
        !            94:       ; check for the ignorelevel option
        !            95:       ; it must be the first option given.
        !            96:       ;
        !            97:       (If (and files (eq #/- (getcharn (car files) 1)))
        !            98:         then (If (fixp
        !            99:                     (setq temp (readlist (cdr (explode (car files))))))
        !           100:                 then (setq ignorelevel temp)
        !           101:                      (setq files (cdr files))))
        !           102: 
        !           103:       ; process all files.  if a -a is seen, go into annotate mode.
        !           104:       ; otherwise generate an xref file.
        !           105:       ;
        !           106:       (do ((ii files (cdr ii)))
        !           107:          ((null ii))
        !           108:          (if (eq '-d (car ii))
        !           109:             then (setq debug-mode t)
        !           110:           elseif anno-mode
        !           111:             then (process-annotate-file (car ii))
        !           112:           elseif (eq '-a (car ii))
        !           113:             then (setq anno-mode t)
        !           114:             else (process-xref-file (car ii))))
        !           115:       (if (not anno-mode) (generate-xref-file))
        !           116:       (return 0)))
        !           117: 
        !           118: ;.. process-xref-file
        !           119: (defun illegal-file (name)
        !           120:    (msg "File " name " is not a valid cross reference file" N))
        !           121: 
        !           122: ;--- process-xref-file :: scan the information in an xref file
        !           123: ; if the name ends in .l then change it to .x
        !           124: ;
        !           125: ;.. lxref
        !           126: (defun process-xref-file (name)
        !           127:    (if debug-mode then (msg "process-xref-file: " name N))
        !           128:    (let (p fname filenm)
        !           129:       ; convert foo.l to foo.x
        !           130:       (setq fname (nreverse (exploden name)))
        !           131:       (If (and (eq #/l (car fname)) (eq #/. (cadr fname)))
        !           132:         then (setq fname (implode (nreverse (cons #/x (cdr fname)))))
        !           133:         else (setq fname name))
        !           134: 
        !           135:       ; now look for foo or foo.x
        !           136:       (If (and (null (errset (setq p (infile fname)) nil))
        !           137:               (null (errset (setq p (infile (concat fname ".x"))) nil)))
        !           138:         then (msg "Couldn't open " name N)
        !           139:         else (setq filenm (car (errset (read p))))
        !           140:              (If (dtpr filenm)
        !           141:                 then (If (eq 'File (car filenm))
        !           142:                         then (setq filenm (cadr filenm))
        !           143:                              (process-File p filenm)
        !           144:                       elseif (eq 'Chome (car filenm))
        !           145:                         then (process-Chome p)
        !           146:                       elseif (eq 'Doc (car filenm))
        !           147:                         then (setq docseen t) (process-Doc p)
        !           148:                         else (illegal-file name))
        !           149:                 else (illegal-file name))
        !           150:              (close p))))
        !           151: 
        !           152: 
        !           153: ;--- process-File :: process an xref file from liszt
        !           154: ;
        !           155: ;.. process-xref-file
        !           156: (defun process-File (p filenm)
        !           157:    (let ((readtable xref-readtable))
        !           158:       (do ((jj (read p) (read p))
        !           159:           (caller)
        !           160:           (callee))
        !           161:          ((null jj) (close p))
        !           162:          (setq caller (car jj))
        !           163:          (If (not (get caller i-seen))
        !           164:             then (putprop caller t i-seen)
        !           165:                  (push caller funcs))  ; add to global list
        !           166:          ; remember home of this function (and allow multiple homes)
        !           167:          (push filenm (get caller i-home))
        !           168: 
        !           169:          ; remember type of this function (and allow multiple types)
        !           170:          (push (cadr jj) (get caller i-type))
        !           171: 
        !           172:          ; for each function the caller calls
        !           173:          (do ((kk (cddr jj) (cdr kk)))
        !           174:              ((null kk))
        !           175:              (setq callee (car kk))
        !           176:              (If (not (get callee i-seen)) then (putprop callee t i-seen)
        !           177:                  (push callee funcs))
        !           178:              (push (cons caller filenm) (get callee i-callers))))))
        !           179: 
        !           180: ;.. process-xref-file
        !           181: (defun process-Chome (p)
        !           182:    (do ((jj (read p) (read p))
        !           183:        (caller))
        !           184:        ((null jj) (close p))
        !           185:        (setq caller (car jj))
        !           186:        (If (not (get caller i-seen))
        !           187:           then (putprop caller t i-seen)
        !           188:           (push caller funcs)) ; add to global list
        !           189:        ; remember home of this function (and allow multiple homes)
        !           190:        (putprop caller (cons (cdr jj) (get caller i-Chome)) i-Chome)))
        !           191: 
        !           192: ;--- process-Doc :: process a Doc file
        !           193: ;
        !           194: ; A doc file begins with an entry (Doc).
        !           195: ; subsequent entries are (Name File)  and this means that function
        !           196: ; Name is defined in file File.  This type of file is generated
        !           197: ; by a sed and awk script passing over the franz manual. (see the
        !           198: ; Makefile in the doc directory).
        !           199: ;
        !           200: ;.. process-xref-file
        !           201: (defun process-Doc (p)
        !           202:    (do ((jj (read p) (read p))
        !           203:        (caller))
        !           204:        ((null jj) (close p))
        !           205:        (setq caller (car jj))
        !           206:        (If (not (get caller i-seen))
        !           207:           then (putprop caller t i-seen)
        !           208:           (push caller funcs)) ; add to global list
        !           209:        ; remember home of this function (and allow multiple homes)
        !           210:        (putprop caller (cons (cadr jj) (get caller i-Doc)) i-Doc)))
        !           211: 
        !           212: ;.. generate-xref-file
        !           213: (defun terprchk (wid)
        !           214:   (cond ((> (setq width (+ wid width)) 78.) 
        !           215:         (terpr)
        !           216:         (patom "       ")
        !           217:         (setq width (+ 8 wid)))))
        !           218: 
        !           219: ; determine type of function
        !           220: ;.. generate-xref-file
        !           221: (defun typeit (fcn)
        !           222:   (cond ((bcdp fcn) (getdisc fcn))
        !           223:        ((dtpr fcn) (car fcn))))
        !           224: 
        !           225: 
        !           226: ;.. lxref
        !           227: (defun generate-xref-file ()
        !           228:    ; sort alphabetically
        !           229:    (setq funcs (sort funcs 'alphalessp))
        !           230: 
        !           231:    ; now print out the cross reference
        !           232:    (do ((ii funcs (cdr ii))
        !           233:        (name) (home) (type) (callers) (Chome) (Doc) (clength))
        !           234:        ((null ii))
        !           235:        (setq name (car ii)
        !           236:             home (get name i-home)
        !           237:             type (get name i-type)
        !           238:             callers (get name i-callers)
        !           239:             Chome (get name i-Chome)
        !           240:             Doc (get name i-Doc))
        !           241: 
        !           242:        (If (lessp (setq clength (length callers)) ignorelevel)
        !           243:          then (setq callers (sortcar callers 'alphalessp)))
        !           244: 
        !           245:        (do ((xx Chome (cdr xx)))
        !           246:           ((null xx))
        !           247:           (setq home (cons (concat "<C-code>:" (caar xx))
        !           248:                            home)
        !           249:                 type (cons (cadar xx) type)))
        !           250: 
        !           251:        (If (null home)
        !           252:          then (setq home (If (getd name)
        !           253:                             then (setq type
        !           254:                                        (ncons (typeit (getd name))))
        !           255:                                  '(Franz-initial)
        !           256:                             else '(Undefined))))
        !           257: 
        !           258:        (patom name)
        !           259:        (patom "        ")
        !           260: 
        !           261: 
        !           262:        (If (null (cdr type))
        !           263:          then (patom (car type))
        !           264:               (patom " ")
        !           265:               (patom (car home))
        !           266:          else (patom "Mult def: ")
        !           267:               (mapcar '(lambda (typ hom)
        !           268:                           (patom typ)
        !           269:                           (patom " in ")
        !           270:                           (patom hom)
        !           271:                           (patom ", "))
        !           272:                       type
        !           273:                       home))
        !           274: 
        !           275: 
        !           276:        (If docseen
        !           277:          then (If Doc then (msg "  [Doc: " (If (cdr Doc) then Doc
        !           278:                                               else (car Doc)) "]")
        !           279:                  else (msg "  [**undoc**]")))
        !           280:        (If (null callers) then (msg "  *** Unreferenced ***"))
        !           281:        (terpr)
        !           282:        (patom "        ")
        !           283:        (cond ((null callers))
        !           284:             ((not (lessp clength ignorelevel))
        !           285:              (patom "Called by ")
        !           286:              (print clength)
        !           287:              (patom " functions"))
        !           288:             (t (do ((jj callers (cdr jj))
        !           289:                     (calle)
        !           290:                     (width 8))
        !           291:                    ((null jj))
        !           292:                    ; only print name if in same file
        !           293:                    (setq calle (caar jj))
        !           294:                    (cond ((memq (cdar jj) home)
        !           295:                           (terprchk (+ (flatc calle) 2))
        !           296:                           (patom calle))
        !           297:                          (t (terprchk (+ (flatc calle) 6 (flatc (cdar jj))))
        !           298:                             (patom calle)
        !           299:                             (patom " in ")
        !           300:                             (patom (cdar jj))))
        !           301:                    (If (cdr jj) then (patom ", ")))))
        !           302:        (terpr)
        !           303:        (terpr)
        !           304:        botloop ))
        !           305: 
        !           306: 
        !           307: ;--- annotate code
        !           308: 
        !           309: 
        !           310:                   
        !           311: ;--- process-annotate-file :: anotate a file
        !           312: ;
        !           313: ;.. lxref
        !           314: (defun process-annotate-file (filename)
        !           315:    (let (sourcep outp)
        !           316:       ; make sure file exists and write annotate file as a
        !           317:       ; file with the prefix #,
        !           318:       (if (null (errset (setq sourcep (infile filename))))
        !           319:         then (msg "will ignore that file " N)
        !           320:         else ; will write to file.A (erasing the final l)
        !           321:              (let ((filen (concat "#," filename)))
        !           322:                 (setq outp (outfile filen))
        !           323:                 (anno-it sourcep outp)
        !           324:                 (close outp)
        !           325:                 ; now mv the original filename to #dfilename
        !           326:                 ; and the annotated file to the original file
        !           327:                 (let ((oldcopy (concat "#." filename)))
        !           328:                    (if (null (errset
        !           329:                                 (progn (if (probef oldcopy)
        !           330:                                           then (sys:unlink oldcopy))
        !           331:                                        (sys:link filename oldcopy)
        !           332:                                        (sys:unlink filename)
        !           333:                                        (sys:link filen filename)
        !           334:                                        (sys:unlink filen))))
        !           335:                       then (msg "An error occured while mving files around "
        !           336:                                 N
        !           337:                                 "files possibly affected "
        !           338:                                 filename oldcopy filen)))))))
        !           339: 
        !           340: 
        !           341: ;.. process-annotate-file
        !           342: (defun anno-it (inp outp)
        !           343:    (do ((xx (read-a-line inp) (read-a-line inp))
        !           344:        (anno-it t))
        !           345:        ((null xx))
        !           346:        (if (match xx 1 callby-marker)  ; flush anno lines
        !           347:          then (flush-a-line outp inp)
        !           348:        elseif (match xx 1 anno-off-marker)
        !           349:          then (setq anno-it nil)       ; ';#-'  turns off annotating
        !           350:               (write-a-line xx outp inp)
        !           351:        elseif (match xx 1 anno-on-marker)
        !           352:          then (setq anno-it t)
        !           353:               (write-a-line xx outp inp)
        !           354:          else (if anno-it then (anno-check xx outp))
        !           355:               (write-a-line xx outp inp))))
        !           356: 
        !           357: 
        !           358: ;;; file reading code for annotate function
        !           359: ; lines are read with (read-a-line port).  It will read up to the
        !           360: ; first 127 characters in the line, returning a hunk whose cxr 0 is the
        !           361: ; max(index) + 1 of the characters in the hunk.  the oversize-line flag
        !           362: ; will be set if there are still more character to be read from this line.
        !           363: ;
        !           364: ; the line should be printed by calling (print-a-line buffer) or if it isn't
        !           365: ; to be printed, (flush-a-line) should be called (which will check the
        !           366: ; oversize-line flag and flush unread input too).
        !           367: ;
        !           368: (declare (special inp-buffer oversize-line))
        !           369: 
        !           370: (setq inp-buffer (makhunk 128))
        !           371: 
        !           372: ;.. anno-it
        !           373: (defun read-a-line (port)
        !           374:    (setq oversize-line nil)
        !           375:    (do ((i 1 (1+ i))
        !           376:        (ch (tyi port) (tyi port)))
        !           377:        ((or (eq #\newline ch)
        !           378:            (eq #\eof ch))
        !           379:        (if (or (eq #\newline ch) (>& i 1))
        !           380:           then (rplacx 0 inp-buffer i)         ; store size
        !           381:                inp-buffer                      ; return buffer
        !           382:           else nil))   ; return nil upon eof
        !           383:        (rplacx i inp-buffer ch)
        !           384:        (if (>& i 126)
        !           385:          then (setq oversize-line t)
        !           386:               (rplacx 0 inp-buffer (1+ i))
        !           387:               (return inp-buffer))))
        !           388: 
        !           389: ;--- write-a-line :: write the given buffer and check for oversize-line
        !           390: ;
        !           391: ;.. anno-it
        !           392: (defun write-a-line (buf oport iport)
        !           393:    (do ((max (cxr 0 buf))
        !           394:        (i 1 (1+ i)))
        !           395:        ((not (<& i max))
        !           396:        (if oversize-line
        !           397:            then (oversize-check oport iport t)
        !           398:            else (terpr oport)))
        !           399:        (tyo (cxr i buf) oport)))
        !           400: 
        !           401: ;.. anno-it
        !           402: (defun flush-a-line (oport iport)
        !           403:    (oversize-check oport iport nil))
        !           404: 
        !           405: ;.. flush-a-line, write-a-line
        !           406: (defun oversize-check (oport iport printp)
        !           407:    (if oversize-line
        !           408:       then (do ((ch (tyi iport) (tyi iport)))
        !           409:               ((or (eq ch #\eof) (eq ch #\newline))
        !           410:                (cond ((and printp (eq ch #\newline))
        !           411:                       (tyo ch oport))))
        !           412:               (if printp then (tyo ch oport)))))
        !           413: 
        !           414:        
        !           415:                       
        !           416: ;.. anno-it
        !           417: (defun anno-check (buffer outp)
        !           418:    (if (match buffer 1 '(#\lpar #/d #/e #/f))
        !           419:       then (let (funcname)
        !           420:              (if (setq funcname (find-func buffer))
        !           421:                  (let ((recd (get funcname i-callers)))
        !           422:                     (if recd
        !           423:                        then (printrcd recd outp)))))))
        !           424: 
        !           425: ;--- printrcd :: print a description
        !           426: ;
        !           427: ;.. anno-check
        !           428: (defun printrcd (fcns port)
        !           429:    (let ((functions (sortcar fcns 'alphalessp)))
        !           430:       (print-rec functions port 0)))
        !           431: 
        !           432: ;.. print-rec, printrcd
        !           433: (defun print-rec (fcns p wide)
        !           434:    (if fcns
        !           435:       then (let ((size (flatc (caar fcns))))
        !           436:              (if (>& (+ size wide 2) 78)
        !           437:                 then (msg (P p) N )
        !           438:                      (setq wide 0))
        !           439:              (if (=& wide 0)
        !           440:                 then (mapc '(lambda (x) (tyo x p)) callby-marker)
        !           441:                      (setq wide (length callby-marker)))
        !           442:              (if (not (=& wide 4))
        !           443:                 then (msg (P p) ", ")
        !           444:                      (setq wide (+ wide 2)))
        !           445:              (msg (P p) (caar fcns))
        !           446:              (print-rec (cdr fcns) p (+ wide size 2)))
        !           447:       else (msg (P p) N)))
        !           448: 
        !           449:                      
        !           450:                    
        !           451: ;--- match :: try to locate pattern in buffer
        !           452: ; start at 'start' in buf.
        !           453: ;.. anno-check, anno-it, match
        !           454: (defun match (buf start pattern)
        !           455:    (if (null pattern)
        !           456:       then t
        !           457:     elseif (and (<& start (cxr 0 buf))
        !           458:            (eq (car pattern) (cxr start buf)))
        !           459:       then (match buf (1+ start) (cdr pattern))))
        !           460: 
        !           461: ;--- find-func :: locate function name on line
        !           462: ;
        !           463: ;.. anno-check
        !           464: (defun find-func (buf)
        !           465:    ; first locate first space or tab
        !           466:    (do ((i 1 (1+ i))
        !           467:        (max (cxr 0 buf))
        !           468:        (die))
        !           469:        ((or (setq die (not (<& i max)))
        !           470:            (memq (cxr i buf) '(#\space #\tab)))
        !           471:        (if die
        !           472:           then nil     ; can find it, so give up
        !           473:           else ; find first non blank
        !           474:                (do ((ii i (1+ ii)))
        !           475:                    ((or (setq die (not (<& ii max)))
        !           476:                         (not (memq (cxr ii buf) '(#\space #\tab))))
        !           477:                     (if (or die (eq (cxr ii buf) #\lpar))
        !           478:                        then nil
        !           479:                        else ; fid first sep or left paren
        !           480:                             (do ((iii (1+ ii) (1+ iii)))
        !           481:                                 ((or (not (<& iii max))
        !           482:                                      (memq (cxr iii buf)
        !           483:                                            '(#\space #\tab #\lpar)))
        !           484:                                  (implode-fun buf ii (1- iii)))))))))))
        !           485: 
        !           486: ;--- implode-fun :: return implode of everything between from and to in buf
        !           487: ;
        !           488: ;.. find-func
        !           489: (defun implode-fun (buf from to)
        !           490:    (do ((xx (1- to) (1- xx))
        !           491:        (res (list (cxr to buf)) (cons (cxr xx buf) res)))
        !           492:        ((not (<& from xx))
        !           493:        (implode (cons (cxr from buf) res)))))
        !           494: 
        !           495: 
        !           496: 
        !           497: 
        !           498: 

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