******************************************************************************* * * RENUM * * A program for renumbering the statements in Fortran programs. * * March 1986, John Kodis * ******************************************************************************* program renum logical & at end, & eof, & usebuf integer & i, & parlvl, & strip, & posc, posl, & statmc, statml, & wherec, wherel integer*4 & j, & label, & newlab, & skip character & infile*26, & outfil*26, & tmp*149 include 'rencom' logical ! function & blank, & contin, & find, & gotnum, & matchd, & numbr2, & tab integer ! function & numsiz integer*4 ! function & lookup skip = 0 call get2fn(infile, outfil) if (index(infile, '.') .eq. 0) & infile(index(infile, ' '):) = '.FTN' if (index(outfil, '.') .eq. 0) & outfil(index(outfil, ' '):) = infile(index(infile, '.'):) open(1, file=infile, status='old', err=130, & readonly, shared ) open(2, file=outfil, status='new', err=140, & carriagecontrol='list' ) * Build a symbol table of all labels. 10 laslab = 0 usebuf = skip .gt. 0 20 call filbuf(usebuf, atend, eof) usebuf = .TRUE. if (gotnum(1, 1, 5, label, strip)) then laslab = laslab + 1 if (laslab .le. MAXLAB) then labels(laslab) = label else write(5, '('' **** Error -- too many labels.'')') go to 150 end if end if if (.not. AtEnd) go to 20 * Time for pass two. Rewind the file, skip records up to the * start of the next subprogram to be renumbered, and start * looking for statement labels to be replaced. rewind(1) do 30, j = 1, skip 30 read(1, '(a)') tmp usebuf = .FALSE. 40 call filbuf(usebuf, atend, eof) usebuf = .TRUE. skip = skip + laslin * To speed up the program, make a quick test for empty lines, * blank lines, and comment lines. If the current statement * falls one of these catagories, skip the following tests and * just write the statement out as it stands. if ((linlen(1) .eq. 0) .or. & (buf(1) .eq. ' ') .or. & (index('Cc*!', buf(1)(1:1)) .ne. 0) ) go to 110 * Try to replace the statement label. Set STATMC to the first * position after the label, or to 1 if there is no statement * label. 50 statmc = 1 statml = 1 if (gotnum(1, statml, 5, label, strip)) then statmc = 7 60 if (strip.lt.5 .and. buf(1)(strip+1:strip+1).eq.' ') then strip = strip + 1 go to 60 end if newlab = lookup(label) write(tmp, '(i5, a)') newlab, buf(1)(strip+1:linlen(1)) linlen(1) = 5 + linlen(1) - strip buf(1) = tmp end if * Look for an "if" statement. If found, set STATMC to the * first character after the closing parenthisis. 70 if (matchd(statmc, statml, 'if(', 3, posc, posl)) then * Skip past the expression following the "if". parlvl = 1 80 if (parlvl .gt. 0) then if (buf(posl)(posc:posc) .eq. '(' ) parlvl = parlvl + 1 if (buf(posl)(posc:posc) .eq. ')' ) parlvl = parlvl - 1 call incr(posc, posl) call skipbl(posc, posl) go to 80 end if statmc = posc statml = posl * If this is an arithmatic if statement, try to replace each * of the three required statement labels which follow the "if". 90 if (gotnum(posc, posl, linlen(posl), label, strip)) then newlab = lookup(label) write(tmp, '(a, i, a)') & buf(posl)( : posc-1), & newlab, & buf(posl)(posc+strip : ) linlen(posl) = numsiz(newlab) + linlen(posl) - strip buf(posl) = tmp posc = posc + numsiz(newlab) if (matchd(posc, posl, ',', 1, posc, posl)) go to 90 end if go to 70 end if ! Done processing "if" statements. * Try to replace any statement labels in a "do" statement. if (matchd(statmc, statml, 'do', 2, wherec, wherel)) then call renumb(wherec, wherel) go to 110 end if * Try to replace statement labels in "goto 9999" and * "goto (9990,9991,...,9999), exp" type statements. if (matchd(statmc, statml, 'goto', 4, wherec, wherel)) then call renumb(wherec, wherel) 100 if (matchd(wherec, wherel, '(', 1, posc, posl)) then if (gotnum(posc,posl, linlen(posl), label, strip)) then newlab = lookup(label) write(tmp, '(a, i, a)') & buf(posl)(:posc-1), & newlab, & buf(posl)(posc+strip:linlen(posl)) linlen(posl) = numsiz(newlab) + linlen(posl) - strip buf(posl) = tmp posc = posc + numsiz(newlab) end if call matchd(posc, posl, ',', 1, posc, posl) go to 100 end if go to 110 end if * Try to replace statement labels of format statements, "fmt=" * statements, "err=" statements, and "end=" statements in I/O * and encode/decode statements. if (matchd(statmc, statml, 'write(', 6, wherec, wherel)) then if (numbr2(wherec, wherel, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'fmt=', 4, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'rewrite(', 8, wherec,wherel)) then if (numbr2(wherec, wherel, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'fmt=', 4, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'type', 4, wherec,wherel)) then call renumb(wherec, wherel) else if (matchd(statmc,statml, 'print', 5, wherec,wherel)) then call renumb(wherec, wherel) else if (matchd(statmc,statml, 'read(', 5, wherec,wherel)) then if (numbr2(wherec, wherel, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'fmt=', 4, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'end=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'accept', 6, wherec,wherel)) then call renumb(wherec, wherel) else if (matchd(statmc,statml, 'open(', 5, wherec,wherel)) then if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'close(', 6, wherec,wherel)) then if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'rewind(', 7, wherec,wherel)) then if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml,'backspace(',10,wherec,wherel)) then if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'delete(', 7, wherec,wherel)) then if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'unlock(', 7, wherec,wherel)) then if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'endfile(', 8, wherec,wherel)) then if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'encode(', 7, wherec,wherel)) then if (numbr2(wherec, wherel, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) else if (matchd(statmc,statml, 'decode(', 7, wherec,wherel)) then if (numbr2(wherec, wherel, posc, posl)) & call renumb(posc, posl) if (find(wherec, wherel, 'err=', 4, posc, posl)) & call renumb(posc, posl) end if 110 do 120, i = 1, laslin write(2, '(a)') buf(i)(1:linlen(i)) 120 continue if (linlen(1) .gt. 132) & write(5, '(a)') & ' **** Warning -- previous line exceeds 132 characters.' if (.not. AtEnd) go to 40 if (.not. eof) go to 10 go to 150 130 write(5, '(a, a, a)') & ' **** Error -- can''t open input file "', infile, '".' go to 150 140 write(5, '(a, a, a)') & ' **** Error -- can''t open output file "', outfil, '".' 150 close(2) close(1) end ******************************************************************************** * * FIL BUF * * Used to read one statement (which may be continued on more * than one line) into the statement buffer, BUF. The * paramater ENDST indicates whether the current line is an END * statement, and the parameter EOF indicates whether the end * of the input file has been reached. Also, EOF implies * ENDST. The parameter USEBUF, when true, indicates that the * first line of the statement to be read in is already in BUF * at BUF(LASLIN+1). When the parameter USEBUF is false the * first line of the statement will be read from the input * file. This is necessary because the only way to know * whether the last line of a statement has been read in is to * keep reading lines until there are no more continuation * lines. * ******************************************************************************** subroutine filbuf(usebuf, endst, eof) integer & i, & junk logical & endst, & eof, & usebuf include 'rencom' logical ! functions & atend, & contin if (.not. usebuf) then read(1, '(q, a)', err=20, end=30) linlen(1), buf(1) else buf(1) = buf(laslin+1) linlen(1) = linlen(laslin+1) endif laslin = 1 10 read(1, '(q, a)', err=20, end=30) linlen(laslin+1), buf(laslin+1) if (contin(laslin+1, junk)) then laslin = laslin + 1 go to 10 end if eof = .FALSE. endst = atend() return 20 write(5, '('' **** Error -- can''''t read from input file.'')') 30 eof = .TRUE. endst = .TRUE. return end ******************************************************************************** * * GOTNUM * * GOTNUM tests for a statement label starting on line FROML, * column FROMC, and continuing for TO characters. If a label * is found in this range of characters, GOTNUM will return the value * .TRUE., the numeric value of the label will be returned in * LABEL, and STRIP will be set to the number of characters * between the first and last digits in the label. Otherwise * GOTNUM will return the value .FALSE., and LABEL and STRIP will be * undefined. * ******************************************************************************** logical function gotnum(fromc, froml, to, label, strip) character & c integer & digit, & fromc, & froml, & i, & strip, & to integer*4 & label logical ! function & blank include 'rencom' label = 0 i = 0 10 c = buf(froml)(fromc+i : fromc+i) digit = index('0123456789', c) if ((digit .ne. 0) .or. blank(c)) then if (digit .ne. 0) then label = label*10 + digit - 1 strip = i + 1 end if i = i + 1 if (fromc+i .le. to) go to 10 end if gotnum = label .gt. 0 return end ******************************************************************************** * * MATCHD * * If the next KEYLEN non-blank characters from line FROML, * column FROMC match the string specified in KEY, then * MATCHD will return the value .TRUE., and NEXTL and NEXTC * will be set to the first non-blank character following the * specified key. Otherwise, MATCHD will be .FALSE., and NEXTL * and NEXTC will be undefined. * ******************************************************************************** logical function matchd(fromc, froml, key, keylen, nextc, nextl) integer & fromc, & froml, & keychr, & keylen, & nextc, & nextl character & key*10 logical ! function & blank, & chareq include 'rencom' keychr = 1 nextc = fromc nextl = froml 10 call skipbl(nextc, nextl) if (keychr .gt. keylen) then matchd = .TRUE. else if (.not. chareq(key(keychr:keychr), & buf(nextl)(nextc:nextc) )) then matchd = .FALSE. else call incr(nextc, nextl) keychr = keychr + 1 go to 10 end if return end ******************************************************************************** * * FIND * * If the string specified in KEY occurs anywhere in the * portion of the current statement which comes after column * FROMC on line FROML, then FIND will return the value * .TRUE., and PASTL and PASTC will be set to the first * non-blank character following the specified key. Otherwise, * FIND will be .FALSE., and PASTL and PASTC will be * undefined. * ******************************************************************************** logical function find(fromc, froml, key, keylen, pastc, pastl) integer & fromc, & froml, & keychr, & keylen, & nextc, & nextl, & pastc, & pastl character & key*20 include 'rencom' logical ! function & blank, & chareq keychr = 1 nextc = fromc nextl = froml pastc = nextc pastl = nextl 10 call skipbl(pastc, pastl) if (keychr .gt. keylen) then find = .TRUE. else if (buf(pastl)(pastc:pastc) .eq. ' ') then find = .FALSE. else if (chareq(key(keychr:keychr), buf(pastl)(pastc:pastc))) then call incr(pastc, pastl) keychr = keychr + 1 go to 10 else call incr(nextc, nextl) call skipbl(nextc, nextl) pastc = nextc pastl = nextl keychr = 1 go to 10 end if return end ******************************************************************************** * * NUMBR 2 * * Used to test for the occurance of two numbers seperated by a * comma beginning at line FROML, column FROMC. If found, * NUMBR2 will return the value .TRUE., and NEXTL and NEXTC will be * set to the location of the first digit of the second number. * Otherwise, NUMBR2 will be .FALSE., and NEXTL and * NEXTC will be undefined. * ******************************************************************************** logical function numbr2(fromc, froml, nextc, nextl) integer & fromc, & froml, & nextc, & nextl include 'rencom' logical ! function & blank nextc = fromc nextl = froml 10 call skipbl(nextc, nextl) if (index('0123456789', buf(nextl)(nextc:nextc)) .eq. 0) then numbr2 = .FALSE. else 20 if (index(' 0123456789', buf(nextl)(nextc:nextc)) .ne. 0) then call incr(nextc, nextl) go to 20 end if if (buf(nextl)(nextc:nextc) .ne. ',') then numbr2 = .FALSE. else call incr(nextc, nextl) 30 if (blank(buf(nextl)(nextc:nextc))) then call incr(nextc, nextl) call skipbl(nextc, nextl) go to 30 end if numbr2 = index('0123456789',buf(nextl)(nextc:nextc)).ne.0 end if end if return end ******************************************************************************** * * CONTIN * * Used to determine where the statement portion of a line * begins. POS will be set either to column one, or to the * first column after the continuation character if the line * specified is a continuation line. GOTCON is set to .TRUE. * if the specified line is a continuation line, and set * .FALSE. otherwise. * ******************************************************************************** logical function contin(line, pos) integer & line, & pos include 'rencom' logical ! functions & blank, & tab pos = 1 contin = .FALSE. if ((buf(line)(1:5) .eq. ' ') .and. & (buf(line)(6:6) .ne. '0') .and. & (.not. blank(buf(line)(6:6))) ) then pos = 7 contin = .TRUE. else if ((tab(buf(line)(1:1))) .and. & (index('123456789', buf(line)(2:2)) .ne. 0) ) then pos = 3 contin = .TRUE. endif end if return end ******************************************************************************** * * AT END * * Returns .TRUE. if the current line is an "END" statement. * Returns .FALSE. otherwise. * ******************************************************************************** logical function at end integer & col, & nextc, & nextl logical & match include 'rencom' logical ! function & blank, & matchd col = 1 10 if ((col .le. 5) .and. & (index(' 0123456789', buf(1)(col:col)) .gt. 0) ) then col = col + 1 go to 10 end if match = matchd(min(col, linlen(1)), 1, 'end', 3, nextc, nextl) atend = match .and. blank(buf(nextl)(nextc:nextc)) return end ******************************************************************************** * * RENUMB * * If a number is at the passed line and column position, it * will be replaced with its new statement number equivalent. * Otherwise, no action is taken. * ******************************************************************************** subroutine renumb(fromc, froml) integer & fromc, & froml, & strip integer*4 & label, & newlab character & tmp*149 include 'rencom' logical ! function & gotnum integer ! functions & numsiz integer*4 ! functions & lookup if (gotnum(fromc, froml, linlen(froml), label, strip)) then newlab = lookup(label) write(tmp, '(a, i, a)') & buf(froml)(:fromc-1), & newlab, & buf(froml)(fromc+strip:linlen(froml)) linlen(froml) = numsiz(newlab) + linlen(froml) - strip buf(froml) = tmp end if return end ******************************************************************************** * * LOOKUP * * LOOKUP will search through the statement label table for the * label passed to it. If found, the label's position in the * table will be used to compute a new label value. Otherwise, * the label value -9999 is returned, and an error message is * written out. * ******************************************************************************** integer*4 function lookup(label) integer & i integer*4 & label include 'rencom' do 10, i = 1, laslab if (label .eq. labels(i)) then lookup = i * 10 return end if 10 continue write(5, '(a, i6)') & ' **** Error -- no such label:', label lookup = -9999 return end ******************************************************************************** * * INCR * * Sets line and column variables L and C to the position of * the next character. If the column position is already at the end * of the line, L and C will be set to the first statement * character in the next line. * ******************************************************************************** subroutine incr(c, l) integer & c, & l include 'rencom' if (c .le. linlen(l)) then c = c + 1 if ((c .gt. linlen(l)) .and. (l .lt. laslin)) then l = l + 1 call contin(l, c) end if end if return end ******************************************************************************** * * SKIP BL * * Sets the line and column positions to the first non-blank * character at or beyond the current position. Since text * contained in comments and character strings should not be * renumbered, aphostrophe-delimited comments and character * strings are treated by this routine as if they were * sequences of blank space. * ******************************************************************************** subroutine skipbl(col, lin) integer & col, & lin character & ch logical & inchar logical ! function & blank include 'rencom' inchar = .FALSE. 10 if ((col .le. linlen(lin)) .or. (lin .lt. laslin)) then ch = buf(lin)(col:col) if (blank(ch)) then call incr(col, lin) go to 10 else if (ch .eq. '''') then inchar = .not. inchar call incr(col, lin) go to 10 else if (inchar) then call incr(col, lin) go to 10 else if ((.not. inchar) .and. (ch .eq. '!')) then col = linlen(lin) call incr(col, lin) go to 10 end if end if return end ******************************************************************************** * * NUM SIZ * * Returns the number of characters needed to represent a * number in the range of 1 through 99999. Returns 8 if passed * a value outside of this range. * ******************************************************************************** integer function numsiz(n) integer n if (n .le. 0) then numsiz = 8 else if (n .le. 9) then numsiz = 1 else if (n .le. 99) then numsiz = 2 else if (n .le. 999) then numsiz = 3 else if (n .le. 9999) then numsiz = 4 else numsiz = 5 end if return end ******************************************************************************** * * TAB * * Returns .TRUE. if passed an ASCII tab character. * Returns .FALSE. otherwise. * ******************************************************************************** logical function tab(char) character & char tab = ichar(char) .eq. 9 return end ******************************************************************************** * * BLANK * * Returns .TRUE. if passed a space character or an ASCII tab * character. Returns .FALSE. otherwise. * ******************************************************************************** logical function blank(char) character & char logical ! function & tab blank = ((char .eq. ' ') .or. (tab(char))) return end ******************************************************************************** * * CHAR EQ * * Returns .TRUE. if passed two characters which are the same * or which represent the same letter (e.g., chareq('A', 'a') * returns .TRUE.). Returns .FALSE. otherwise. * ******************************************************************************** logical function chareq(char1, char2) character & char1, & char2 integer ! function & ilower chareq = ilower(char1) .eq. ilower(char2) return end ******************************************************************************** * * ILOWER * * Returns the integer value of the lower case version of the * character which is passed. * ******************************************************************************** integer function ilower(c) character & c if ((ichar(c).lt.ichar('A')) .or. (ichar(c).gt.ichar('Z'))) then ilower = ichar(c) else ilower = ichar(c) - ichar('A') + ichar('a') end if return end ******************************************************************************** * * GET 2 FN * * Gets one or two filenames. If a command line is present, * the filenames are read from it. Otherwise, they are read * from the console. In either case, if oney one filename is * available, the second filename will be set to be the same as * the first filename. * ******************************************************************************** subroutine get2fn(fn1, fn2) character & buf*255, & fn1*26, & fn2*26 integer & i, & linlen, & parm(41), & parms call getmcr(buf, linlen) * call lib$get_foreign(%descr(buf), , linlen) if ((linlen .le. 0) .or. (index(buf(:linlen), ' ') .eq. 0)) then write(5, '('' File? '', $)') read (5, '(q, a)', end=40) linlen, buf(2:) buf(1:1) = ' ' linlen = linlen + 1 end if i = 1 parms = 0 10 if (i .lt. linlen) then 20 if (i .le. linlen .and. buf(i:i) .ne. ' ') then i = i + 1 go to 20 end if 30 if (i .le. linlen .and. buf(i:i) .eq. ' ') then i = i + 1 go to 30 end if if (i .le. linlen) then parms = parms + 1 parm(parms) = i parm(parms+1) = linlen + 1 end if go to 10 end if fn1 = buf(parm(1):parm(2)-1) if (parms .eq. 1) then fn2 = fn1 else fn2 = buf(parm(2):parm(3)-1) end if return 40 call exit end