# ARCHIVE MAIN.RAT 24 27-MAR-80 17:53:31 #-------------------------------------------------------------------- #include symbols definitions # include symbols include rat4sym #-------------------------------------------------------------------- ## rat4 -- main program #BKY subroutine driver call initr4 call rat4 call endr4 end #BKY #assembly code main program (used to avoid loading fortran I/O) #BKY % #BKY ident main #BKY entry main #BKY vfd 42/0lmain,18/main #BKY ext driver #BKY rj uzero00 #BKY rj driver #BKY end main #BKY% # ARCHIVE RAT4S.RAT 83 12-JUN-80 16:52:32 ##rat4 - driver subroutine for ratfor compiler /*/sor/rat4r/rat4s subroutine rat4 integer getarg, open, pmatch, index character buf(MAXLINE) character sym(FILENAMESIZE) #file containing general definitions character symbls(8) #standard part of file spec for symbols character symflg(9) # /SYMBOLS flag integer i, arg1 #BKY integer ovride, inbuf(OPTSIZE), outbf(OPTSIZE) include cline #needed to set input file # initialize standard part of file specification data symbls /BIGS, BIGY, BIGM, BIGB, BIGO, BIGL, BIGS, EOS/ data symflg /SLASH, BIGS, BIGY, BIGM, BIGB, BIGO, BIGL, BIGS, EOS/ #set STDOUT file type to that needed by fortran compiler #BKY if (ovride (STDOUT) == NO) #BKY call settyp (STDOUT, CDC) #Expand I/O buffers for BKY #BKY call xpdfet (STDOUT, outbf, OPTSIZE) call initrt #initialize variables call xitsta(1) arg1 = 1 if (getarg(1,buf,MAXLINE) ~= EOF) if (pmatch(buf, symflg) == YES) { arg1 = 2 # read file containing standard definitions infile(1) = open(symbls, READ) if (infile(1) == ERR) { call usrbin(sym) # get portion of file name for usr/bin for (i=1; sym(i) ~= EOS; i=i+1) ; # move pointer to end call scopy(symbls, 1, sym, i) # copy remainder of name into sym infile(1) = open (sym, READ) } if (infile(1) == ERR) { call xitsta(4) call error ("can't open symbols file.") } else { call parse call close (infile(1)) } } # loop through all input files for (i = arg1; ; i=i+1) { if (getarg(i,buf,MAXLINE) == EOF) { if (i ~= arg1) break infile(1) = STDIN } else if (buf(1) == QMARK & buf(2) == EOS) { call error ('usage: rat4 [file ...] >outfile.') } else if (buf(1) == MINUS & buf(2) == EOS) infile(1) = STDIN else { infile(1) = open(buf,READ) if (infile(1) == ERR) { call xitsta(4) call cant(buf) } } #For BKY, expand input buffer #BKY call xpdfet (infile(1), inbuf, OPTSIZE) call parse if (infile(1) ~= STDIN) call close(infile(1)) } return end # ARCHIVE BALPAR.RAT 33 10-APR-80 23:43:44 ## 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) if (t == COMMA) call outch(BLANK) } until (nlpar <= 0) if (nlpar ~= 0) call synerr('missing parenthesis in condition.') return end # ARCHIVE BRKNXT.RAT 36 25-MAR-80 01:22: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 include cgoto 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) call outgo(labval(i)+10) else call outgo(labval(i)) xfer = YES return } if (token == LEXBREAK) call synerr('illegal break.') else call synerr('illegal next.') return end # ARCHIVE DEFTOK.RAT 24 25-MAR-80 01:22:58 ## deftok - get token; process macro calls and invocations character function deftok(token, toksiz, fd) character gtok integer fd, toksiz character defn(MAXDEF), t, token(MAXTOK) 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 # ARCHIVE DOCODE.RAT 22 11-APR-80 02:36:43 ## docode - generate code for beginning of do subroutine docode(lab) integer labgen integer lab include cgoto # string dostr 'do' character dostr(4) data dostr(1), dostr(2), dostr(3), dostr(4)/BIGD, BIGO, BLANK, EOS/ xfer = NO call outtab call outstr(dostr) lab = labgen(2) call outnum(lab) call outch(BLANK) call eatup call outdon call inden(2) return end # ARCHIVE DOSTAT.RAT 9 11-APR-80 02:36:44 ## dostat - generate code for end of do statement subroutine dostat(lab) integer lab call outden(2) call outcon(lab) call outcon(lab+10) return end # ARCHIVE EATUP.RAT 47 22-JUN-80 23:17:32 ## eatup - process rest of statement; interpret continuations 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 if (t == RBRACE | t == LBRACE) { 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 == NOT | 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.') return end # ARCHIVE ELSEIF.RAT 10 11-APR-80 11:44:18 ## elseif - generate code for end of if before else subroutine elseif(lab) integer lab call outgo(lab+10) call outden(1) call outcon(lab) call inden(1) return end # ARCHIVE FORCOD.RAT 97 22-JUN-80 23:17:33 ## forcod - beginning of for statement subroutine forcod(lab) character gettok character t, token(MAXTOK) integer length, labgen integer i, j, lab, nlpar include cfor # string ifnot 'if (.not.' character ifnot(10) data ifnot(1) /BIGI/ data ifnot(2) /BIGF/ data ifnot(3) /BLANK/ data ifnot(4) /LPAREN/ data ifnot(5) /PERIOD/ data ifnot(6) /BIGN/ data ifnot(7) /BIGO/ data ifnot(8) /BIGT/ data ifnot(9) /PERIOD/ data ifnot(10) /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 == EOF) { call pbstr(token) return } if (t ~= NEWLINE) call outstr(token) } call outch(RPAREN) call outch(RPAREN) call outch(BLANK) call outgo(lab+20) 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 error('for clause too long.') call scopy(token, 1, forstk, j) j = j + length(token) } } call inden(2) lab = lab + 10 # label for next's return end # ARCHIVE FORS.RAT 24 11-APR-80 02:36:47 ## fors - process end of for statement subroutine fors(lab) integer length integer i, j, lab include cfor include cgoto xfer = NO 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-10) call outden(2) call outcon(lab+10) fordep = fordep - 1 return end # ARCHIVE GETDEF.RAT 50 25-MAR-80 01:23:00 ## 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(MAXDEF), token(MAXTOK), t, ptoken(MAXTOK) c = gtok(ptoken, MAXTOK, fd) if (c == LPAREN) t = LPAREN # define (name, defn) else { t = BLANK # define name defn call pbstr(ptoken) } if (gtok(token, toksiz, fd) ~= ALPHA) call error('non-alphanumeric name.') c = gtok(ptoken, MAXTOK, fd) if (t == BLANK) { # define name defn call pbstr(ptoken) i = 1 repeat { c = ngetch(c, fd) if (i > defsiz) call error('definition too long.') defn(i) = c i = i + 1 } until (c == SHARP | c == NEWLINE | c == EOF) if (c == SHARP) call putbak(c) } else if (t == LPAREN) { # define (name, defn) if (c ~= COMMA) call error('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) } else call error('getdef is confused.') defn(i-1) = EOS return end # ARCHIVE GETTOK.RAT 89 25-MAR-80 01:23:01 ## gettok - get token. handles file inclusion and line numbers character function gettok(token, toksiz) integer equal, open integer t, i, j, toksiz character deftok character name(FILENAMESIZE), token(MAXTOK), filnam(FILENAMESIZE) include cline include cfname # string incl 'include' character incl(8) # string fncn 'function' character fncn(9) data incl(1) /BIGI/ data incl(2) /BIGN/ data incl(3) /BIGC/ data incl(4) /BIGL/ data incl(5) /BIGU/ data incl(6) /BIGD/ data incl(7) /BIGE/ data incl(8) /EOS/ data fncn(1) /BIGF/ data fncn(2) /BIGU/ data fncn(3) /BIGN/ data fncn(4) /BIGC/ data fncn(5) /BIGT/ data fncn(6) /BIGI/ data fncn(7) /BIGO/ data fncn(8) /BIGN/ data fncn(9) /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, fncn) == YES) { t = deftok(fcname, MAXNAME, infile(level)) call pbstr(fcname) return } if (equal(token, incl) == NO) return i = 0 #pick up file name -- watch out for characters that might #have been processed by deftok repeat { t = deftok(name, FILENAMESIZE, infile(level)) for (j = 1; name(j) ~= EOS; j = j + 1) { i = i + 1 filnam(i) = name(j) #IAS if (filnam(i) == LBRACE) filnam(i) = LBRACK #IAS if (filnam(i) == RBRACE) filnam(i) = RBRACK if (filnam(i) == LBRACE) filnam(i) = LBRACK if (filnam(i) == RBRACE) filnam(i) = RBRACK } } until (t == NEWLINE | t == SEMICOL) filnam(i) = EOS if (level >= NFILES) call synerr('includes nested too deeply.') else { infile(level+1) = open(filnam, READ) linect(level+1) = 1 if (infile(level+1) == ERR) { call putlin(filnam, ERROUT) call synerr ("can't open include.") #NOTIAS #IAS call synerr ('can''t open include') } else { level = level + 1 if (fnamp + i <= MAXFNAMES) { call scopy(filnam, 1, fnames, fnamp) fnamp = fnamp + i # push file name stack } } } } if (level > 1) { # close include and pop file name stack call close(infile(level)) for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1) if (fnames(fnamp-1) == EOS) break } } token(1) = EOF # in case called more than once token(2) = EOS gettok = EOF return end # ARCHIVE GTOK.RAT 76 25-JUN-80 23:06:21 ## gtok - get token for Ratfor character function gtok(lexstr, toksiz, fd) character ngetch, type integer fd, i, toksiz character c, lexstr(MAXTOK) include cline while (ngetch(c, fd) ~= EOF) if (c ~= BLANK & c ~= TAB) break call putbak(c) for (i = 1; i <= toksiz; i = i + 1) { gtok = type(ngetch(lexstr(i), fd)) if (gtok ~= LETTER & gtok ~= DIGIT) break } if (i > toksiz) { call synerr('token too long.') i = i-1 } if (i > 1) { # some alpha seen call putbak(lexstr(i)) # went one too far i = i-1 gtok = ALPHA } else if (lexstr(1) == LBRACK) { # allow [ for { lexstr(1) = LBRACE gtok = LBRACE } else if (lexstr(1) == RBRACK) { # allow ] for } lexstr(1) = RBRACE gtok = RBRACE } 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) { for ( ; i > 1; i = i-1) #wpw call putbak(lexstr(i)) #wpw break } else if (i >= toksiz-1) { call synerr('missing quote.') lexstr(i) = lexstr(1) call putbak(NEWLINE) break } } else if (lexstr(1) == SHARP) { # output comments call putch(BIGC, STDOUT) while (ngetch(lexstr(1), fd) ~= NEWLINE) call putch(lexstr(1), STDOUT) call putch(NEWLINE, STDOUT) gtok = NEWLINE } else if (lexstr(1) == GREATER | lexstr(1) == LESS | lexstr(1) == NOT | lexstr(1) == BANG | lexstr(1) == CARET | lexstr(1) == BACKSLASH | lexstr(1) == EQUALS | lexstr(1) == AND | lexstr(1) == OR) call relate(lexstr, i, fd) lexstr(i+1) = EOS if (lexstr(1) == NEWLINE) linect(level) = linect(level) + 1 return end # ARCHIVE IFCODE.RAT 13 11-APR-80 02:36:51 ## ifcode - generate initial code for if subroutine ifcode(lab) integer labgen integer lab include cgoto xfer = NO lab = labgen(2) call ifgo(lab) call inden(2) return end # ARCHIVE IFGO.RAT 24 25-MAR-80 01:23:02 ## ifgo - generate 'if (.not.(...)) goto lab' subroutine ifgo(lab) integer lab # string ifnot 'if (.not.' character ifnot(10) data ifnot(1) /BIGI/ data ifnot(2) /BIGF/ data ifnot(3) /BLANK/ data ifnot(4) /LPAREN/ data ifnot(5) /PERIOD/ data ifnot(6) /BIGN/ data ifnot(7) /BIGO/ data ifnot(8) /BIGT/ data ifnot(9) /PERIOD/ data ifnot(10) /EOS/ 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) # ' goto lab ' return end # ARCHIVE INITKW.RAT 22 25-MAR-80 01:23:02 ## initkw - initialize table and install keywords 'define' and 'DEFINE' subroutine initkw integer i include clook # string defnam 'define' and 'DEFINE' character defnam(14), 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 defnam(8) /BIGD/, defnam(9) /BIGE/, defnam(10) /BIGF/ data defnam(11) /BIGI/, defnam(12) /BIGN/, defnam(13) /BIGE/ data defnam(14) /EOS/ data deftyp(1), deftyp(2) /DEFTYPE, EOS/ avail = 1 for (i=1; i<=127; i=i+1) tabptr(i) = 0 call instal(defnam, deftyp) call instal(defnam(8), deftyp) return end # ARCHIVE INITRT.RAT 112 25-JUN-80 23:06:24 ##initrt - initialize variables for ratfor compiler /*/sor/rat4r/initrt subroutine initrt # initialize global variables # these may be put in a block data program # if available on your system # common blocks include coutln include cline include cdefio include cfor include clook include ckeywd include cgoto include cfname include cflags # keywords: data sdo(1), sdo(2), sdo(3) /BIGD, BIGO, EOS/ data vdo(1), vdo(2) /LEXDO, EOS/ data sif(1), sif(2), sif(3) /BIGI, BIGF, EOS/ data vif(1), vif(2) /LEXIF, EOS/ data selse(1), selse(2), selse(3), selse(4), selse(5) /BIGE, BIGL, BIGS, BIGE, EOS/ data velse(1), velse(2) /LEXELSE, EOS/ data swhile(1), swhile(2), swhile(3), swhile(4), swhile(5), swhile(6) /BIGW, BIGH, BIGI, BIGL, BIGE, EOS/ data vwhile(1), vwhile(2) /LEXWHILE, EOS/ data sbreak(1), sbreak(2), sbreak(3), sbreak(4), sbreak(5), sbreak(6) /BIGB, BIGR, BIGE, BIGA, BIGK, EOS/ data vbreak(1), vbreak(2) /LEXBREAK, EOS/ data snext(1), snext(2), snext(3), snext(4), snext(5) /BIGN, BIGE, BIGX, BIGT, EOS/ data vnext(1), vnext(2) /LEXNEXT, EOS/ data sfor(1), sfor(2), sfor(3), sfor(4) /BIGF, BIGO, BIGR, EOS/ data vfor(1), vfor(2) /LEXFOR, EOS/ data srept(1), srept(2), srept(3), srept(4), srept(5), srept(6), srept(7) /BIGR, BIGE, BIGP, BIGE, BIGA, BIGT, EOS/ data vrept(1), vrept(2) /LEXREPEAT, EOS/ data slitrl(1), slitrl(2) /TOGGLE, EOS/ data vlitrl(1), vlitrl(2) /LEXLITERAL, EOS/ data suntil(1), suntil(2), suntil(3), suntil(4), suntil(5), suntil(6) /BIGU, BIGN, BIGT, BIGI, BIGL, EOS/ data vuntil(1), vuntil(2) /LEXUNTIL, EOS/ data sret(1), sret(2), sret(3), sret(4), sret(5), sret(6), sret(7) /BIGR, BIGE, BIGT, BIGU, BIGR, BIGN, EOS/ data vret(1), vret(2) /LEXRETURN, EOS/ data swrite/BIGW, BIGR, BIGI, BIGT, BIGE, EOS/ data vwrite/LEXWRITE, EOS/ data sread/BIGR, BIGE, BIGA, BIGD, EOS/ data vread/LEXREAD, EOS/ data sencod/BIGE, BIGN, BIGC, BIGO, BIGD, BIGE, EOS/ data vencod/LEXENCODE, EOS/ data sdecod/BIGD, BIGE, BIGC, BIGO, BIGD, BIGE, EOS/ data vdecod/LEXDECODE, EOS/ data sforma/BIGF, BIGO, BIGR, BIGM, BIGA, BIGT, EOS/ data vforma/LEXFORMAT, EOS/ # output character pointer #(note--this is also initialized in 'parse') data outp /0/ # indent level data indent /0/ # file conrol # (note--also initialized in 'parse') data level /1/ data linect(1) /1/ data infile(1) /STDIN/ data fnamp /2/ data fnames(1) /EOS/ # pushback buffer pointer # (note--also initialized in 'parse') data bp /0/ # depth of for stack # (note--also initialized in 'parse') data fordep /0/ # pointers for table lookup code data avail /1/ data tabptr /127*0/ # current function name for return data fcname(1) /EOS/ # flag controlling conversion of > and < to .gt. and .lt. data inform /.false./ call initkw #install keywords in table return end # ARCHIVE INSTAL.RAT 27 25-MAR-80 01:23:03 ## instal - add name and definition to table subroutine instal(name, defn) character defn(MAXDEF), name(MAXTOK) integer c integer length integer dlen, nlen include clook nlen = length(name) + 1 dlen = length(defn) + 1 if (avail + nlen + dlen > MAXTBL) { call putlin(name, ERROUT) call remark(': too many definitions.') return } c = name(1) table(avail) = tabptr(c) tabptr(c) = avail #***NOTE*** Some systems allow byte-addressable character strings # which differ in format from integered strings. Thus # special 'scopy' routines are needed to deal with them. call scopyi (name, 1, table, avail+1) call scopyi (defn, 1, table, avail+nlen+1) avail = avail + nlen + dlen + 1 return end # ARCHIVE LABELC.RAT 18 10-APR-80 10:05:44 ## labelc - output statement number subroutine labelc(lexstr) character lexstr(ARB) integer length, i include cgoto xfer = NO # can't suppress goto's now # if (length(lexstr) == 5) # warn about 23xxx labels # if (lexstr(1) == DIG2 & lexstr(2) == DIG3) 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 LITRAL.RAT 27 25-MAR-80 01:23:04 ## litral - process literal ratfor lines subroutine litral integer getlin include coutln include cline # Finish off any left-over characters if (outp > 0) call outdon call getlin (outbuf, infile(level)) # throw away end of current line #loop through input until matching toggle found while ( getlin (outbuf, infile(level)) ~= EOF ) { for (i=1; outbuf(i) == BLANK; i=i+1) ; if (outbuf(i) == TOGGLE) break call putlin (outbuf, STDOUT) linect(level) = linect(level) + 1 } outp = 0 return end # ARCHIVE LABGEN.RAT 9 10-APR-80 10:05:45 ## labgen - generate n consecutive labels, return first one integer function labgen(n) integer label, n data label /2000/ labgen = label label = label + n*10 return end # ARCHIVE LEX.RAT 51 25-JUN-80 23:06:28 ## lex - return lexical type of token integer function lex(lexstr) character gettok character lexstr(MAXTOK) integer alldig, equal 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 if (equal(lexstr, sret) == YES) lex = vret(1) else if (equal(lexstr, slitrl) == YES) lex = vlitrl(1) else if (equal(lexstr, swrite) == YES) lex = vwrite(1) else if (equal(lexstr, sread) == YES) lex = vread(1) else if (equal(lexstr, sencod) == YES) lex = vencod(1) else if (equal(lexstr, sdecod) == YES) lex = vdecod(1) else if (equal(lexstr, sforma) == YES) lex = vforma(1) else lex = LEXOTHER return end # ARCHIVE LOOKUP.RAT 25 25-MAR-80 01:23:05 ## lookup - locate name, extract definition from table integer function lookup(name, defn) character defn(MAXDEF), name(MAXTOK) integer i, j, k , c include clook c = name(1) for (i = tabptr(c); i > 0; i = table(i)) { j = i + 1 for (k = 1; name(k) == table(j) & name(k) ~= EOS; k = k + 1) j = j + 1 if (name(k) == table(j)) { # got one #***NOTE*** Some systems allow byte-addressable character # strings, which differ from integer strings. Thus # special 'scopy' routines are needed to deal with # them. call icopys(table, j+1, defn, 1) lookup = YES return } } lookup = NO return end # ARCHIVE NGETCH.RAT 28 23-JUN-80 00:24:50 ## ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c, c2 integer fd include cdefio 10 if (bp > 0) { c = buf(bp) bp = bp - 1 } else c = getch(c, fd) if (c == UNDERLINE) { if (bp > 0) { c2 = buf(bp) bp = bp - 1 } else c2 = getch(c2, fd) if (c2 == NEWLINE) goto 10 call putbak(c2) } ngetch = c return end # ARCHIVE OTHERC.RAT 13 25-MAR-80 01:23:05 ## otherc - output ordinary Fortran statement subroutine otherc(lexstr) character lexstr(ARB) include cgoto xfer = NO call outtab call outstr(lexstr) call eatup call outdon return end # ARCHIVE OUTCH.RAT 18 25-MAR-80 01:23:06 ## 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 OUTCON.RAT 28 25-MAR-80 01:23:06 ## outcon - output 'n continue' subroutine outcon(n) integer n include cgoto include coutln # string contin 'continue' character contin(9) data contin(1) /BIGC/ data contin(2) /BIGO/ data contin(3) /BIGN/ data contin(4) /BIGT/ data contin(5) /BIGI/ data contin(6) /BIGN/ data contin(7) /BIGU/ data contin(8) /BIGE/ data contin(9) /EOS/ 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 11 25-MAR-80 01:23:06 ## outdon - finish off an output line subroutine outdon include coutln outbuf(outp+1) = NEWLINE outbuf(outp+2) = EOS call putlin(outbuf, STDOUT) outp = 0 return end # ARCHIVE OUTGO.RAT 22 25-MAR-80 01:23:06 ## outgo - output 'goto n' subroutine outgo(n) integer n include cgoto # string goto 'goto' character goto(6) data goto(1) /BIGG/ data goto(2) /BIGO/ data goto(3) /BIGT/ data goto(4) /BIGO/ data goto(5) /BLANK/ data goto(6) /EOS/ if (xfer == YES) return call outtab call outstr(goto) call outnum(n) call outdon return end # ARCHIVE OUTNUM.RAT 30 25-MAR-80 01:23:07 ## outnum - output positive decimal number subroutine outnum(n) character chars(MAXCHARS) integer d, i, m # string digits '0123456789' character 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/ m = n i = 0 repeat { i = i + 1 d = mod(m, 10) chars(i) = digits(d+1) m = m / 10 } until (m == 0 | i >= MAXCHARS) for ( ; i > 0; i = i - 1) call outch(chars(i)) return end # ARCHIVE OUTSTR.RAT 34 25-JUN-80 23:06:32 ## outstr - output string subroutine outstr(str) #***NOTE*** - strings on BKY were converted to nL... format, a # hollerith string terminated with a zero byte. #***NOTE*** - modified to put out quoted literals character c, str(ARB) integer i, j for (i = 1; str(i) ~= EOS; i = i + 1) { c = str(i) if ((c ~= SQUOTE & c ~= DQUOTE) | str(i+1) == EOS) call outch(c) else { call outch(SQUOTE) for (i = i + 1; str(i) ~= c; i = i + 1) { if (str(i) == SQUOTE) call outch(SQUOTE) # "'" -> '''' call outch(str(i)) } call outch(SQUOTE) # i = i + 1 # for (j = i; str(j) ~= c; j = j + 1) # find end # ; # call outnum(j-i) # call outch (BIGH) #NOTBKY # #BKY call outch (BIGL) # for ( ; i < j; i = i + 1) # call outch(str(i)) } } return end # ARCHIVE OUTTAB.RAT 11 11-APR-80 02:38:45 ## 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 93 25-JUN-80 23:06:34 ## parse - parse Ratfor source program subroutine parse character lexstr(MAXTOK) integer lex integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token include coutln include cline include cdefio include cfor include cfname include cgoto include ckeywd include cflags #initialize variables for current input file outp = 0 indent = 0 level = 1 linect(1) = 1 fnamp = 2 fnames(1) = EOS bp = 0 fordep = 0 fcname(1) = EOS 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.') } else if (token == LEXLITERAL) call litral 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 == LEXWRITE) call format(swrite) else if (token == LEXREAD) call format(sread) else if (token == LEXENCODE) call format(sencod) else if (token == LEXDECODE) call format(sdecod) else if (token == LEXFORMAT) { inform = .true. call otherc(lexstr) inform = .false. } else if (token == LEXBREAK | token == LEXNEXT) call brknxt(sp, lextyp, labval, token) else if (token == LEXRETURN) call retcod 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 PBSTR.RAT 10 25-MAR-80 01:23:08 ## 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 # ARCHIVE PUTBAK.RAT 12 25-MAR-80 01:23:08 ## putbak - push character back onto input subroutine putbak(c) character c include cdefio bp = bp + 1 if (bp > BUFSIZE) call error('too many characters pushed back.') buf(bp) = c return end # ARCHIVE RELATE.RAT 78 25-JUN-80 23:06:37 ## relate - convert relational shorthands into long form subroutine relate(token, last, fd) character ngetch character token(ARB) integer length integer fd, last include cflags # 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. ' character dotge(7), dotgt(7), dotlt(7), dotle(7) character dotne(7), dotnot(6), doteq(7), dotand(8), dotor(7) data dotge /BLANK, PERIOD, BIGG, BIGE, PERIOD, BLANK, EOS/ data dotgt /BLANK, PERIOD, BIGG, BIGT, PERIOD, BLANK, EOS/ data dotle /BLANK, PERIOD, BIGL, BIGE, PERIOD, BLANK, EOS/ data dotlt /BLANK, PERIOD, BIGL, BIGT, PERIOD, BLANK, EOS/ data dotne /BLANK, PERIOD, BIGN, BIGE, PERIOD, BLANK, EOS/ data doteq /BLANK, PERIOD, BIGE, BIGQ, PERIOD, BLANK, EOS/ data dotor /BLANK, PERIOD, BIGO, BIGR, PERIOD, BLANK, EOS/ data dotand /BLANK, PERIOD, BIGA, BIGN, BIGD, PERIOD, BLANK, EOS/ data dotnot /PERIOD, BIGN, BIGO, BIGT, 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 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) == NOT | 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 11-APR-80 02:38:49 ## 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 36 10-APR-80 11:11:08 ## retcod - generate code for return subroutine retcod character token(MAXTOK), gettok, t include cfname include cgoto # string retrn 'return' # string eqstr ' = ' character retrn(7) character eqstr(4) data retrn(1) /BIGR/ data retrn(2) /BIGE/ data retrn(3) /BIGT/ data retrn(4) /BIGU/ data retrn(5) /BIGR/ data retrn(6) /BIGN/ data retrn(7) /EOS/ data eqstr /BLANK, EQUALS, BLANK, EOS/ t = gettok(token, MAXTOK) if (t ~= NEWLINE & t ~= SEMICOL & t ~= RBRACE) { call pbstr(token) call outtab call outstr(fcname) call outstr(eqstr) call eatup call outdon } else if (t == RBRACE) call pbstr(token) call outtab call outstr(retrn) call outdon xfer = YES return end # ARCHIVE SYNERR.RAT 9 12-JUN-80 12:01:30 # synerr - report rat4 syntax error subroutine synerr(msg) character msg(ARB) call xitsta(3) call syn2(msg, ERROUT) call syn2(msg, STDOUT) return end # ARCHIVE UNSTAK.RAT 30 11-APR-80 02:47:48 ## 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 outden(2) call outcon(labval(sp)) } else if (lextyp(sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outden(2) call outcon(labval(sp)+10) } 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 # ARCHIVE UNTILS.RAT 20 11-APR-80 02:38:51 ## 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 outnum(lab) if (token == LEXUNTIL) { junk = lex(ptoken) call ifgo(lab-10) } else call outgo(lab-10) call outden(2) call outcon(lab+10) return end # ARCHIVE WHILEC.RAT 12 11-APR-80 02:38:51 ## 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+10) call inden(2) return end # ARCHIVE WHILES.RAT 9 11-APR-80 02:38:57 ## whiles - generate code for end of while subroutine whiles(lab) integer lab call outgo(lab) call outden(2) call outcon(lab+10) return end # ARCHIVE ICOPYS.RAT 14 25-MAR-80 01:23:11 ## icopys - copy integer string to character string subroutine icopys(from, i, to, j) character to(ARB) integer from(ARB), 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 # ARCHIVE SCOPYI.RAT 14 25-MAR-80 01:23:11 ## scopyi - copy character string to integer string subroutine scopyi(from, i, to, j) character from(ARB) integer to(ARB), 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 # ARCHIVE INDEN.RAT 7 11-APR-80 11:42:04 ## inden - indent the tab position subroutine inden(ind) integer ind include coutln indent = indent + ind return end # ARCHIVE OUTDEN.RAT 7 11-APR-80 11:42:05 ## outden - outdent the tab position subroutine outden(out) integer out include coutln indent = indent - out return end # ARCHIVE SYN2.RAT 53 12-JUN-80 12:01:36 ## syn2 - report Ratfor syntax error subroutine syn2(msg, f) character lc(MAXCHARS), msg(ARB) integer itoc integer i, junk, f include cline # string serror '? error at line ' character serror(17) # string in ' in ' character in(5) data serror(1) /QMARK/ data serror(2) /BLANK/ data serror(3) /LETE/ data serror(4) /LETR/ data serror(5) /LETR/ data serror(6) /LETO/ data serror(7) /LETR/ data serror(8) /BLANK/ data serror(9) /LETA/ data serror(10) /LETT/ data serror(11) /BLANK/ data serror(12) /LETL/ data serror(13) /LETI/ data serror(14) /LETN/ data serror(15) /LETE/ data serror(16) /BLANK/ data serror(17) /EOS/ data in(1) /BLANK/ data in(2) /LETI/ data in(3) /LETN/ data in(4) /BLANK/ data in(5) /EOS/ call putlin(serror, f) if (level >= 1) i = level else i = 1 # for EOF errors junk = itoc(linect(i), lc, MAXCHARS) call putlin(lc, f) for (i = fnamp - 1; i > 1; i = i - 1) if (fnames(i-1) == EOS) { # print file name call putlin(in, f) call putlin(fnames(i), f) break } call putch(COLON, f) call putch(BLANK, f) call putlin(msg, f) call putch(NEWLINE, f) return end # ARCHIVE FORMAT.RAT 86 25-JUN-80 23:57:35 # format - output format statement for write, read, encode, and decode subroutine format(token) character token(ARB), t, tok(MAXTOK), forst(MAXFORMAT) character gettok character form(7) integer j, length, labgen, lab include cflags data form/BIGF, BIGO, BIGR, BIGM, BIGA, BIGT, EOS/ call outtab call outstr(token) t = gettok(tok, MAXTOK) if (t ~= LPAREN) { call pbstr(tok) call eatup call outdon return } call outstr(tok) call skpout(t) if (t == EOF) return if (t == RPAREN) { call eatup call outdon return } t = gettok(tok, MAXTOK) if (t ~= LPAREN) { call pbstr(tok) repeat { call skpout(t) if (t == EOF) return } until (t == RPAREN) call eatup call outdon } 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 outdon 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 SKPOUT.RAT 26 25-JUN-80 23:57:37 subroutine skpout(t) character t, tok(MAXTOK) integer nlpar, gettok 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