# ARCHIVE RATFIV.HDR 51 27-DEC-81 22:35:41 # # # # RATFIV structured Fortran compiler # ================================== # # Authors: Original by B. Kernighan and P. J. Plauger, # with rewrites and enhancements by David Hanson and # friends (U. of Arizona), Joe Sventek and Debbie # Scherrer (Lawrence Berkely Laboratory), and # William P. Wood, Jr. (Institute For Cancer Research). # # Address: William P. Wood, Jr. # Computer Center # Institute For Cancer Research # 7701 Burholme Ave. # Philadelphia, Pa. 19111 # (215) 728 2760 # # Version: 2.0 # # Date: December 27, 1981 # # # # ******************************************************* # * * # * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * # * FROM THE NATIONAL INSTITUTES OF HEALTH: * # * NIH CA06927 * # * NIH CA22780 * # * * # * DIRECT INQUIRIES TO: * # * COMPUTER CENTER * # * THE INSTITUTE FOR CANCER RESEARCH * # * 7701 BURHOLME AVENUE * # * PHILADELPHIA, PENNSYLVANIA 19111 * # * * # * NO WARRANTY OR REPRESENTATION, EXPRESS OR * # * IMPLIED, IS MADE WITH RESPECT TO THE * # * CORRECTNESS, COMPLETENESS, OR USEFULNESS * # * OF THIS SOFTWARE, NOR THAT USE OF THIS * # * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * # * OWNED RIGHTS. * # * * # * NO LIABILITY IS ASSUMED WITH RESPECT TO * # * THE USE OF, OR FOR DAMAGES RESULTING FROM * # * THE USE OF THIS SOFTWARE * # * * # ******************************************************* # # ARCHIVE ADDCHR.RAT 11 30-NOV-81 14:23:57 # addchr - put c in buf(bp) if it fits, increment bp subroutine addchr(c, buf, bp, maxsiz) integer bp, maxsiz character c, buf(ARB) if (bp > maxsiz) call fatal("string buffer overflow.") buf(bp) = c bp = bp + 1 return end # ARCHIVE ADDSTR.RAT 10 30-NOV-81 14:23:57 # addstr - put s in buf(bp) by repeated calls to addchr subroutine addstr(s, buf, bp, maxsiz) character s(ARB), buf(ARB) integer bp, maxsiz integer i for (i = 1; s(i) != EOS; i=i+1) call addchr(s(i), buf, bp, maxsiz) return end # ARCHIVE BALPAR.RAT 34 30-NOV-81 14:23:57 # balpar - copy balanced paren string subroutine balpar character gettok character t, token(MAXTOK) integer nlpar if (gettok(token, MAXTOK) != LPAREN) { call synerr('missing left paren.') return } call outstr(token) nlpar = 1 repeat { t = gettok(token, MAXTOK) if (t == SEMICOL | t == EOF | t == RBRACK | t == LBRACK | (t < 0 & t != ALPHA)) { call pbstr(token) break } if (t == NEWLINE) # delete newlines token(1) = EOS else if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 # else nothing special call outstr(token) if (t == COMMA) call outch(BLANK) } until (nlpar <= 0) if (nlpar != 0) call synerr('missing parenthesis in condition.') return end # ARCHIVE BRKNXT.RAT 35 30-NOV-81 14:23:57 # brknxt - generate code for break n and next n; n = 1 is default subroutine brknxt(sp, lextyp, labval, token) integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token integer i, n, alldig, ctoi character t, ptoken(MAXTOK), gettok n = 0 t = gettok(ptoken, MAXTOK) if (alldig(ptoken) == YES) { # have break n or next n i = 1 n = ctoi(ptoken, i) - 1 } else if (t != SEMICOL) # default case call pbstr(ptoken) for (i = sp; i > 0; i = i - 1) if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) { if (n > 0) { n = n - 1 next # seek proper level } if (token == LEXBREAK) { labval(i) = abs(labval(i)) # output break label call outgo(labval(i)+10, YES) } else call outgo(abs(labval(i)), YES) return } if (token == LEXBREAK) call synerr("illegal break.") else call synerr("illegal next.") return end # ARCHIVE CASCOD.RAT 60 30-NOV-81 14:23:58 # switch statement - routines involved are cascod, caslab, swcode, swend, swvar # cascod - generate code for case or default label subroutine cascod(lab, token) integer lab, token, l, lb, ub, i, j, labgen character tok(MAXTOK), t, gettok, caslab include cswtch if (swtop <= 0) { call synerr("illegal case or default.") return } call outgo(lab+10, YES) # terminate previous case l = labgen(1) if (token == LEXCASE) { # case n[,n]... : ... while (caslab(lb, t) != EOF) { ub = lb if (t == MINUS) junk = caslab(ub, t) if (lb > ub) { call synerr("illegal range in case label.") ub = lb } if (swlast + 3 > MAXSWITCH) call fatal("switch table overflow.") for (i = swtop + 3; i < swlast; i = i + 3) if (lb <= swstak(i)) break else if (lb <= swstak(i+1)) call synerr("duplicate case label.") if (i < swlast & ub >= swstak(i)) call synerr("duplicate case label.") for (j = swlast; j > i; j = j - 1) # insert new entry swstak(j+2) = swstak(j-1) swstak(i) = lb swstak(i+1) = ub swstak(i+2) = l swstak(swtop+1) = swstak(swtop+1) + 1 swlast = swlast + 3 if (t != COMMA) break } } else { # default : ... t = gettok(tok, MAXTOK) if (swstak(swtop+2) != 0) call synerr("multiple defaults in switch statement.") else swstak(swtop+2) = l } if (t == EOF) call putbak(EOF) else if (t != COLON) call synerr("missing colon in case or default label.") call outden(2) call outcon(l) call inden(2) return end # ARCHIVE CASLAB.RAT 33 30-NOV-81 14:23:58 # caslab - get one case label character function caslab(n, t) integer n, i, s character t, tok(MAXTOK), gettok, gtsknl, esc integer ctoi, alldig, elenth t = gtsknl(tok, MAXTOK) if (t == EOF) { caslab = t return } if (t == MINUS) s = -1 else s = +1 if (t == MINUS | t == PLUS) t = gettok(tok, MAXTOK) if (alldig(tok) == YES) { i = 1 n = s*ctoi(tok, i) } else if (isquote(t) & elenth(tok) == 3) { # character constant i = 2 n = esc(tok, i) } else { call synerr("invalid case label.") n = 0 } t = gtsknl(tok, MAXTOK) caslab = t return end # ARCHIVE DFUNCT.RAT 16 30-NOV-81 14:23:58 # dfunct - define the current function name subroutine dfunct include cfname character t, gettok string funct "function" t = gettok(fcname, MAXNAME) call pbstr(fcname) call otherc(funct) if (t != ALPHA) { call errlin(fcname) call synerr("bad function name.") fcname(1) = EOS } return end # ARCHIVE DOBASE.RAT 24 30-NOV-81 14:23:58 # dobase - convert number in base to decimal subroutine dobase(base, token, toksiz, i) integer base, toksiz, i, n, cn, itoc character token(ARB), c, ngetch, cupper if (base > 1 & base <= 36) { # got one for (n = 0 ; ; n = base*n + cn) { c = cupper(ngetch(c)) if (c >= BIGA & c <= BIGZ) cn = c - BIGA + 10 else if (c >= DIG0 & c <= DIG9) cn = c - DIG0 else break if (cn >= base) call synerr("digit inconsistent with base.") } call putbak(c) i = itoc(n, token, toksiz) } else call synerr("number base out of range.") return end # ARCHIVE DOCODE.RAT 18 30-NOV-81 14:23:59 # docode - generate code for beginning of do subroutine docode(lab) integer labgen integer lab include cgoto string dostr 'do ' xfer = NO call outtab call outstr(dostr) lab = labgen(2) call outnum(lab) call outch(BLANK) call eatup call inden(2) lab = -lab return end # ARCHIVE DOSTAT.RAT 10 30-NOV-81 14:23:59 # dostat - generate code for end of do statement subroutine dostat(lab) integer lab call outden(2) call outcon(abs(lab)) if (lab > 0) # break seen call outcon(lab+10) return end # ARCHIVE EATUP.RAT 51 30-NOV-81 14:23:59 # eatup - process rest of statement subroutine eatup character gettok, type character ptoken(MAXTOK), t, token(MAXTOK) integer nlpar, length include coutln nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == SEMICOL | t == NEWLINE) break else if (t == RBRACK | t == LBRACK | (t < 0 & t != ALPHA)) { call pbstr(token) break } if (t == EOF) { call synerr('unexpected EOF.') call pbstr(token) break } if (t == COMMA | t == PLUS | t == MINUS | t == STAR | t == LPAREN | t == AND | t == BAR | t == BANG | t == EQUALS | t == TILDE | t == CARET | t == GREATER | t == LESS | t == BACKSLASH) { while (gettok(ptoken, MAXTOK) == NEWLINE) ; call pbstr(ptoken) } if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == PLUS | t == MINUS | token(1) == EQUALS) { call outch(BLANK); call outstr(token); call outch(BLANK) } else if ((t == ALPHA) & (type(outbuf(outp)) == LETTER)) { call outch(BLANK); call outstr(token) } else if (t == COMMA) { call outstr(token); call outstr(BLANK) } else call outstr(token) } until (nlpar < 0) if (nlpar != 0) call synerr('unbalanced parentheses.') if (t != LEXFUNCTION) call outdon else call outch(BLANK) return end # ARCHIVE ELENTH.RAT 18 16-DEC-81 23:13:26 # calculate length of buf, taking quotes and escaped characters into account # two quotes in a row in a quoted string count as one integer function elenth(buf) character buf(ARB), c character esc, nqc integer i, n if (isquote(buf(1))) n = 1 else n = 0 for (i = n+1; buf(i) != EOS; i = i+1) { c = nqc(buf, i, buf(1), c) c = esc(buf, i) n = n+1 } return (n) end # ARCHIVE ELSEF.RAT 26 30-NOV-81 14:24:00 # elsef - generate code for end of if before else subroutine elsef(endlab, elslab, elstyp) integer endlab, elslab, elstyp include cflags include cgoto string elses "else" if (f77) { call outden(2) call outtab call outstr(elses) if (elstyp == LEXELSEIF) call outch(BLANK) else call outdon } else { call outgo(endlab, YES) call outden(2) call outcon(elslab) } if (elstyp == LEXELSE) call inden(2) xfer = NO return end # ARCHIVE FCLAUS.RAT 33 30-NOV-81 14:24:00 # process "for" init or re-init clause subroutine fclaus character gettok character token(MAXTOK), t integer brack if (gettok(token, MAXTOK) == LBRACK) # { mother } brack = YES else { call pbstr(token) brack = NO # other } repeat { t = gettok(token, MAXTOK) if (t == RBRACK & brack == YES) { if (gettok(token, MAXTOK) != SEMICOL) { call synerr("invalid for clause.") call pbstr(token) } break } if (t == EOF) { call pbstr(token) call synerr("unexpected EOF.") break } if (t != SEMICOL) call otherc(token) } until (brack == NO) return end # ARCHIVE FORCOD.RAT 109 30-NOV-81 14:24:00 # forcod - beginning of for statement subroutine forcod(lab) character gettok character t, token(MAXTOK) integer length, labgen integer i, j, lab, nlpar logical emptyc # .true. if condition part is empty include cfor include cflags string ifnot "if (.not." string whiles "do while " string trues "(.true.)" emptyc = .false. lab = labgen(3) call outcon(0) if (gettok(token, MAXTOK) != LPAREN) { call synerr('missing left paren.') return } if (gettok(token, MAXTOK) != SEMICOL) { # real init clause call pbstr(token) call fclaus } if (gettok(token, MAXTOK) == SEMICOL) { # empty condition emptyc = .true. if (f77) { call outtab call outstr(whiles) call outstr(trues) call outdon } else call outcon(lab) } else { # non-empty condition call pbstr(token) if (f77) { call outtab call outstr(whiles) } else { call outnum(lab) call outtab call outstr(ifnot) } call outch(LPAREN) nlpar = 0 while (nlpar >= 0) { t = gettok(token, MAXTOK) if (t == SEMICOL) break if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == EOF) { call pbstr(token) return } if (t != NEWLINE) call outstr(token) } call outch(RPAREN) if (f77) call outdon else { call outch(RPAREN) call outch(BLANK) call outgo(lab+20, NO) } if (nlpar < 0) call synerr('invalid for clause.') } fordep = fordep + 1 # stack reinit clause j = 1 for (i = 1; i < fordep; i = i + 1) # find end j = j + length(forstk(j)) + 1 forstk(j) = EOS # null, in case no reinit nlpar = 0 while (nlpar >= 0) { t = gettok(token, MAXTOK) if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == EOF) { call pbstr(token) break } if (nlpar >= 0 & t != NEWLINE) { if (t == PLUS | t == MINUS | token(1) == EQUALS) { token(1) = BLANK; token(2) = t; token(3) = BLANK; token(4) = EOS } else if (t == COMMA) { token(2) = BLANK; token(3) = EOS } if (j + length(token) >= MAXFORSTK) call fatal('for clause too long.') call scopy(token, 1, forstk, j) j = j + length(token) } } call inden(2) lab = lab + 10 # label for next's if (f77 | emptyc) lab = -lab return end # ARCHIVE FORMA.RAT 81 30-NOV-81 14:24:00 # forma - output format statement for write, read, encode, and decode subroutine forma(token) character token(ARB), t, tok(MAXTOK), forst(MAXFORMAT) character gettok, gtsknl integer j, length, labgen, lab include cflags string form "format" call outtab call outstr(token) t = gettok(tok, MAXTOK) if (t != LPAREN) { call pbstr(tok) call eatup return } call outstr(tok) call skpout(t) if (t == EOF) return if (t == RPAREN) { call eatup return } t = gtsknl(tok, MAXTOK) if (t != LPAREN) { call pbstr(tok) repeat { call skpout(t) if (t == EOF) return } until (t == RPAREN) call eatup } else { lab = labgen(1) call outnum(lab) j = 1 forst(1) = EOS nlpar = 0 inform = .true. #don't convert < and > to .lt. and .gt. repeat { t = gettok(tok, MAXTOK) if (t == EOF) { call pbstr(tok) call synerr('unexpected EOF.') inform = .false. return } if (t == LPAREN) nlpar = nlpar+1 else if (t == RPAREN) nlpar = nlpar-1 if (nlpar >= 0 & t != NEWLINE) { if (j + length(tok) >= MAXFORMAT) { call synerr('format too long.') break } call scopy(tok, 1, forst, j) j = j + length(tok) } } until (nlpar < 0) inform = .false. repeat { call skpout(t) if (t == EOF) return } until (t == RPAREN) call eatup call inden(2) call outnum(lab) call outtab call outstr(form) call outch(LPAREN) call outstr(forst) call outch(RPAREN) call outdon call outden(2) } return end # ARCHIVE FORS.RAT 34 30-NOV-81 14:24:01 # fors - process end of for statement subroutine fors(lab) integer length integer i, j, lab include cfor include cgoto include cflags string enddos "end do" xfer = NO j = 1 for (i = 1; i < fordep; i = i + 1) j = j + length(forstk(j)) + 1 call outnum(abs(lab)) if (length(forstk(j)) > 0) { call putbak(SEMICOL) call pbstr(forstk(j)) call fclaus } else if (f77) call outcon(0) call outden(2) if (f77) { call outtab call outstr(enddos) call outdon } else call outgo(abs(lab)-10, YES) if (lab > 0) call outcon(lab+10) fordep = fordep - 1 return end # ARCHIVE GETTOK.RAT 10 30-NOV-81 14:24:01 # gettok - get token after processing by deftok character function gettok(token, toksiz) character token(ARB), deftok integer toksiz repeat gettok = deftok(token, toksiz) until (gettok != BLANK & gettok != TAB) return end # ARCHIVE GTOKENR.RAT 121 15-DEC-81 23:44:58 # gtoken - get token for Ratfiv character function gtoken(token, toksiz) character ngetch, type integer i, toksiz, j, ctoi, alldig character c, token(ARB) include cmacro string toolng "token too long." for (i = 1; i <= toksiz; i = i + 1) { gtoken = type(ngetch(token(i))) if (gtoken != LETTER & gtoken != DIGIT & gtoken != UNDERLINE & gtoken != DOLLAR) break } c = token(1) if (i > 1) { # some alpha seen gtoken = ALPHA if (i > toksiz) { i = toksiz - 1 call synerr(toolng) } else { c = token(i) token(i) = EOS i = i - 1 if (c == RADIX) # check for base other than 10 if (alldig(token) == YES) { j = 1 call dobase(ctoi(token, j), token, toksiz, i) if (token(1) == MINUS) { gtoken = MINUS i = 1 call pbstr(token(2)) } } else call putbak(RADIX) else call putbak(c) } } else if (isquote(c) | c == ACCENT) { # Accented strings are passed through as literal strings, with the accents # being stripped off of the output. Any characters (except EOF) may appear # within accents. # Two occurrences of the initial quote character (', ", or `) within a string # in a row are interpreted as a single literal occurrence of that character. # Unbalanced occurrences of ' or " are allowed on a line and are passed # through as themselves. gtoken = c for (i = 2; i < toksiz; i = i+1) if (ngetch(token(i)) == c) if (ngetch(token(i+1)) != c) { call putbak(token(i+1)) break } else i = i+1 else if (c == ACCENT & token(i) == EOF) { call synerr("EOF in literal string.") token(i) = ACCENT call putbak(EOF) break } else if (c != ACCENT & (token(i) == NEWLINE | token(i) == EOF)) { if (token(i) == EOF) call synerr("EOF in quoted string.") # allow unbalanced quote on line for ( ; i > 1 & token(i) != c; i = i-1) call putbak(token(i)) if (i > 1) { call putbak(c) i = i-1 } break } if (i >= toksiz) { if (c == ACCENT) call synerr("missing accent.") else call synerr("missing quote.") call synerr(toolng) if (token(i-1) == c) i = i-2 else i = i-1 token(i) = c } } else if (cp == 0) { # not in a macro? if (c == LBRACE) { # allow { for [ token(1) = LBRACK gtoken = LBRACK } else if (c == RBRACE) { # allow } for ] token(1) = RBRACK gtoken = RBRACK } else if (c == SHARP) { # output comments call outcom(token) token(1) = NEWLINE gtoken = NEWLINE } else if (c == GREATER | c == LESS | c == TILDE | c == BANG | c == CARET | c == BACKSLASH | c == EQUALS | c == AND | c == OR) { if (toksiz < 11) call synerr("gtoken: shouldn't happen.") else call relate(token, i) } } token(i+1) = EOS return end # ARCHIVE GTSKNL.RAT 10 30-NOV-81 14:24:02 # gtsknl - get next token, skip newlines character function gtsknl(token, toksiz) character token(ARB), gettok integer toksiz repeat gtsknl = gettok(token, toksiz) until (gtsknl != NEWLINE) return end # ARCHIVE IFCODE.RAT 25 30-NOV-81 14:24:02 # ifcode - generate initial code for if subroutine ifcode(lab) integer labgen integer lab include cflags include cgoto string ifs "if " string thens " then" xfer = NO if (f77) { call outtab call outstr(ifs) call balpar call outstr(thens) call outdon } else { lab = labgen(2) call ifgo(lab) } call inden(2) return end # ARCHIVE IFGO.RAT 13 30-NOV-81 14:24:02 # ifgo - generate 'if (.not.(...)) goto lab' subroutine ifgo(lab) integer lab string ifnot 'if (.not.' call outtab # get to column 7 call outstr(ifnot) # 'if (.not.' call balpar # collect and output condition call outch(RPAREN) # ')' call outch(BLANK) call outgo(lab, NO) # ' goto lab' return end # ARCHIVE IFS.RAT 24 30-NOV-81 14:24:02 # ifs - generate code for end of if subroutine ifs(sp, lextyp, labval) integer sp, lextyp(MAXSTACK), labval(MAXSTACK) include cflags include cgoto string endifs "end if" xfer = NO call outden(2) if (f77) { call outtab call outstr(endifs) call outdon } else switch (lextyp(sp)) { case LEXIF: call outcon(labval(sp)) case LEXELSE: call outcon(labval(sp-1)) case LEXELSEIF: call outcon(labval(sp)) call outcon(labval(sp-1)) } sp = sp-1 return end # ARCHIVE INDEN.RAT 8 30-NOV-81 14:24:03 # inden - indent or outdent the tab position subroutine inden(ind) integer ind include coutln indent = max(0, indent + ind) return end # ARCHIVE INIRAT.RAT 97 30-NOV-81 14:24:03 # inirat - initialize table and install keywords subroutine inirat integer set character sdefin(7), vdefin(2) character sinclu(8), vinclu(2) character sfunct(9), vfunct(2) character sdo(3), vdo(2) character sif(3), vif(2) character selse(5), velse(2) character swhile(6), vwhile(2) character sfor(4), vfor(2) character srepea(7), vrepea(2) character suntil(6), vuntil(2) character snext(5), vnext(2) character sbreak(6), vbreak(2) character sretur(7), vretur(2) character sread(5), vread(2) character swrite(6), vwrite(2) character sencod(7), vencod(2) character sdecod(7), vdecod(2) character sforma(7), vforma(2) character sstrng(7), vstrng(2) character sswtch(7), vswtch(2) character scase(5), vcase(2) character sdefal(8), vdefal(2) data sdefin /LETD, LETE, LETF, LETI, LETN, LETE, EOS/, vdefin /DEFINETYPE, EOS/ data sinclu /LETI, LETN, LETC, LETL, LETU, LETD, LETE, EOS/, vinclu /LEXINCLUDE, EOS/ data sfunct /LETF, LETU, LETN, LETC, LETT, LETI, LETO, LETN, EOS/, vfunct /LEXFUNCTION, EOS/ data sdo /LETD, LETO, EOS/, vdo /LEXDO, EOS/ data sif /LETI, LETF, EOS/, vif /LEXIF, EOS/ data selse /LETE, LETL, LETS, LETE, EOS/, velse /LEXELSE, EOS/ data swhile /LETW, LETH, LETI, LETL, LETE, EOS/, vwhile /LEXWHILE, EOS/ data sfor /LETF, LETO, LETR, EOS/, vfor /LEXFOR, EOS/ data srepea /LETR, LETE, LETP, LETE, LETA, LETT, EOS/, vrepea /LEXREPEAT, EOS/ data suntil /LETU, LETN, LETT, LETI, LETL, EOS/, vuntil /LEXUNTIL, EOS/ data snext /LETN, LETE, LETX, LETT, EOS/, vnext /LEXNEXT, EOS/ data sbreak /LETB, LETR, LETE, LETA, LETK, EOS/, vbreak /LEXBREAK, EOS/ data sretur /LETR, LETE, LETT, LETU, LETR, LETN, EOS/, vretur /LEXRETURN, EOS/ data sread /LETR, LETE, LETA, LETD, EOS/, vread /LEXREAD, EOS/ data swrite /LETW, LETR, LETI, LETT, LETE, EOS/, vwrite /LEXWRITE, EOS/ data sencod /LETE, LETN, LETC, LETO, LETD, LETE, EOS/, vencod /LEXENCODE, EOS/ data sdecod /LETD, LETE, LETC, LETO, LETD, LETE, EOS/, vdecod /LEXDECODE, EOS/ data sforma /LETF, LETO, LETR, LETM, LETA, LETT, EOS/, vforma /LEXFORMAT, EOS/ data sstrng /LETS, LETT, LETR, LETI, LETN, LETG, EOS/, vstrng /LEXSTRING, EOS/ data sswtch /LETS, LETW, LETI, LETT, LETC, LETH, EOS/, vswtch /LEXSWITCH, EOS/ data scase /LETC, LETA, LETS, LETE, EOS/, vcase /LEXCASE, EOS/ data sdefal /LETD, LETE, LETF, LETA, LETU, LETL, LETT, EOS/, vdefal /LEXDEFAULT, EOS/ call insupl(sdefin, vdefin, set(set(set(0, HASARGS), COMMA_OK), 1)) call insupl(sinclu, vinclu, 0) call insupl(sfunct, vfunct, 0) call insupl(sdo, vdo, 0) call insupl(sif, vif, 0) call insupl(selse, velse, 0) call insupl(swhile, vwhile, 0) call insupl(sfor, vfor, 0) call insupl(srepea, vrepea, 0) call insupl(suntil, vuntil, 0) call insupl(snext, vnext, 0) call insupl(sbreak, vbreak, 0) call insupl(sretur, vretur, 0) call insupl(sread, vread, 0) call insupl(swrite, vwrite, 0) call insupl(sencod, vencod, 0) call insupl(sdecod, vdecod, 0) call insupl(sforma, vforma, 0) call insupl(sstrng, vstrng, 0) call insupl(sswtch, vswtch, 0) call insupl(scase, vcase, 0) call insupl(sdefal, vdefal, 0) return end # ARCHIVE LABELC.RAT 15 30-NOV-81 14:24:03 # labelc - output statement number subroutine labelc(lexstr) character lexstr(ARB) integer length, i include cgoto xfer = NO # can't suppress goto's now i = length(lexstr) if (lexstr(i) == DIG0) if (i > 4 | (lexstr(1) != DIG1 & i == 4)) call synerr('warning: possible label conflict.') call outstr(lexstr) call outtab return end # ARCHIVE LABGEN.RAT 9 30-NOV-81 14:24:03 # labgen - generate n consecutive labels, return first one integer function labgen(n) integer n include cgoto labgen = label label = label + n*10 return end # ARCHIVE LEX.RAT 20 30-NOV-81 14:24:04 # lex - return lexical type of token integer function lex(lexstr) character gettok character lexstr(MAXTOK) integer alldig while (gettok(lexstr, MAXTOK) == NEWLINE) ; lex = lexstr(1) if (lex < 0 | lex == EOF | lex == SEMICOL | lex == LBRACK | lex == RBRACK) ; else if (alldig(lexstr) == YES) lex = LEXDIGITS else if (lex == TOGGLE) lex = LEXLITERAL else lex = LEXOTHER return end # ARCHIVE LITRAL.RAT 37 1-DEC-81 11:18:38 # litral - process literal Fortran lines subroutine litral character ngetch, c integer nb include cgoto call outdon # Finish off any left-over characters xfer = NO for (nb = 0; ngetch(c) == BLANK; nb = nb+1) ; if (c != NEWLINE) { # literal on this line only for ( ; nb > 0; nb = nb - 1) call putch(BLANK, STDOUT) repeat { if (c == EOF) goto 10 call putch(c, STDOUT) } until (ngetch(c) == NEWLINE) call putch(NEWLINE, STDOUT) } else # loop until matching toggle found while (ngetch(c) != TOGGLE) { repeat { if (c == EOF) goto 10 call putch(c, STDOUT) } until (ngetch(c) == NEWLINE) call putch(NEWLINE, STDOUT) } return 10 call putbak(EOF) call synerr("EOF in literal fortran code.") return end # ARCHIVE NQC.RAT 13 30-NOV-81 14:24:04 # nqc - get next character from quoted character string character function nqc(lin, i, q, c) character lin(ARB), q, c integer i c = lin(i) if (c == q) if (lin(i+1) == q) i = i+1 else c = EOS return(c) end # ARCHIVE OTHERC.RAT 11 30-NOV-81 14:24:04 # otherc - output ordinary Fortran statement subroutine otherc(lexstr) character lexstr(ARB) include cgoto xfer = NO call outtab call outstr(lexstr) call eatup return end # ARCHIVE OUTCH.RAT 18 30-NOV-81 14:24:05 # outch - put one character into output buffer subroutine outch(c) character c integer i include coutln if (outp >= 72) { # continuation card call outdon for (i = 1; i < 6; i = i + 1) outbuf(i) = BLANK outbuf(6) = STAR outp = 6 } outp = outp + 1 outbuf(outp) = c return end # ARCHIVE OUTCOM.RAT 24 30-NOV-81 14:24:05 # outcom - output comments subroutine outcom(token) character token(1), ngetch integer j include cmacro include coutln if (defstk(defcnt) & (outp < 6 | outbuf(6) == BLANK)) { call putch(BIGC, STDOUT) for (j = 2; ngetch(token(1)) != NEWLINE; j = j+1) { if (j > 80) { call putch(NEWLINE, STDOUT) call putch(BIGC, STDOUT) j = 2 } call putch(token(1), STDOUT) } call putch(NEWLINE, STDOUT) } else while (ngetch(token(1)) != NEWLINE) ; return end # ARCHIVE OUTCON.RAT 17 30-NOV-81 14:24:05 # outcon - output 'n continue' subroutine outcon(n) integer n include cgoto include coutln string contin 'continue' xfer = NO if (n <= 0 & outp == 0) return # don't need unlabeled continues if (n > 0) call outnum(n) call outtab call outstr(contin) call outdon return end # ARCHIVE OUTDON.RAT 12 1-DEC-81 10:48:24 # outdon - finish off an output line subroutine outdon include coutln if (outp > 0) { outbuf(outp+1) = NEWLINE outbuf(outp+2) = EOS call putlin(outbuf, STDOUT) outp = 0 } return end # ARCHIVE OUTGO.RAT 16 30-NOV-81 14:24:06 # outgo - output 'goto n' subroutine outgo(n, newxf) integer n, newxf include coutln include cgoto string goto 'goto ' if (xfer == YES) return xfer = newxf call outtab call outstr(goto) call outnum(n) call outdon return end # ARCHIVE OUTNUM.RAT 11 30-NOV-81 14:24:06 # outnum - output decimal number subroutine outnum(int) integer int, i, j integer itoc character str(MAXCHARS) i = itoc(int, str, MAXCHARS) for (j = 1; j <= i; j = j+1) call outch(str(j)) return end # ARCHIVE OUTSTR.RAT 49 30-NOV-81 14:24:07 # outstr - output string subroutine outstr(str) #***NOTE*** - modified to put out quoted strings unless /HOLLERITH # switch was specified on the command line # and to strip ACCENT chars character c, q, str(ARB), cupper, nqc integer i, j , k include cflags for (i = 1; str(i) != EOS; i = i + 1) { c = str(i) if (c == ACCENT) { for (i = i+1; ; i = i+1) { if (str(i) == ACCENT) if (str(i+1) == ACCENT) i = i+1 else break call outch(str(i)) } } else if (str(i+1) == EOS | ! isquote(c)) call outch(cupper(c)) else if (holler) { # hollerith output? q = c i = i+1 k = 0 for (j = i; nqc(str, j, q, c) != EOS; j = j+1) # find end k = k+1 call outnum(k) call outch(BIGH) for ( ; nqc(str, i, q, c) != EOS; i = i+1) call outch(c) } else { # quoted output q = c call outch(SQUOTE) for (i = i + 1; nqc(str, i, q, c) != EOS; i = i + 1) { if (c == SQUOTE) call outch(SQUOTE) # ' -> '' call outch(c) } call outch(SQUOTE) } } return end # ARCHIVE OUTTAB.RAT 11 30-NOV-81 14:24:07 # outtab - get past column 6 subroutine outtab integer i, mod include coutln i = mod(indent, 44) + 6 while (outp < i) call outch(BLANK) return end # ARCHIVE PARSE.RAT 140 1-DEC-81 09:55:07 # parse - parse Ratfiv source program subroutine parse character lexstr(MAXTOK) integer lex integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token, i include coutln include cline include cdefio include cfor include cfname include cgoto include cflags include csbuf include cswtch string sdecod "decode" string sencod "encode" string sread "read" string swrite "write" string sforma "format" # initialize variables for current input file outp = 0 indent = 0 level = 1 fnamp(1) = 1 linect(1) = 0 bp = 0 sbp = 1 fordep = 0 inform = .false. # controls conversion of > and < to .gt. and .lt. fcname(1) = EOS xfer = NO label = 2000 swtop = 0 swlast = 1 sp = 1 lextyp(1) = EOF for (token = lex(lexstr); token != EOF; token = lex(lexstr)) { switch (token) { case LEXOTHER: call otherc(lexstr) case LEXIF: call ifcode(lab) sp = sp+1 case LEXELSE: if (lextyp(sp) == LEXIF | lextyp(sp) == LEXELSEIF) { if (lex(lexstr) == LEXIF) # have "else if ..." lextyp(sp) = LEXELSEIF else { call pbstr(lexstr) lextyp(sp) = LEXELSE } call elsef(labval(sp-1), labval(sp), lextyp(sp)) if (lextyp(sp) == LEXELSEIF) call ifcode(labval(sp)) } else { token = LEXERROR call synerr("illegal else.") } case LEXDO: call docode(lab) case LEXWHILE: call whilec(lab) case LEXFOR: call forcod(lab) case LEXREPEAT: call repcod(lab) case LEXBREAK, LEXNEXT: call brknxt(sp, lextyp, labval, token) case LEXDIGITS: call labelc(lexstr) case LEXSWITCH: call swcode(lab) case LEXCASE, LEXDEFAULT: if (sp > 1 & lextyp(max(1, sp-1)) == LEXSWITCH) call cascod(labval(sp-1), token) else { token = LEXERROR call synerr("illegal case or default.") } case LEXWRITE: call forma(swrite) case LEXREAD: call forma(sread) case LEXENCODE: call forma(sencod) case LEXDECODE: call forma(sdecod) case LEXFORMAT: inform = .true. call otherc(sforma) inform = .false. case LEXINCLUDE: call rinclu case LEXFUNCTION: call dfunct case LEXRETURN: call retcod case LEXSTRING: call strdcl case LEXLITERAL: call litral default: if (token == RBRACK) { if (lextyp(sp) == LBRACK) sp = sp - 1 else call synerr("illegal right brace.") } } if (token == LEXIF | token == LEXWHILE | token == LEXFOR | token == LEXREPEAT | token == LEXSWITCH | token == LEXDO | token == LEXDIGITS | token == LBRACK) { sp = sp + 1 # beginning of statement if (sp > MAXSTACK) call fatal('stack overflow in parser.') lextyp(sp) = token # stack type and value labval(sp) = lab if (token == LEXIF) { lextyp(sp-1) = token labval(sp-1) = lab+10 } } else if (token != LEXELSE) { # end of statement - prepare to unstack token = lex(lexstr) # peek at next token call pbstr(lexstr) call unstak(sp, lextyp, labval, token) } } if (sp != 1) call synerr('unexpected EOF.') return end # ARCHIVE RAT5S.RAT 83 1-DEC-81 11:28:22 # rat5s - driver subroutine for ratfiv compiler subroutine rat5s integer getarg, open, pmatch character buf(MAXLINE) integer i, arg1 include cline # needed to set input file include cflags string symbls "SYMBOLS" # file containing general definitions string symflg "/SYMBOLS" # /SYMBOLS switch string f77sw "/F77" # Fortran 77 switch string hollsw "/HOLLERITH" # output hollerith strings switch string stdinn "STDIN" # STDIN string call inimac # initialize macro processor call inirat # initialize ratfiv f77 = .false. holler = .false. for (arg1 = 1; getarg(arg1,buf,MAXLINE) != EOF; arg1 = arg1+1) if (buf(1) != SLASH) break else if (pmatch(buf, symflg) == YES) { # read file containing standard defs call scopy(symbls, 1, fnames, 1) infile(1) = open(symbls, READ) if (infile(1) == ERR) { # then try system-wide symbols file call usrbin(fnames) # get location of system-wide file for (i=1; fnames(i) != EOS; i=i+1) # move pointer to end ; call scopy(symbls, 1, fnames, i) # copy remainder of name infile(1) = open (fnames, READ) } if (infile(1) == ERR) { call error ("can't open symbols file.") } else { call parse call close (infile(1)) } } else if (pmatch(buf, f77sw) == YES) f77 = .true. else if (pmatch(buf, hollsw) == YES) holler = .true. else { call putlin(buf, ERROUT) call error(": illegal switch.") } # loop through all input files for (i = arg1; ; i = i+1) { if (getarg(i,buf,MAXLINE) == EOF) { if (i != arg1) break infile(1) = STDIN call scopy(stdinn, 1, fnames, 1) } else if (buf(1) == QMARK & buf(2) == EOS) { call remark (_ 'usage: rat[/symbols][/hollerith][/f77] [file ...] [>outfile].') } else if (buf(1) == MINUS & buf(2) == EOS) { infile(1) = STDIN call scopy(stdinn, 1, fnames, 1) } else { infile(1) = open(buf,READ) call scopy(buf, 1, fnames, 1) if (infile(1) == ERR) call cant(buf) } call parse if (infile(1) != STDIN) call close(infile(1)) } return end # ARCHIVE RATMAIN.RAT 7 1-DEC-81 11:29:40 # ratfiv -- main program program ratfiv # remove this if necessary on your system call initr4 call rat5s call endr4 end # ARCHIVE RELATE.RAT 61 30-NOV-81 14:24:09 # relate - convert relational shorthands into long form subroutine relate(token, last) character ngetch character token(ARB) integer length integer last include cflags character dotge(9), dotgt(9), dotlt(9), dotle(9) character dotne(9), dotnot(8), doteq(9), dotand(10), dotor(9) data dotge /ACCENT, BLANK, PERIOD, BIGG, BIGE, PERIOD, BLANK, ACCENT, EOS/ data dotgt /ACCENT, BLANK, PERIOD, BIGG, BIGT, PERIOD, BLANK, ACCENT, EOS/ data dotle /ACCENT, BLANK, PERIOD, BIGL, BIGE, PERIOD, BLANK, ACCENT, EOS/ data dotlt /ACCENT, BLANK, PERIOD, BIGL, BIGT, PERIOD, BLANK, ACCENT, EOS/ data dotne /ACCENT, BLANK, PERIOD, BIGN, BIGE, PERIOD, BLANK, ACCENT, EOS/ data doteq /ACCENT, BLANK, PERIOD, BIGE, BIGQ, PERIOD, BLANK, ACCENT, EOS/ data dotor /ACCENT, BLANK, PERIOD, BIGO, BIGR, PERIOD, BLANK, ACCENT, EOS/ data dotand /ACCENT, BLANK, PERIOD, BIGA, BIGN, BIGD, PERIOD, BLANK, ACCENT, EOS/ data dotnot /ACCENT, PERIOD, BIGN, BIGO, BIGT, PERIOD, ACCENT, EOS/ if (ngetch(token(2)) != EQUALS) call putbak(token(2)) if (token(1) == GREATER) { if (token(2) == EQUALS) call scopy(dotge, 1, token, 1) else if (inform) token(2) = EOS else call scopy(dotgt, 1, token, 1) } else if (token(1) == LESS) { if (token(2) == EQUALS) call scopy(dotle, 1, token, 1) else if (inform) token(2) = EOS else call scopy(dotlt, 1, token, 1) } else if (token(1) == TILDE | token(1) == BANG | token(1) == CARET) { if (token(2) == EQUALS) call scopy(dotne, 1, token, 1) else call scopy(dotnot, 1, token, 1) } else if (token(1) == EQUALS) { if (token(2) == EQUALS) call scopy(doteq, 1, token, 1) else token(2) = EOS } else if (token(1) == AND) call scopy(dotand, 1, token, 1) else if (token(1) == OR | token(1) == BACKSLASH) call scopy(dotor, 1, token, 1) else # can't happen token(2) = EOS last = length(token) return end # ARCHIVE REPCOD.RAT 12 30-NOV-81 14:24:09 # repcod - generate code for beginning of repeat subroutine repcod(lab) integer labgen integer lab call outcon(0) # in case there was a label lab = labgen(3) call outcon(lab) call inden(2) lab = -(lab + 10) # label to go on next's return end # ARCHIVE RETCOD.RAT 29 30-NOV-81 14:24:09 # retcod - generate code for return subroutine retcod character token(MAXTOK), gettok, t include cfname include cgoto string retrn 'return' string eqs " = " t = gettok(token, MAXTOK) if (t == SEMICOL | t == NEWLINE | t == EOF | t == RBRACK | t == LBRACK | (t < 0 & t != ALPHA)) call pbstr(token) else { call pbstr(token) call outtab if (fcname(1) == EOS) call synerr("return: no function defined.") else { call outstr(fcname) call outstr(eqs) } call eatup } call outtab call outstr(retrn) call outdon xfer = YES return end # ARCHIVE RINCLU.RAT 29 16-DEC-81 23:27:37 # rinclu - do include for ratfiv subroutine rinclu character file(FILENAMESIZE), t, buf(MAXTOK), nqc, c, brkchr(5) character gettok, deftok integer i, j, index data brkchr /SEMICOL, BLANK, TAB, NEWLINE, EOS/ t = gettok(buf, MAXTOK) if (isquote(t) & buf(2) != EOS) { # include "file" or 'file' i = 1 for (j = 2; i <= FILENAMESIZE & nqc(buf, j, t, c) != EOS; j = j+1) { file(i) = c i = i+1 } } else # include file for (i = 1; t != EOF & index(brkchr, t) == 0; t = deftok(buf, MAXTOK)) for (j = 1; i <= FILENAMESIZE & buf(j) != EOS; j = j+1) { file(i) = buf(j) i = i+1 } if (i > FILENAMESIZE) call synerr("include file name too long.") else { file(i) = EOS call includ(file) } return end # ARCHIVE SKPOUT.RAT 26 30-NOV-81 14:24:10 subroutine skpout(t) character t, tok(MAXTOK), gettok integer nlpar nlpar = 0 repeat { t = gettok(tok, MAXTOK) if (t == EOF) { call pbstr(tok) call synerr('unexpected EOF.') return } if (t == LPAREN) nlpar = nlpar+1 else if (t == RPAREN) nlpar = nlpar-1 if (t != NEWLINE) { call outstr(tok) if (t == COMMA) call outch(BLANK) } } until (nlpar < 0 | (t == COMMA & nlpar == 0)) if (t == RPAREN) call outch(BLANK) return end # ARCHIVE STRDCL.RAT 102 30-NOV-81 14:24:10 # strdcl - generate code for string declaration subroutine strdcl character t, token(MAXTOK), gettok, esc, nqc, q, c integer i, j, k, n, len integer length, ctoi, lex, elenth #$ character dchar(MAXTOK) include csbuf string char character string dat "data " string eoss EOS #$ character char(11), dat(6), eoss(5) #$ data char/LETC, LETH, LETA, LETR, LETA, LETC, LETT, LETE, LETR, SLASH, EOS/, #$ dat /LETD, LETA, LETT, LETA, BLANK, EOS/, #$ eoss /BIGE, BIGO, BIGS, SLASH, EOS/ repeat { t = gettok(token, MAXTOK) if (t != ALPHA) call synerr("missing string token.") call outtab call outstr(char) #$ call pbstr(char) #use defined meaning of "character" #$ repeat #$ { #$ t = gettok(dchar, MAXTOK) #$ if (t == SLASH) #$ break #$ call outstr (dchar) #$ } call outch(BLANK) # separator in declaration call outstr(token) call addstr(token, sbuf, sbp, MAXSTRING) # save for later call addchr(EOS, sbuf, sbp, MAXSTRING) if (gettok(token, MAXTOK) != LPAREN) { # make size same as initial value len = elenth(token) + 1 if (isquote(token(1)) & token(2) != EOS) len = len - 2 } else { # form is string name(size) init t = gettok(token, MAXTOK) i = 1 len = ctoi(token, i) if (token(i) != EOS) call synerr("invalid string size.") if (gettok(token, MAXTOK) != RPAREN) call synerr("missing right paren.") else t = gettok(token, MAXTOK) } call outch(LPAREN) call outnum(len) call outch(RPAREN) call outdon if (isquote(token(1)) & token(2) != EOS) { q = token(1) for(i = 2; nqc(token, i, q, c) != EOS; i = i+1) call addchr(c, sbuf, sbp, MAXSTRING) } else call addstr(token, sbuf, sbp, MAXSTRING) call addchr(EOS, sbuf, sbp, MAXSTRING) t = gettok(token, MAXTOK) # peek at next token if (t == COMMA) # string ..., ... while (gettok(token, MAXTOK) == NEWLINE) ; call pbstr(token) } until (t != COMMA) t = lex(token) call pbstr(token) if (t != LEXSTRING) { # dump accumulated data statements for (i = 1; i < sbp; i = j + 1) { call outtab call outstr(dat) k = 1 for (j = i + length(sbuf(i)) + 1; ; j = j + 1) { if (k > 1) call outch(COMMA) call outstr(sbuf(i)) call outch(LPAREN) call outnum(k) call outch(RPAREN) call outch(SLASH) if (sbuf(j) == EOS) break n = esc(sbuf, j) call outnum (n) call outch(SLASH) k = k + 1 } call outstr(eoss) call outch(SLASH) #$ call pbstr(eoss) # use defined meaning of EOS #$ repeat { #$ t = gettok(token, MAXTOK) #$ call outstr(token) #$ } until (t == SLASH) call outdon } sbp = 1 } return end # ARCHIVE SWCODE.RAT 34 30-NOV-81 14:24:11 # swcode - generate code for beginning of switch statement subroutine swcode(lab) integer lab, labgen character tok(MAXTOK), gettok include cswtch include cgoto string eqs " = " lab = labgen(2) if (swlast + 3 > MAXSWITCH) call fatal("switch table overflow.") swstak(swlast) = swtop swstak(swlast+1) = 0 swstak(swlast+2) = 0 swtop = swlast swlast = swlast + 3 xfer = NO call outtab # Innn=(e) call swvar(lab) call outstr(eqs) call balpar call outdon call outgo(lab, YES) # goto L call inden(2) while(gettok(tok, MAXTOK) == NEWLINE) ; if (tok(1) != LBRACK) { call synerr("missing left brace in switch statement.") call pbstr(tok) } call putbak(LBRACK) return end # ARCHIVE SWEND.RAT 98 30-NOV-81 14:24:11 # swend - finish off switch statement; generate dispatch code subroutine swend(lab) integer lab, lb, ub, n, i, j include cswtch string sif "if (" string slt " .lt. 1 .or. " string sgt " .gt. " string sgoto "goto (" string seq " .eq. " string sge " .ge. " string sle " .le. " string sand " .and. " string eqs " = " lb = swstak(swtop+3) ub = swstak(swlast-2) n = swstak(swtop+1) call outgo(lab+10, YES) # terminate last case call outden(2) if (swstak(swtop+2) == 0) swstak(swtop+2) = lab + 10 # default default label call outcon(lab) # L continue if (n >= CUTOFF & ub - lb + 1 <= DENSITY*n & lb > -MAXINT) { # output branch table if (lb != 1) { # L Innn=Innn-lb+1 call outtab call swvar(lab) call outstr(eqs) call swvar(lab) if (lb < 1) call outch(PLUS) call outnum(-lb + 1) call outdon } call outtab # if(Innn.lt.1.or.Innn.gt.ub-lb+1)goto default call outstr(sif) call swvar(lab) call outstr(slt) call swvar(lab) call outstr(sgt) call outnum(ub - lb + 1) call outch(RPAREN) call outch(BLANK) call outgo(swstak(swtop+2), NO) call outtab # goto (....),Innn call outstr(sgoto) j = lb for (i = swtop + 3; i < swlast; i = i + 3) { for ( ; j < swstak(i); j = j + 1) { # fill in vacancies call outnum(swstak(swtop+2)) call outch(COMMA) } for (j = swstak(i+1) - swstak(i); j >= 0; j = j - 1) { call outnum(swstak(i+2)) # fill in range if (j > 0) call outch(COMMA) } j = swstak(i+1) + 1 if (i < swlast - 3) call outch(COMMA) } call outch(RPAREN) call outch(COMMA) call outch(BLANK) call swvar(lab) call outdon } else if (n > 0) { # output linear search form for (i = swtop + 3; i < swlast; i = i + 3) { call outtab # if(Innn call outstr(sif) call swvar(lab) if (swstak(i) == swstak(i+1)) { call outstr(seq) # .eq.... call outnum(swstak(i)) } else { call outstr(sge) # .ge.lb.and.Innn.le.ub call outnum(swstak(i)) call outstr(sand) call swvar(lab) call outstr(sle) call outnum(swstak(i+1)) } call outch(RPAREN) # ) goto ... call outch(BLANK) call outgo(swstak(i+2), NO) } if (lab + 10 != swstak(swtop+2)) call outgo(swstak(swtop+2), YES) } call outcon(lab+10) # L+10 continue swlast = swtop # pop switch stack swtop = swstak(swtop) return end # ARCHIVE SWVAR.RAT 8 30-NOV-81 14:24:12 # swvar - output switch variable Innn, where nnn = lab subroutine swvar(lab) integer lab call outch(BIGI) call outnum(lab) return end # ARCHIVE UNSTAK.RAT 26 30-NOV-81 14:24:12 # unstak - unstack at end of statement subroutine unstak(sp, lextyp, labval, token) integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token for ( ; sp > 1; sp = sp - 1) { if (lextyp(sp) == LBRACK) break if ((lextyp(sp) == LEXIF | lextyp(sp) == LEXELSEIF) & token == LEXELSE) break switch (lextyp(sp)) { case LEXIF, LEXELSEIF, LEXELSE: call ifs(sp, lextyp, labval) case LEXDO: call dostat(labval(sp)) case LEXWHILE: call whiles(labval(sp)) case LEXFOR: call fors(labval(sp)) case LEXREPEAT: call untils(labval(sp), token) case LEXSWITCH: call swend(labval(sp)) } } return end # ARCHIVE UNTILS.RAT 20 30-NOV-81 14:24:12 # untils - generate code for until or end of repeat subroutine untils(lab, token) character ptoken(MAXTOK) integer lex integer junk, lab, token include cgoto xfer = NO call outden(2) call outnum(abs(lab)) if (token == LEXUNTIL) { junk = lex(ptoken) call ifgo(abs(lab)-10) } else call outgo(abs(lab)-10, YES) if (lab > 0) # break seen call outcon(lab+10) return end # ARCHIVE WHILEC.RAT 22 30-NOV-81 14:24:12 # whilec - generate code for beginning of while subroutine whilec(lab) integer labgen integer lab include cflags string whiles "do while " call outcon(0) # unlabeled continue, in case there was a label lab = labgen(2) call outnum(lab) if (f77) { call outtab call outstr(whiles) call balpar call outdon lab = -lab } else call ifgo(lab+10) call inden(2) return end # ARCHIVE WHILES.RAT 20 30-NOV-81 14:24:13 # whiles - generate code for end of while subroutine whiles(lab) integer lab include cflags include cgoto string enddos "end do" call outden(2) if (f77) { call outtab call outstr(enddos) call outdon xfer = NO } else call outgo(lab, YES) if (lab > 0) # break seen or not Fortran 77 output call outcon(lab+10) return end