c c CALLTREE.FOR c c Print call tree for set of FORTRAN programs c PROGRAM calltree IMPLICIT INTEGER*4 (a-z) INCLUDE 'CALLTREE.FTN' c CALL init CALL readem CALL sortem CALL printem CALL listem c STOP END c c ---------------------------------------------------------------------------- c BLOCK DATA IMPLICIT INTEGER*4 (a-z) INCLUDE 'CALLTREE.FTN/Nolist' c DATA ttyin,ttyout/5,6/ DATA referenced /M_sub * .FALSE./ c END c c ---------------------------------------------------------------------------- c SUBROUTINE init IMPLICIT INTEGER*4 (a-z) INCLUDE 'CALLTREE.FTN/Nolist' c CHARACTER outfile*40 c c Set up the run. c WRITE (ttyout,1) READ (ttyin,2) outfile OPEN (Unit=2, File=outfile, Status='NEW', Access='SEQUENTIAL', 1 Carriagecontrol='FORTRAN',err=900) c RETURN 900 WRITE (ttyout,3) outfile STOP 1 1 FORMAT (' CALLTREE V1.0'/' Output file name ? ',$) 2 FORMAT (a) 3 FORMAT (' Can''t open ',a) END c c ---------------------------------------------------------------------------- c SUBROUTINE readem IMPLICIT INTEGER*4 (a-z) INCLUDE 'CALLTREE.FTN/Nolist' CHARACTER char*1,thisname*32,thisarg*64 c c Outer loop on files c 100 WRITE (ttyout,1) READ (ttyin,2,end=999) filename IF (filename .EQ. Blank) GOTO 999 CALL STR$upcase(filename,filename) c c Add extension .LIS if not specified. c rbrak = INDEX(filename,']') + 1 dot = INDEX(filename(rbrak:),'.') IF (dot .EQ. 0) THEN flen = Trulen(filename) filename(flen+1:) = '.LIS' ENDIF c c Open file for processing. c OPEN (Unit=1, File=filename, Status='OLD', Readonly, Err=950) c c Method: c Read file and separate lines into 3 classes as follows: c 1. FORTRAN statements (those with 4 digits in cols 1-4). c a. PROGRAM statement c b. FUNCTION or SUBROUTINE statement c c. All other FORTRAN statements c 2. Function/Subroutine reference statements (follows line containing c string "FUNCTIONS AND SUBROUTINES REFERENCED", ended by a c statement of type 1 above). c 3. All other lines. c part = 1 200 READ (1,2,end=299) line lenline = Trulen(line) IF (lenline .EQ. 0) GOTO 200 CALL STR$upcase(line,line) c c If part = 1, then looking for PROGRAM/FUNCTION/SUBROUTINE statement. c 210 IF (part .EQ. 1) THEN DO c = 1,4 ! Switch to part 2 if not FORTRAN statement char = line(c:c) IF (.NOT. Isdigit(char)) THEN part = 3 GOTO 200 ENDIF ENDDO c c Discard lines beginning with comment chars. Also, strip inline comments. c line = line(9:) char = line(1:1) IF (char .EQ. '*' .OR. char .EQ. 'C' .OR. char .EQ. '!') GOTO 200 excl = INDEX(line,'!') IF (excl .GT. 0) line(excl:) = Blank c c Blank out any portion of line following a single quote, so we don't c have to worry about literals containing keyword strings. c quote = INDEX(line,'''') IF (quote .GT. 0) line(quote:) = Blank c c Finally, look for the keywords 'PROGRAM', 'FUNCTION', and 'SUBROUTINE'. c The name of the function follows. Copy it up to first blank or left paren. c main = .TRUE. found = INDEX(line,'PROGRAM') IF (found .EQ. 0) THEN found = INDEX(line,'FUNCTION') main = .FALSE. ENDIF IF (found .EQ. 0) THEN found = INDEX(line,'SUBROUTINE') main = .FALSE. ENDIF IF (found .EQ. 0) GOTO 200 ! Not a line of interest start = Find_sp(line,found+1) start = Find_nw(line,start+1) send = Find_sp(line,start) paren = INDEX(line,'(') - 1 IF (send*paren .GT. 0) send = MIN(send,paren) IF (send .EQ. 0) send = lenline IF (paren .GT. 0) THEN ! Store args thisarg = line(paren+1:) ELSE thisarg = Blank ENDIF c c Look up name in list so far for insertion. c DO n = 1,nname IF (line(start:send) .EQ. names(n)) GOTO 150 ENDDO nname = nname + 1 n = nname 150 names(n) = line(start:send) IF (thisarg .NE. Blank) args(n) = thisarg file(n) = filename ncall(n) = 0 IF (main) THEN ! Remember where it all starts prog = n referenced(prog) = .TRUE. ENDIF part = 3 ! There can't be any more module = n ! Remember who called GOTO 200 ENDIF c c Now processing rest of listing file. Looking for the key string: c 'FUNCTIONS AND SUBROUTINES REFERENCED'. Following that, there should c be a title line ('Type Name') and then the subprograms called. c DO c = 1,4 ! Switch back to mode 1 (may not be any routines called) IF (.NOT. Isdigit(line(c:c))) GOTO 215 ENDDO part = 1 ! Back to another program GOTO 210 215 IF (part .EQ. 3) THEN IF (line(:36) .EQ. 'FUNCTIONS AND SUBROUTINES REFERENCED') THEN part = 2 GOTO 200 ENDIF ELSE ! We already found key string. Read references c c We will stay in part 2 mode until the next FORTRAN statement is found. c In order for a line to qualify as a reference, however, it must meet c certain criteria. These are: c 1. Must be blank in column 1 c 2. Must not contain any characters c 3. Columns 9-41 (the routine name) must be a valid name c 4. Columns 3-12 do not contain the string "Type Name". c Otherwise, we remain in part 2, but ignore the line. c IF (line(1:1) .NE. Blank .OR. INDEX(line,TAB) .GT. 0 1 .OR. line(3:12) .EQ. 'TYPE NAME') THEN GOTO 200 ENDIF thisname = line(9:41) tlen = Trulen(thisname) DO c = 1,tlen char = thisname(c:c) IF (.NOT. Isdigit(char) .AND. .NOT. Isalpha(char) 1 .AND. char .NE. '_' .AND. char .NE. '$') GOTO 200 ENDDO DO n = 1,nname IF (thisname .EQ. names(n)) GOTO 220 ENDDO nname = nname + 1 n = nname names(n) = thisname 220 ncall(module) = ncall(module) + 1 called(ncall(module),module) = n referenced(n) = .TRUE. ENDIF GOTO 200 c c Go back and do another file. c 299 GOTO 100 c c End of all files. One error possible. c 900 WRITE (ttyout,3) line(start:send) STOP 3 950 WRITE (ttyout,5) filename GOTO 100 999 RETURN c 1 FORMAT (' INPUT>',$) 2 FORMAT (a) 3 FORMAT (1x,a,' ',a) 4 FORMAT (10x,'CALLS ',a) 5 FORMAT (' Unable to open:',a) END c c ---------------------------------------------------------------------------- c SUBROUTINE sortem IMPLICIT INTEGER*4 (a-z) INCLUDE 'CALLTREE.FTN/Nolist' c c Sort each routines references alphabetically. c CHARACTER tref(M_sub)*32 INTEGER*4 tptr(M_sub) c c Loop on each routine. c WRITE (ttyout,1) DO n = 1,nname m = ncall(n) DO c = 1,m ! Build a temporary list for sorting tptr(c) = called(c,n) tref(c) = names(called(c,n)) ENDDO IF (m .GT. 0) CALL chsra2(tref,tptr,m) ! Sort them DO c = 1,m ! Restore sorted pointers called(c,n) = tptr(c) ENDDO ENDDO c RETURN 1 FORMAT (' Sorting...') END c c ---------------------------------------------------------------------------- c SUBROUTINE printem IMPLICIT INTEGER*4 (a-z) INCLUDE 'CALLTREE.FTN/Nolist' c CHARACTER thisarg*64 c c Check if PROGRAM ever found. c IF (prog .LE. 0) GOTO 900 c c Oh, for recursion in FORTRAN! c root = prog ! Header level = 1 indent = 1 subr(level) = root WRITE (2,1) names(root) c 50 nc(level) = ncall(root) ic(level) = 0 100 ic(level) = ic(level) + 1 IF (ic(level) .GT. nc(level)) GOTO 150 c c Go down to another level. c root = called(ic(level),root) level = level + 1 indent = indent + 4 subr(level) = root c line = names(root) lenline = MAX(1,Trulen(line)) filename = file(root) flen = MAX(1,Trulen(filename)) thisarg = args(root) alen = MAX(1,Trulen(thisarg)) c WRITE (2,2,err=299) level,line(:lenline),thisarg(:alen), 1 filename(:flen) GOTO 50 c c End of a level, back up 1. c 150 level = level - 1 IF (level .LE. 0) GOTO 200 ! Done indent = indent - 4 root = subr(level) GOTO 100 c c Finished c 200 RETURN 299 WRITE (6,4) level,lenline,alen,flen WRITE (6,5) line(:lenline) WRITE (6,5) thisarg(:alen) WRITE (6,5) filename(:flen) c 900 WRITE (ttyout,3) STOP 5 c 1 FORMAT (' Call tree for program ',a) 2 FORMAT (1x,i3,('.'),a,1x,a,' <',a,'>') 3 FORMAT (' No PROGRAM statement found!!') 4 FORMAT (' WRITE error, lens are:',3i10) 5 FORMAT (' <',a,'>') END c c ---------------------------------------------------------------------------- c SUBROUTINE listem IMPLICIT INTEGER*4 (a-z) INCLUDE 'CALLTREE.FTN/Nolist' c CHARACTER last*40,sortrec(M_sub)*137,thisfile*40,thisname*32,ref$*1 CHARACTER thisarg*64 LOGICAL undef c c Build sort records. c DO n = 1,nname ! Build pointers for sorting IF (referenced(n)) THEN sortrec(n) = file(n) // names(n) // 'T' // args(n) ELSE sortrec(n) = file(n) // names(n) // 'F' // args(n) ENDIF ENDDO CALL chsra1(sortrec,nname) ! Sort them c c Print by file name. c i = 1 last = sortrec(1)(:40) sortrec(nname+1) = '%%%%%%%%%%%%%' WRITE (2,1) 100 IF (i .GT. nname) RETURN thisfile = sortrec(i)(:40) thisname = sortrec(i)(41:72) tlen = MAX(1,Trulen(thisname)) ref$ = sortrec(i)(73:73) thisarg = sortrec(i)(74:) alen = MAX(1,Trulen(thisarg)) flen = MAX(1,Trulen(thisfile)) WRITE (2,2) thisfile(:flen) c c If first file is null, then it contains undefined references. c These will be flagged if the contain a "$" as probable system routines. c IF (.NOT. Isdigit(thisfile(1:1)) .AND. 1 .NOT. Isalpha(thisfile(1:1))) THEN undef = .TRUE. ELSE undef = .FALSE. ENDIF c c All belong to this file until file name changes. c DO WHILE (last .EQ. thisfile) IF (ref$ .EQ. 'T') THEN IF (undef .AND. INDEX(thisname,'$') .GT. 0) THEN WRITE (2,5) thisname(:tlen),thisarg(:alen) ELSE WRITE (2,3) thisname(:tlen),thisarg(:alen) ENDIF ELSE WRITE (2,4) thisname(:tlen),thisarg(:alen) ENDIF i = i + 1 thisfile = sortrec(i)(:40) thisname = sortrec(i)(41:72) tlen = MAX(1,Trulen(thisname)) ref$ = sortrec(i)(73:) thisarg = sortrec(i)(74:) alen = MAX(1,Trulen(thisarg)) ENDDO last = thisfile GOTO 100 c 1 FORMAT ('1LISTING OF ROUTINES IN EACH FILE'//) 2 FORMAT ('0FILE<',a,'> CONTAINS ROUTINES:') 3 FORMAT (8x,a,1x,a) 4 FORMAT (8x,a,1x,a,' (unreferenced)') 5 FORMAT (8x,a,1x,a,' (system ?)') END