# ========== Ratfor in ratfor ========== # block data - initialize global variables block data include commonblocks # include coutln # include cline # include cdefio # include cfor # include clook # include ckeywd # include cchar # output character pointer: data outp /0/ # file control: data level /1/ data linect(1) /1/ data infile(1) /STDIN/ # pushback buffer pointer: data bp /0/ # depth of for stack: data fordep /0/ # pointers for table lookup code: data lastp /0/ data lastt /0/ # keywords: data sdo(1), sdo(2), sdo(3) /LETD, LETO, EOS/ data vdo(1), vdo(2) /LEXDO, EOS/ data sif(1), sif(2), sif(3) /LETI, LETF, EOS/ data vif(1), vif(2) /LEXIF, EOS/ data selse(1), selse(2), selse(3), selse(4), selse(5) /LETE, LETL, LETS, LETE, EOS/ data velse(1), velse(2) /LEXELSE, EOS/ data swhile(1), swhile(2), swhile(3), swhile(4), swhile(5), swhile(6) /LETW, LETH, LETI, LETL, LETE, EOS/ data vwhile(1), vwhile(2) /LEXWHILE, EOS/ data sbreak(1), sbreak(2), sbreak(3), sbreak(4), sbreak(5), sbreak(6) /LETB, LETR, LETE, LETA, LETK, EOS/ data vbreak(1), vbreak(2) /LEXBREAK, EOS/ data snext(1), snext(2), snext(3), snext(4), snext(5) /LETN, LETE, LETX, LETT, EOS/ data vnext(1), vnext(2) /LEXNEXT, EOS/ data sfor(1), sfor(2), sfor(3), sfor(4) /LETF, LETO, LETR, EOS/ data vfor(1), vfor(2) /LEXFOR, EOS/ data srept(1), srept(2), srept(3), srept(4), srept(5), srept(6), srept(7) /LETR, LETE, LETP, LETE, LETA, LETT, EOS/ data vrept(1), vrept(2) /LEXREPEAT, EOS/ data suntil(1), suntil(2), suntil(3), suntil(4), suntil(5), suntil(6) /LETU, LETN, LETT, LETI, LETL, EOS/ data vuntil(1), vuntil(2) /LEXUNTIL, EOS/ # character set definitions: data extblk /' '/, intblk /BLANK/ data extdig(1) /'0'/, intdig(1) /DIG0/ data extdig(2) /'1'/, intdig(2) /DIG1/ data extdig(3) /'2'/, intdig(3) /DIG2/ data extdig(4) /'3'/, intdig(4) /DIG3/ data extdig(5) /'4'/, intdig(5) /DIG4/ data extdig(6) /'5'/, intdig(6) /DIG5/ data extdig(7) /'6'/, intdig(7) /DIG6/ data extdig(8) /'7'/, intdig(8) /DIG7/ data extdig(9) /'8'/, intdig(9) /DIG8/ data extdig(10) /'9'/, intdig(10) /DIG9/ # normal case of letters data extlet(1) /'a'/, intlet(1) /LETA/ data extlet(2) /'b'/, intlet(2) /LETB/ data extlet(3) /'c'/, intlet(3) /LETC/ data extlet(4) /'d'/, intlet(4) /LETD/ data extlet(5) /'e'/, intlet(5) /LETE/ data extlet(6) /'f'/, intlet(6) /LETF/ data extlet(7) /'g'/, intlet(7) /LETG/ data extlet(8) /'h'/, intlet(8) /LETH/ data extlet(9) /'i'/, intlet(9) /LETI/ data extlet(10) /'j'/, intlet(10) /LETJ/ data extlet(11) /'k'/, intlet(11) /LETK/ data extlet(12) /'l'/, intlet(12) /LETL/ data extlet(13) /'m'/, intlet(13) /LETM/ data extlet(14) /'n'/, intlet(14) /LETN/ data extlet(15) /'o'/, intlet(15) /LETO/ data extlet(16) /'p'/, intlet(16) /LETP/ data extlet(17) /'q'/, intlet(17) /LETQ/ data extlet(18) /'r'/, intlet(18) /LETR/ data extlet(19) /'s'/, intlet(19) /LETS/ data extlet(20) /'t'/, intlet(20) /LETT/ data extlet(21) /'u'/, intlet(21) /LETU/ data extlet(22) /'v'/, intlet(22) /LETV/ data extlet(23) /'w'/, intlet(23) /LETW/ data extlet(24) /'x'/, intlet(24) /LETX/ data extlet(25) /'y'/, intlet(25) /LETY/ data extlet(26) /'z'/, intlet(26) /LETZ/ # upper case of letters data extbig(1) /'A'/, intbig(1) /BIGA/ data extbig(2) /'B'/, intbig(2) /BIGB/ data extbig(3) /'C'/, intbig(3) /BIGC/ data extbig(4) /'D'/, intbig(4) /BIGD/ data extbig(5) /'E'/, intbig(5) /BIGE/ data extbig(6) /'F'/, intbig(6) /BIGF/ data extbig(7) /'G'/, intbig(7) /BIGG/ data extbig(8) /'H'/, intbig(8) /BIGH/ data extbig(9) /'I'/, intbig(9) /BIGI/ data extbig(10) /'J'/, intbig(10) /BIGJ/ data extbig(11) /'K'/, intbig(11) /BIGK/ data extbig(12) /'L'/, intbig(12) /BIGL/ data extbig(13) /'M'/, intbig(13) /BIGM/ data extbig(14) /'N'/, intbig(14) /BIGN/ data extbig(15) /'O'/, intbig(15) /BIGO/ data extbig(16) /'P'/, intbig(16) /BIGP/ data extbig(17) /'Q'/, intbig(17) /BIGQ/ data extbig(18) /'R'/, intbig(18) /BIGR/ data extbig(19) /'S'/, intbig(19) /BIGS/ data extbig(20) /'T'/, intbig(20) /BIGT/ data extbig(21) /'U'/, intbig(21) /BIGU/ data extbig(22) /'V'/, intbig(22) /BIGV/ data extbig(23) /'W'/, intbig(23) /BIGW/ data extbig(24) /'X'/, intbig(24) /BIGX/ data extbig(25) /'Y'/, intbig(25) /BIGY/ data extbig(26) /'Z'/, intbig(26) /BIGZ/ # special characters. some of these may # change for your machine data extchr(1) /']'/, intchr(1) /NOT/ # use exclam for not-sign data extchr(2) /'"'/, intchr(2) /DQUOTE/ data extchr(3) /"#"/, intchr(3) /SHARP/ data extchr(4) /'$'/, intchr(4) /DOLLAR/ data extchr(5) /'%'/, intchr(5) /PERCENT/ data extchr(6) /'&'/, intchr(6) /AMPER/ data extchr(7) /"'"/, intchr(7) /SQUOTE/ data extchr(8) /'('/, intchr(8) /LPAREN/ data extchr(9) /')'/, intchr(9) /RPAREN/ data extchr(10) /'*'/, intchr(10) /STAR/ data extchr(11) /'+'/, intchr(11) /PLUS/ data extchr(12) /','/, intchr(12) /COMMA/ data extchr(13) /'-'/, intchr(13) /MINUS/ data extchr(14) /'.'/, intchr(14) /PERIOD/ data extchr(15) /'/'/, intchr(15) /SLASH/ data extchr(16) /':'/, intchr(16) /COLON/ data extchr(17) /';'/, intchr(17) /SEMICOL/ data extchr(18) /'<'/, intchr(18) /LESS/ data extchr(19) /'='/, intchr(19) /EQUALS/ data extchr(20) /'>'/, intchr(20) /GREATER/ data extchr(21) /'?'/, intchr(21) /QMARK/ data extchr(22) /'@'/, intchr(22) /ATSIGN/ data extchr(23) /'Õ'/, intchr(23) /LBRACK/ data extchr(24) /'\\'/, intchr(24) /BACKSLASH/ data extchr(25) /'å'/, intchr(25) /RBRACK/ data extchr(26) /'_'/, intchr(26) /UNDERLINE/ data extchr(27) /'{'/, intchr(27) /LBRACE/ data extchr(28) /'!'/, intchr(28) /BAR/ data extchr(29) /'}'/, intchr(29) /RBRACE/ data extchr(30) /''/, intchr(30) /BACKSPACE/ data extchr(31) /' '/, intchr(31) /TAB/ data extchr(32) /'^'/, intchr(32) /NOT/ # use caret for not-sign data extchr(33) /'~'/, intchr(33) /NOT/ # use tilde for not-sign # NCHARS is last subscript in this array end # ratfor - main program for Ratfor call parse stop end # alldig - return YES if str is all digits integer function alldig(str) character type character str(ARB) integer i alldig = NO if (str(1) == EOS) return for (i = 1; str(i) ^= EOS; i = i + 1) if (type(str(i)) ^= DIGIT) return alldig = YES return end # 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==LBRACE | t==RBRACE | t==EOF) { 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) } until (nlpar <= 0) if (nlpar ^= 0) call synerr("missing parenthesis in condition.") return end # brknxt - generate code for break and next subroutine brknxt(sp, lextyp, labval, token) integer i, labval(MAXSTACK), lextyp(MAXSTACK), sp, token for (i = sp; i > 0; i = i - 1) if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) { if (token == LEXBREAK) call outgo(labval(i)+1) else call outgo(labval(i)) return } if (token == LEXBREAK) call synerr("illegal break.") else call synerr("illegal next.") return end # close - exceedingly temporary version for gettok subroutine close(fd) integer fd rewind fd return end # ctoi - convert string at in(i) to integer, increment i integer function ctoi(in, i) character in(ARB) integer index integer d, i # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ while (in(i) == BLANK | in(i) == TAB) i = i + 1 for (ctoi = 0; in(i) ^= EOS; i = i + 1) { d = index(digits, in(i)) if (d == 0) # non-digit break ctoi = 10 * ctoi + d - 1 } return end # deftok - get token; process macro calls and invocations character function deftok(token, toksiz, fd) character gtok integer fd, toksiz character defn(MAXDEF), t, token(toksiz) integer lookup for (t=gtok(token, toksiz, fd); t^=EOF; t=gtok(token, toksiz, fd)) { if (t ^= ALPHA) # non-alpha break if (lookup(token, defn) == NO) # undefined break if (defn(1) == DEFTYPE) { # get definition call getdef(token, toksiz, defn, MAXDEF, fd) call instal(token, defn) } else call pbstr(defn) # push replacement onto input } deftok = t if (deftok == ALPHA) # convert to single case call fold(token) return end # fold - convert alphabetic token to single case subroutine fold(token) character token(ARB) integer i # WARNING - this routine depends heavily on the # fact that letters have been mapped into internal # right-adjusted ascii. god help you if you # have subverted this mechanism. for (i = 1; token(i) ^= EOS; i = i + 1) if (token(i) >= BIGA & token(i) <= BIGZ) token(i) = token(i) - BIGA + LETA return end # docode - generate code for beginning of do subroutine docode(lab) integer labgen integer lab # string dostr "do" integer dostr(4) data dostr(1), dostr(2), dostr(3), dostr(4)/LETD, LETO, BLANK, EOS/ call outtab call outstr(dostr) lab = labgen(2) call outnum(lab) call eatup call outdon return end # dostat - generate code for end of do statement subroutine dostat(lab) integer lab call outcon(lab) call outcon(lab+1) return end # eatup - process rest of statement; interpret continuations subroutine eatup character gettok character ptoken(MAXTOK), t, token(MAXTOK) integer nlpar nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == SEMICOL | t == NEWLINE) break if (t == RBRACE) { call pbstr(token) break } if (t == LBRACE | t == EOF) { call synerr("unexpected brace or EOF.") call pbstr(token) break } if (t == COMMA | t == UNDERLINE) { if (gettok(ptoken, MAXTOK) ^= NEWLINE) call pbstr(ptoken) if (t == UNDERLINE) token(1) = EOS } else if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 call outstr(token) } until (nlpar < 0) if (nlpar ^= 0) call synerr("unbalanced parentheses.") return end # elseif - generate code for end of if before else subroutine elseif(lab) integer lab call outgo(lab+1) call outcon(lab) return end # equal - compare str1 to str2; return YES if equal, NO if not integer function equal(str1, str2) character str1(ARB), str2(ARB) integer i for (i = 1; str1(i) == str2(i); i = i + 1) if (str1(i) == EOS) { equal = YES return } equal = NO return end # error - print fatal error message, then die subroutine error(buf) integer buf(ARB) call remark(buf) stop end # forcod - beginning of for statement subroutine forcod(lab) character gettok character t, token(MAXTOK) integer length, labgen integer i, j, lab, nlpar include commonblocks # include cfor # string ifnot "if(.not." integer ifnot(9) data ifnot(1) /LETI/ data ifnot(2) /LETF/ data ifnot(3) /LPAREN/ data ifnot(4) /PERIOD/ data ifnot(5) /LETN/ data ifnot(6) /LETO/ data ifnot(7) /LETT/ data ifnot(8) /PERIOD/ data ifnot(9) /EOS/ 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 outtab call eatup call outdon } if (gettok(token, MAXTOK) == SEMICOL) # empty condition call outcon(lab) else { # non-empty condition call pbstr(token) 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 ^= NEWLINE & t ^= UNDERLINE) call outstr(token) } call outch(RPAREN) call outch(RPAREN) call outgo(lab+2) 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 (nlpar >= 0 & t ^= NEWLINE & t ^= UNDERLINE) { call scopy(token, 1, forstk, j) j = j + length(token) } } lab = lab + 1 # label for next's return end # fors - process end of for statement subroutine fors(lab) integer length integer i, j, lab include commonblocks # include cfor call outnum(lab) j = 1 for (i = 1; i < fordep; i = i + 1) j = j + length(forstk(j)) + 1 if (length(forstk(j)) > 0) { call outtab call outstr(forstk(j)) call outdon } call outgo(lab-1) call outcon(lab+1) fordep = fordep - 1 return end # getch - get characters from file integer function getch(c, f) character inmap character buf(MAXLINE), c integer f, i, lastc data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/ # note: MAXLINE = MAXCARD + 1 if (buf(lastc) == NEWLINE | lastc >= MAXLINE) { read(f, 1, end=10) (buf(i), i = 1, MAXCARD) 1 format(MAXCARD a1) for (i = 1; i <= MAXCARD; i = i + 1) buf(i) = inmap(buf(i)) for (i = MAXCARD; i > 0; i = i - 1) if (buf(i) ^= BLANK) break buf(i+1) = NEWLINE lastc = 0 } lastc = lastc + 1 c = buf(lastc) getch = c return 10 c = EOF getch = EOF return end # getdef (for no arguments) - get name and definition subroutine getdef(token, toksiz, defn, defsiz, fd) character gtok, ngetch integer defsiz, fd, i, nlpar, toksiz character c, defn(defsiz), token(toksiz) if (ngetch(c, fd) ^= LPAREN) call remark("missing left paren.") if (gtok(token, toksiz, fd) ^= ALPHA) call remark("non-alphanumeric name.") else if (ngetch(c, fd) ^= COMMA) call remark("missing comma in define.") # else got (name, nlpar = 0 for (i = 1; nlpar >= 0; i = i + 1) if (i > defsiz) call error("definition too long.") else if (ngetch(defn(i), fd) == EOF) call error("missing right paren.") else if (defn(i) == LPAREN) nlpar = nlpar + 1 else if (defn(i) == RPAREN) nlpar = nlpar - 1 # else normal character in defn(i) defn(i-1) = EOS return end # gettok - get token. handles file inclusion and line numbers character function gettok(token, toksiz) integer equal, open integer junk, toksiz character deftok character name(MAXNAME), token(toksiz) include commonblocks # include cline # string incl "include" integer incl(8) data incl(1) /LETI/ data incl(2) /LETN/ data incl(3) /LETC/ data incl(4) /LETL/ data incl(5) /LETU/ data incl(6) /LETD/ data incl(7) /LETE/ data incl(8) /EOS/ for ( ; level > 0; level = level - 1) { for (gettok = deftok(token, toksiz, infile(level)); gettok ^= EOF; gettok = deftok(token, toksiz, infile(level))) { if (equal(token, incl) == NO) return junk = deftok(name, MAXNAME, infile(level)) if (level >= NFILES) call synerr("includes nested too deeply.") else { infile(level+1) = open(name, READONLY) linect(level+1) = 1 if (infile(level+1) == ERR) call synerr("can't open include.") else level = level + 1 } } if (level > 1) call close(infile(level)) } gettok = EOF return end # gtok - get token for Ratfor character function gtok(lexstr, toksiz, fd) character ngetch, type integer fd, i, toksiz character c, lexstr(toksiz) include commonblocks # include cline while (ngetch(c, fd) ^= EOF) if (c ^= BLANK & c ^= TAB) break call putbak(c) for (i = 1; i < toksiz-1; i = i + 1) { gtok = type(ngetch(lexstr(i), fd)) if (gtok ^= LETTER & gtok ^= DIGIT) break } if (i >= toksiz-1) call synerr("token too long.") if (i > 1) { # some alpha seen call putbak(lexstr(i)) # went one too far lexstr(i) = EOS gtok = ALPHA } else if (lexstr(1) == DOLLAR) { # allow $( and $) for { and } if (ngetch(lexstr(2), fd) == LPAREN) { lexstr(1) = LBRACE gtok = LBRACE } else if (lexstr(2) == RPAREN) { lexstr(1) = RBRACE gtok = RBRACE } else call putbak(lexstr(2)) } else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) { for (i = 2; ngetch(lexstr(i), fd) ^= lexstr(1); i = i + 1) if (lexstr(i) == NEWLINE | i >= toksiz-1) { call synerr("missing quote.") lexstr(i) = lexstr(1) call putbak(NEWLINE) break } } else if (lexstr(1) == SHARP) { # strip comments while (ngetch(lexstr(1), fd) ^= NEWLINE) ; gtok = NEWLINE } else if (lexstr(1) == GREATER | lexstr(1) == LESS | lexstr(1) == NOT | lexstr(1) == EQUALS | lexstr(1) == AMPER | lexstr(1) == BAR) call relate(lexstr, i, fd) lexstr(i+1) = EOS if (lexstr(1) == NEWLINE) linect(level) = linect(level) + 1 return end # ifcode - generate initial code for if subroutine ifcode(lab) integer labgen integer lab lab = labgen(2) call ifgo(lab) return end # ifgo - generate "if(.not.(...))goto lab" subroutine ifgo(lab) integer lab # string ifnot "if(.not." integer ifnot(9) data ifnot(1) /LETI/ data ifnot(2) /LETF/ data ifnot(3) /LPAREN/ data ifnot(4) /PERIOD/ data ifnot(5) /LETN/ data ifnot(6) /LETO/ data ifnot(7) /LETT/ data ifnot(8) /PERIOD/ data ifnot(9) /EOS/ call outtab # get to column 7 call outstr(ifnot) # " if(.not. " call balpar # collect and output condition call outch(RPAREN) # " ) " call outgo(lab) # " goto lab " return end # index - find character c in string str integer function index(str, c) character c, str(ARB) for (index = 1; str(index) ^= EOS; index = index + 1) if (str(index) == c) return index = 0 return end # initkw - install keyword "define" in table subroutine initkw # string defnam "define" integer defnam(7), deftyp(2) data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ data defnam(7) /EOS/ data deftyp(1), deftyp(2) /DEFTYPE, EOS/ call instal(defnam, deftyp) return end # inmap - convert left adjusted external rep to right adj ascii integer function inmap(inchar) integer i, inchar include commonblocks # include cchar if (inchar == extblk) { inmap = intblk return } do i = 1, 10 if (inchar == extdig(i)) { inmap = intdig(i) return } do i = 1, 26 if (inchar == extlet(i)) { inmap = intlet(i) return } do i = 1, 26 if (inchar == extbig(i)) { inmap = intbig(i) return } do i = 1, NCHARS if (inchar == extchr(i)) { inmap = intchr(i) return } inmap = inchar return end # instal - add name and definition to table subroutine instal(name, defn) character defn(MAXTOK), name(MAXDEF) integer length integer dlen, nlen include commonblocks # include clook nlen = length(name) + 1 dlen = length(defn) + 1 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { call putlin(name, ERROUT) call remark(": too many definitions.") } lastp = lastp + 1 namptr(lastp) = lastt + 1 call scopy(name, 1, table, lastt + 1) call scopy(defn, 1, table, lastt + nlen + 1) lastt = lastt + nlen + dlen return end # itoc - convert integer int to char string in str integer function itoc(int, str, size) integer abs, mod integer d, i, int, intval, j, k, size character str(size) # string digits "0123456789" integer digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ intval = abs(int) str(1) = EOS i = 1 repeat { # generate digits i = i + 1 d = mod(intval, 10) str(i) = digits(d+1) intval = intval / 10 } until (intval == 0 | i >= size) if (int < 0 & i < size) { # then sign i = i + 1 str(i) = MINUS } itoc = i - 1 for (j = 1; j < i; j = j + 1) { # then reverse k = str(i) str(i) = str(j) str(j) = k i = i - 1 } return end # labelc - output statement number subroutine labelc(lexstr) character lexstr(ARB) integer length if (length(lexstr) == 5) # warn about 23xxx labels if (lexstr(1) == DIG2 & lexstr(2) == DIG3) call synerr("warning: possible label conflict.") call outstr(lexstr) call outtab return end # labgen - generate n consecutive labels, return first one integer function labgen(n) integer label, n data label /23000/ labgen = label label = label + n return end # length - compute length of string integer function length(str) integer str(ARB) for (length = 0; str(length+1) ^= EOS; length = length + 1) ; return end # lex - return lexical type of token integer function lex(lexstr) character gettok character lexstr(MAXTOK) integer alldig, equal include commonblocks # include ckeywd while (gettok(lexstr, MAXTOK) == NEWLINE) ; lex = lexstr(1) if (lex==EOF | lex==SEMICOL | lex==LBRACE | lex==RBRACE) return if (alldig(lexstr) == YES) lex = LEXDIGITS else if (equal(lexstr, sif) == YES) lex = vif(1) else if (equal(lexstr, selse) == YES) lex = velse(1) else if (equal(lexstr, swhile) == YES) lex = vwhile(1) else if (equal(lexstr, sdo) == YES) lex = vdo(1) else if (equal(lexstr, sbreak) == YES) lex = vbreak(1) else if (equal(lexstr, snext) == YES) lex = vnext(1) else if (equal(lexstr, sfor) == YES) lex = vfor(1) else if (equal(lexstr, srept) == YES) lex = vrept(1) else if (equal(lexstr, suntil) == YES) lex = vuntil(1) else lex = LEXOTHER return end # lookup - locate name, extract definition from table integer function lookup(name, defn) character defn(MAXDEF), name(MAXTOK) integer i, j, k include commonblocks # include clook for (i = lastp; i > 0; i = i - 1) { j = namptr(i) for (k = 1; name(k) == table(j) & name(k) ^= EOS; k = k + 1) j = j + 1 if (name(k) == table(j)) { # got one call scopy(table, j+1, defn, 1) lookup = YES return } } lookup = NO return end # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd include commonblocks # include cdefio if (bp > 0) c = buf(bp) else { bp = 1 buf(bp) = getch(c, fd) } bp = bp - 1 ngetch = c return end # open - exceedingly temporary version for gettok integer function open(name, mode) character name(MAXNAME) integer ctoi integer i, mode i = 1 open = ctoi(name, i) return end # otherc - output ordinary Fortran statement subroutine otherc(lexstr) character lexstr(ARB) call outtab call outstr(lexstr) call eatup call outdon return end # outch - put one character into output buffer subroutine outch(c) character c integer i include commonblocks # 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 # outcon - output "n continue" subroutine outcon(n) integer n # string contin "continue" integer contin(9) data contin(1) /LETC/ data contin(2) /LETO/ data contin(3) /LETN/ data contin(4) /LETT/ data contin(5) /LETI/ data contin(6) /LETN/ data contin(7) /LETU/ data contin(8) /LETE/ data contin(9) /EOS/ if (n > 0) call outnum(n) call outtab call outstr(contin) call outdon return end # outdon - finish off an output line subroutine outdon include commonblocks # include coutln outbuf(outp+1) = NEWLINE outbuf(outp+2) = EOS call putlin(outbuf, STDOUT) outp = 0 return end # outgo - output "goto n" subroutine outgo(n) integer n # string goto "goto" integer goto(6) data goto(1) /LETG/ data goto(2) /LETO/ data goto(3) /LETT/ data goto(4) /LETO/ data goto(5) /BLANK/ data goto(6) /EOS/ call outtab call outstr(goto) call outnum(n) call outdon return end # outmap - convert right adj ascii to left adjusted external rep integer function outmap(inchar) integer i, inchar include commonblocks # include cchar if (inchar == intblk) { outmap = extblk return } do i = 1, 10 if (inchar == intdig(i)) { outmap = extdig(i) return } do i = 1, 26 if (inchar == intlet(i)) { outmap = extlet(i) return } do i = 1, 26 if (inchar == intbig(i)) { outmap = extbig(i) return } do i = 1, NCHARS if (inchar == intchr(i)) { outmap = extchr(i) return } outmap = inchar return end # outnum - output decimal number subroutine outnum(n) character chars(MAXCHARS) integer itoc integer i, len, n len = itoc(n, chars, MAXCHARS) for (i = 1; i <= len; i = i + 1) call outch(chars(i)) return end # outstr - output string subroutine outstr(str) character c, str(ARB) integer i, j for (i = 1; str(i) ^= EOS; i = i + 1) { c = str(i) if (c ^= SQUOTE & c ^= DQUOTE) call outch(c) else { i = i + 1 for (j = i; str(j) ^= c; j = j + 1) # find end ; call outnum(j-i) call outch(LETH) for ( ; i < j; i = i + 1) call outch(str(i)) } } return end # outtab - get past column 6 subroutine outtab include commonblocks # include coutln while (outp < 6) call outch(BLANK) return end # parse - parse Ratfor source program subroutine parse character lexstr(MAXTOK) integer lex integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token call initkw # install keywords in table sp = 1 lextyp(1) = EOF for (token = lex(lexstr); token ^= EOF; token = lex(lexstr)) { if (token == LEXIF) call ifcode(lab) else if (token == LEXDO) call docode(lab) else if (token == LEXWHILE) call whilec(lab) else if (token == LEXFOR) call forcod(lab) else if (token == LEXREPEAT) call repcod(lab) else if (token == LEXDIGITS) call labelc(lexstr) else if (token == LEXELSE) { if (lextyp(sp) == LEXIF) call elseif(labval(sp)) else call synerr("illegal else.") } if (token==LEXIF | token==LEXELSE | token==LEXWHILE | token==LEXFOR | token==LEXREPEAT | token==LEXDO | token==LEXDIGITS | token==LBRACE) { sp = sp + 1 # beginning of statement if (sp > MAXSTACK) call error("stack overflow in parser.") lextyp(sp) = token # stack type and value labval(sp) = lab } else { # end of statement - prepare to unstack if (token == RBRACE) { if (lextyp(sp) == LBRACE) sp = sp - 1 else call synerr("illegal right brace.") } else if (token == LEXOTHER) call otherc(lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt(sp, lextyp, labval, token) 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 # pbstr - push string back onto input subroutine pbstr(in) character in(ARB) integer length integer i for (i = length(in); i > 0; i = i - 1) call putbak(in(i)) return end # putbak - push character back onto input subroutine putbak(c) character c include commonblocks # include cdefio bp = bp + 1 if (bp > BUFSIZE) call error("too many characters pushed back.") buf(bp) = c return end # putch (interim version) put characters subroutine putch(c, f) integer buf(MAXLINE), c integer outmap integer f, i, lastc data lastc /0/ if (lastc >= MAXLINE | c == NEWLINE) { if ( lastc <= 0 ) { write(f,2) 2 format(/) } else { write(f, 1) (buf(i), i = 1, lastc) 1 format(MAXCARD a1) } lastc = 0 } if (c ^= NEWLINE) { lastc = lastc + 1 buf(lastc) = outmap(c) } return end # putlin - put out line by repeated calls to putch subroutine putlin(b, f) character b(ARB) integer f, i for (i = 1; b(i) ^= EOS; i = i + 1) call putch(b(i), f) return end # relate - convert relational shorthands into long form subroutine relate(token, last, fd) character ngetch character token(ARB) integer length integer fd, last # string dotge ".ge." # string dotgt ".gt." # string dotlt ".lt." # string dotle ".le." # string dotne ".ne." # string dotnot ".not." # string doteq ".eq." # string dotand ".and." # string dotor ".or." integer dotge(5), dotgt(5), dotlt(5), dotle(5) integer dotne(5), dotnot(6), doteq(5), dotand(6), dotor(5) data dotge(1), dotge(2), dotge(3), dotge(4), dotge(5)/ PERIOD, LETG, LETE, PERIOD, EOS/ data dotgt(1), dotgt(2), dotgt(3), dotgt(4), dotgt(5)/ PERIOD, LETG, LETT, PERIOD, EOS/ data dotle(1), dotle(2), dotle(3), dotle(4), dotle(5)/ PERIOD, LETL, LETE, PERIOD, EOS/ data dotlt(1), dotlt(2), dotlt(3), dotlt(4), dotlt(5)/ PERIOD, LETL, LETT, PERIOD, EOS/ data dotne(1), dotne(2), dotne(3), dotne(4), dotne(5)/ PERIOD, LETN, LETE, PERIOD, EOS/ data doteq(1), doteq(2), doteq(3), doteq(4), doteq(5)/ PERIOD, LETE, LETQ, PERIOD, EOS/ data dotor(1), dotor(2), dotor(3), dotor(4), dotor(5)/ PERIOD, LETO, LETR, PERIOD, EOS/ data dotand(1), dotand(2), dotand(3), dotand(4), dotand(5), dotand(6) /PERIOD, LETA, LETN, LETD, PERIOD, EOS/ data dotnot(1), dotnot(2), dotnot(3), dotnot(4), dotnot(5), dotnot(6) /PERIOD, LETN, LETO, LETT, PERIOD, EOS/ if (ngetch(token(2), fd) ^= EQUALS) call putbak(token(2)) if (token(1) == GREATER) { if (token(2) == EQUALS) call scopy(dotge, 1, token, 1) else call scopy(dotgt, 1, token, 1) } else if (token(1) == LESS) { if (token(2) == EQUALS) call scopy(dotle, 1, token, 1) else call scopy(dotlt, 1, token, 1) } else if (token(1) == NOT) { 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) == AMPER) call scopy(dotand, 1, token, 1) else if (token(1) == BAR) call scopy(dotor, 1, token, 1) else # can't happen token(2) = EOS last = length(token) return end # remark - print warning message # this version is intentionally crude, and should be replaced # instantaneously by something tuned for your # specific environment. subroutine remark(buf) integer buf(ARB), i write(ERROUT, 10) (buf(i), i = 1, 5) 10 format(5a4) return end # 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) lab = lab + 1 # label to go on next's return end # scopy - copy string at from(i) to to(j) subroutine scopy(from, i, to, j) character from(ARB), to(ARB) integer i, j, k1, k2 k2 = j for (k1 = i; from(k1) ^= EOS; k1 = k1 + 1) { to(k2) = from(k1) k2 = k2 + 1 } to(k2) = EOS return end # synerr - report Ratfor syntax error subroutine synerr(msg) character lc(MAXLINE), msg(MAXLINE) integer itoc integer i, junk include commonblocks # include cline call remark("error at line.") for (i = 1; i <= level; i = i + 1) { call putch(BLANK, ERROUT) junk = itoc(linect(i), lc, MAXLINE) call putlin(lc, ERROUT) } call putch(COLON, ERROUT) call putch(NEWLINE, ERROUT) call remark(msg) return end # type - return LETTER, DIGIT or character # this one works with ascii alphabet integer function type(c) integer c if( c >= DIG0 & c <= DIG9 ) type = DIGIT else if( c >= LETA & c <= LETZ ) type = LETTER else if( c >= BIGA & c <= BIGZ ) type = LETTER else type = c return end # 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) == LBRACE) break if (lextyp(sp) == LEXIF & token == LEXELSE) break if (lextyp(sp) == LEXIF) call outcon(labval(sp)) else if (lextyp(sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon(labval(sp)+1) } else if (lextyp(sp) == LEXDO) call dostat(labval(sp)) else if (lextyp(sp) == LEXWHILE) call whiles(labval(sp)) else if (lextyp(sp) == LEXFOR) call fors(labval(sp)) else if (lextyp(sp) == LEXREPEAT) call untils(labval(sp), token) } return end # untils - generate code for until or end of repeat subroutine untils(lab, token) character ptoken(MAXTOK) integer lex integer junk, lab, token call outnum(lab) if (token == LEXUNTIL) { junk = lex(ptoken) call ifgo(lab-1) } else call outgo(lab-1) call outcon(lab+1) return end # whilec - generate code for beginning of while subroutine whilec(lab) integer labgen integer lab call outcon(0) # unlabeled continue, in case there was a label lab = labgen(2) call outnum(lab) call ifgo(lab+1) return end # whiles - generate code for end of while subroutine whiles(lab) integer lab call outgo(lab) call outcon(lab+1) return end