# # # # 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 Wood (Institute For Cancer Research). # # Address: William Wood # Computer Center # Institute For Cancer Research # 7701 Burholme Ave. # Philadelphia, Pa. 19111 # (215) 728 2760 # # Version: 1.0 # # Date: May 14, 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 * # * * # ******************************************************* # * * # * THIS SOFTWARE WAS DESIGNED FOR USE ON A * # * PDP-11/70 OPERATING UNDER IAS V3.0 USING * # * THE FORTRAN-IV PLUS COMPILER. * # * * # ******************************************************* # # ARCHIVE RATMAIN.RAT 10 04-MAY-81 18:21:45 ## ratfiv -- main program # include symbol definitions include macsym include ratsym call initr4 call ratfiv call endr4 end # ARCHIVE RAT4S.RAT 73 06-MAY-81 14:35:47 ##ratfiv - driver subroutine for ratfiv compiler /*/sor/rat4r/rat4s subroutine ratfiv 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 character stdinn(6) # STDIN string integer i, arg1 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/ data stdinn /BIGS, BIGT, BIGD, BIGI, BIGN, EOS/ call inimac # initialize macro processor call inirat #initialize variables 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) call scopy(symbls, 1, fnames, 1) 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 call scopy(sym, 1, fnames, 1) infile(1) = open (sym, READ) } if (infile(1) == ERR) { 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 call scopy(stdinn, 1, fnames, 1) } else if (buf(1) == QMARK & buf(2) == EOS) { call remark ('usage: rat [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 BALPAR.RAT 34 05-MAY-81 20:38:13 ## 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 38 13-MAY-81 01:39:42 ## 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) == LEXSWITCH | 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 if (lextyp(i) == LEXSWITCH) call synerr("illegal next.") else call outgo(labval(i)) xfer = YES return } if (token == LEXBREAK) call synerr("illegal break.") else call synerr("illegal next.") return end # ARCHIVE DOCODE.RAT 21 05-MAY-81 21:26: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 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 52 07-MAY-81 13:31: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) break else if (t == NEWLINE | 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 == 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.') if (t != LEXFUNCTION) call outdon else call outch(BLANK) return end # ARCHIVE ELSEF.RAT 10 11-APR-80 11:44:18 ## elsef - generate code for end of if before else subroutine elsef(lab) integer lab call outgo(lab+10) call outden(1) call outcon(lab) call inden(1) return end # ARCHIVE FORCOD.RAT 96 05-MAY-81 21:26:46 ## 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 } 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 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 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 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 INIRAT.RAT 97 12-MAY-81 12:23:30 ## 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), 1), 2)) 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 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 38 12-MAY-81 13:30:56 ## litral - process literal ratfiv 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)) # if not blank, output only this line # as a literal line linect(level) = linect(level) + 1 for (i = 1; outbuf(i) == BLANK; i = i+1) ; if (outbuf(i) == EOF) goto 10 if (outbuf(i) != NEWLINE) call putlin(outbuf, STDOUT) else { #loop through input until matching toggle found while (getlin (outbuf, infile(level)) != EOF) { linect(level) = linect(level) + 1 for (i=1; outbuf(i) == BLANK; i=i+1) ; if (outbuf(i) == TOGGLE) break call putlin (outbuf, STDOUT) } if (outbuf(1) == EOF) { 10 call putbak(EOF) call synerr("EOF in literal fortran code.") } } 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 20 05-MAY-81 21:10:44 ## 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 OTHERC.RAT 12 05-MAY-81 21:26:50 ## 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 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 32 13-MAY-81 00:15:22 ## 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 = iabs(n) i = 0 repeat { i = i + 1 d = mod(m, 10) chars(i) = digits(d+1) m = m / 10 } until (m == 0 | i >= MAXCHARS) if (n < 0) call outch(MINUS) for ( ; i > 0; i = i - 1) call outch(chars(i)) return end # ARCHIVE OUTSTR.RAT 45 06-MAY-81 10:42:55 ## 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 # and to strip ACCENT chars character c, str(ARB), cupper integer i, j 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 ((c != SQUOTE & c != DQUOTE) | str(i+1) == EOS) call outch(cupper(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 123 13-MAY-81 13:45:19 ## parse - parse Ratfiv source program subroutine parse character lexstr(MAXTOK) character sdecod(7), sencod(7), sread(5), swrite(6), sforma(7) 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 data sread /BIGR, BIGE, BIGA, BIGD, EOS/ data swrite /BIGW, BIGR, BIGI, BIGT, BIGE, EOS/ data sencod /BIGE, BIGN, BIGC, BIGO, BIGD, BIGE, EOS/ data sdecod /BIGD, BIGE, BIGC, BIGO, BIGD, BIGE, EOS/ data sforma /BIGF, BIGO, BIGR, BIGM, BIGA, BIGT, EOS/ #initialize variables for current input file outp = 0 indent = 0 level = 1 fnamp(1) = 1 linect(1) = 1 bp = 0 sbp = 1 fordep = 0 inform = .false. # controls conversion of > and < to .gt. and .lt. fcname(1) = EOS xfer = NO 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) case LEXELSE: if (lextyp(sp) == LEXIF) call elsef(labval(sp)) else 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: for (i = sp; i > 0; i = i-1) # find most recent switch if (lextyp(i) == LEXSWITCH) break if (i == 0) call synerr("illegal case or default.") else call cascod(labval(i), token) 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 == LEXELSE | 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 } else { # 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 RELATE.RAT 61 06-MAY-81 16:47:39 ## 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) == 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 40 05-MAY-81 21:26:53 ## 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 == 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(eqstr) } call eatup } call outtab call outstr(retrn) call outdon xfer = YES return end # ARCHIVE UNSTAK.RAT 32 12-MAY-81 22:39:40 ## 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 & 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) else if (lextyp(sp) == LEXSWITCH) call swend(labval(sp)) } 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 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 FORMAT.RAT 82 05-MAY-81 21:26:56 # forma - output format statement for write, read, encode, and decode subroutine forma(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 return } call outstr(tok) call skpout(t) if (t == EOF) return if (t == RPAREN) { call eatup return } t = gettok(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 SKPOUT.RAT 26 25-JUN-80 23:57:37 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 RINCLU.RAT 32 13-MAY-81 16:24:11 # rinclu - do include for ratfiv subroutine rinclu character file(FILENAMESIZE), t, gettok, buf(MAXTOK) integer i, j t = gettok(buf, MAXTOK) if (t == SQUOTE | t == DQUOTE) { # include "file" or 'file' for (i = 1; buf(i+1) != EOS; i = i+1) { if (i > FILENAMESIZE) { call synerr("include file name too long.") return } file(i) = buf(i+1) } file(max(i-1, 1)) = EOS } else { # include file i = 0 for ( ; t != NEWLINE & t != SEMICOL; t = gettok(buf, MAXTOK)) for (j = 1; buf(j) != EOS; j = j+1) { i = i+1 if (i >= FILENAMESIZE) { call synerr("include file name too long.") return } file(i) = buf(j) } file(i+1) = EOS } call includ(file, t) return end # ARCHIVE DFUNCT.RAT 16 05-MAY-81 18:05:01 # dfunct - define the current function name subroutine dfunct include cfname character t, gettok, funct(9) data funct /BIGF, BIGU, BIGN, BIGC, BIGT, BIGI, BIGO, BIGN, EOS/ 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 GTOKENR.RAT 92 13-MAY-81 20:20:13 ## 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 for (i = 1; i < toksiz-1; i = i + 1) { gtoken = type(ngetch(token(i))) if (gtoken != LETTER & gtoken != DIGIT & gtoken != UNDERLINE & gtoken != PERIOD) break } if (token(1) == ACCENT) { # leave stuff in here alone for (i = 2; i < toksiz-1; i = i+1) if (ngetch(token(i)) == ACCENT) { if (ngetch(token(i+1)) != ACCENT) { call putbak(token(i+1)) break } else i = i+1 } else if (token(i) == EOF) { call synerr("EOF in literal string.") token(i) = ACCENT call putbak(EOF) break } if (i >= toksiz-1) { i = toksiz-1 token(i) = ACCENT } } if (i >= toksiz-1) call synerr('token too long.') if (i > 1 & token(1) != ACCENT) { # some alpha seen c = token(i) token(i) = EOS if (c == RADIX) # check for base other than 10 if (alldig(token) == YES) { j = 1 call dobase(ctoi(token, j), token, toksiz, i) } else call putbak(RADIX) else call putbak(c) gtoken = ALPHA } else if (token(1) == SQUOTE | token(1) == DQUOTE) { for (i = 2; ngetch(token(i)) != token(1); i = i + 1) if (token(i) == NEWLINE) { for ( ; i > 1; i = i-1) # call putbak(token(i)) # break } else if (i >= toksiz-1) { call synerr('missing quote.') token(i) = token(1) call putbak(NEWLINE) break } } else if (cp == 0) { # not in a macro? if (token(1) == LBRACE) { # allow { for [ token(1) = LBRACK gtoken = LBRACK } else if (token(1) == RBRACE) { # allow } for ] token(1) = RBRACK gtoken = RBRACK } else if (token(1) == SHARP) { # output comments call putch(BIGC, STDOUT) while (ngetch(token(1)) != NEWLINE) call putch(token(1), STDOUT) call putch(NEWLINE, STDOUT) gtoken = NEWLINE } else if (token(1) == GREATER | token(1) == LESS | token(1) == NOT | token(1) == BANG | token(1) == CARET | token(1) == BACKSLASH | token(1) == EQUALS | token(1) == AND | token(1) == OR) { if (toksiz < 10) call synerr("shouldn't happen.") else call relate(token, i) } } token(i+1) = EOS return end # ARCHIVE GETTOK.RAT 10 12-MAY-81 22:39:45 # 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 DOBASE.RAT 24 12-MAY-81 11:29:37 # 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("number inconsistent with base.") } call putbak(c) i = itoc(n, token, toksiz) } else call synerr("number base out of range.") return end # ARCHIVE STRDCL.RAT 95 12-MAY-81 14:55:40 # strdcl - generate code for string declaration subroutine strdcl character t, token(MAXTOK), gettok, esc 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/ 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 (token(1) == SQUOTE | token(1) == DQUOTE) 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 (token(1) == SQUOTE | token(1) == DQUOTE) { len = length(token) token(len) = EOS call addstr(token(2), sbuf, sbp, MAXSTRING) } else call addstr(token, sbuf, sbp, MAXSTRING) call addchr(EOS, sbuf, sbp, MAXSTRING) t = lex(token) # peek at next 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 ADDSTR.RAT 10 12-MAY-81 12:24:10 # 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 ADDCHR.RAT 11 12-MAY-81 12:24:11 # 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 ELENTH.RAT 15 12-MAY-81 12:24:11 # calculate length of buf, taking escaped characters into account integer function elenth(buf) character buf(ARB), c character esc integer i, n n = 0 for (i=1; buf(i) != EOS; i=i+1) { c = esc(buf, i) n = n + 1 } elenth = n return end # ARCHIVE CASCOD.RAT 65 14-MAY-81 21:24:51 # 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 include cgoto if (swtop <= 0) { call synerr("illegal case or default.") return } call outgo(lab+10) # terminate previous case xfer = YES 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 == COLON) break else if (t != COMMA) call synerr("illegal case syntax.") } } 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.") xfer = NO call outden(2) call outcon(l) call inden(2) return end # ARCHIVE CASLAB.RAT 36 14-MAY-81 21:24:53 # caslab - get one case label character function caslab(n, t) integer n, i, s character t, tok(MAXTOK), gettok integer ctoi, alldig, length t = gettok(tok, MAXTOK) while (t == NEWLINE) t = gettok(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 ((t == DQUOTE | t == SQUOTE) & length(tok) == 3) { # char const n = tok(2) } else { call synerr("invalid case label.") n = 0 } t = gettok(tok, MAXTOK) while (t == NEWLINE) t = gettok(tok, MAXTOK) caslab = t return end # ARCHIVE SWCODE.RAT 34 13-MAY-81 00:54:24 # swcode - generate code for beginning of switch statement subroutine swcode(lab) integer lab, labgen character tok(MAXTOK), gettok include cswtch include cgoto 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 outch(EQUALS) call balpar call outdon call outgo(lab) # goto L xfer = YES 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 96 13-MAY-81 12:04:02 # swend - finish off switch statement; generate dispatch code subroutine swend(lab) integer lab, lb, ub, n, i, j include cswtch include cgoto 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." lb = swstak(swtop+3) ub = swstak(swlast-2) n = swstak(swtop+1) call outgo(lab+10) # terminate last case call outden(2) if (swstak(swtop+2) == 0) swstak(swtop+2) = lab + 10 # default default label xfer = NO call outcon(lab) # L continue if (n >= CUTOFF & ub - lb + 1 < DENSITY*n) { # output branch table if (lb != 1) { # L Innn=Innn-lb+1 call outtab call swvar(lab) call outch(EQUALS) 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 outgo(swstak(swtop+2)) 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 outgo(swstak(i+2)) } if (lab + 10 != swstak(swtop+2)) call outgo(swstak(swtop+2)) } call outcon(lab+10) # L+10 continue swlast = swtop # pop switch stack swtop = swstak(swtop) return end # ARCHIVE SWVAR.RAT 8 12-MAY-81 22:39:54 # swvar - output switch variable Innn, where nnn = lab subroutine swvar(lab) integer lab call outch(BIGI) call outnum(lab) return end # ARCHIVE MACMAIN.RAT 61 10-MAY-81 15:03:58 _ifdef(MACRO) _undef(MACRO) # compiling for RATFIV or somebody _elsedef _macro(MACRO) _enddef _ifdef(MACRO) ## macro - expand macros with arguments /*/sor/macror/macros # include symbols file include macsym # program macro include cline integer getarg, i, j, open character deftok character file(MAXLINE), token(MAXTOK) character stdinn(6) # STDIN string data stdinn /BIGS, BIGT, BIGD, BIGI, BIGN, EOS/ call initr4 call inimac for (i=1; ;i=i+1) { fnamp(1) = 1 level = 1 linect(1) = 1 if (getarg(i, file, MAXLINE) == EOF) { if (i != 1) break infile(level) = STDIN call scopy(stdinn, 1, fnames, 1) } else if (file(1) == QMARK & file(2) == EOS) call remark('usage: macro [file ...].') else if (file(1) == MINUS & file(2) == EOS) { infile(level) = STDIN call scopy(stdinn, 1, fnames, 1) } else { infile(level) = open(file, READ) call scopy(file, 1, fnames, 1) if (infile(level) == ERR) call cant (file) } while (deftok(token, MAXTOK) != EOF) if (token(1) == ACCENT) for (j = 2; ; j = j+1) { if (token(j) == ACCENT) if (token(j+1) == ACCENT) j = j+1 else break call putch(token(j), STDOUT) } else call putlin(token, STDOUT) } call endr4 end _enddef # ARCHIVE DODEF.RAT 22 10-MAY-81 15:03:59 ## dodef - install definition in table /*/sor/macror/dodef subroutine dodef(iargs, nargs) integer a1, iargs, nargs, argtyp character c, ngetch, type include cmacro if (nargs >= 1) { a1 = arg(1) if (type(evalst(a1)) != LETTER & evalst(a1) != UNDERLINE & evalst(a1) != EOS) { call errlin(evalst(a1)) call synerr("non-alphanumeric name.") } else if (nargs > 1) call instal(evalst(a1), evalst(arg(2)), argtyp(evalst(arg(2)))) else call instal(evalst(a1), EOS, 0) # subarrays } if (ngetch(c) != NEWLINE) call putbak(c) return end # ARCHIVE DOIF.RAT 14 10-MAY-81 15:04:00 ## doif - select one of two (macro) arguments /*/sor/macror/doif subroutine doif(iargs, nargs) integer equal integer iargs, nargs include cmacro if (nargs < 3) return if (equal(evalst(arg(1)), evalst(arg(2))) == YES) # subarrays call pbstr(evalst(arg(3))) else if (nargs >= 4) call pbstr(evalst(arg(4))) return end # ARCHIVE DOINCR.RAT 12 10-MAY-81 15:04:00 ## doincr - increment macro argument by 1 /*/sor/macror/doincr subroutine doincr(iargs, nargs) integer ctoi integer iargs, nargs, k include cmacro if (nargs != 0) { k = arg(1) call pbnum(ctoi(evalst, k)+1) } return end # ARCHIVE DOSUB.RAT 29 10-MAY-81 15:04:01 ## dosub - select macro substring /*/sor/macror/dosub subroutine dosub(iargs, nargs) integer ctoi, length integer ap1, fc, iargs, nargs, k, nc, bs include cmacro if (nargs == 0) return if (nargs == 1) bs = 1 else { k = arg(2) bs = ctoi(evalst, k) } if (nargs <= 2) nc = MAXTOK else { k = arg(3) nc = ctoi(evalst, k) # number of characters } ap1 = arg(1) # target string fc = ap1 + bs - 1 # first char of substring if (fc >= ap1 & fc < ap1 + length(evalst(ap1))) { # subarrays k = fc + min(nc, length(evalst(fc))) - 1 for ( ; k >= fc; k = k - 1) call putbak(evalst(k)) } return end # ARCHIVE EVAL.RAT 73 10-MAY-81 15:04:01 ## eval - expand args: evaluate builtin or push back defn subroutine eval(idefn, iargs, nargs) integer index, length integer argno, idefn, iargs, nargs, k, t, td include cmacro # 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/ t = argstk(idefn) td = evalst(t) if (td < 0) { if (td == IFDEFTYPE) call doifd(iargs, nargs) else if (td == ELSEDEFTYPE) call doelsd else if (td == ENDDEFTYPE) call doendd else if (!defstk(defcnt)) ; else if (td == DEFINETYPE) call dodef(iargs, nargs) else if (td == INCRTYPE) call doincr(iargs, nargs) else if (td == SUBSTRTYPE) call dosub(iargs, nargs) else if (td == IFELSETYPE) call doif(iargs, nargs) else if (td == ARITHTYPE) call doarth(iargs, nargs) else if (td == LENTYPE) call dolen(iargs, nargs) else if (td == INDEXTYPE) call doind(iargs, nargs) else if (td == INCLUDETYPE) call doincl(iargs, nargs) else if (td == UNDEFTYPE) call dound(iargs, nargs) else # just pass it along call putbak(evalst(t)) } else if (!defstk(defcnt)) ; else { for (k = t+length(evalst(t))-1; k > t; k = k - 1) if (evalst(k-1) != ARGFLAG) call putbak(evalst(k)) else { argno = index(digits, evalst(k)) - 1 if (argno >= 0 & argno <= nargs) { call pbstr(evalst(arg(argno))) k = k - 1 # skip over $ } else if (argno == -1) # wasn't a digit call putbak(evalst(k)) else k = k - 1 # skip over $ } if (k == t) # do last character call putbak(evalst(k)) } return end # ARCHIVE GTOKENM.RAT 41 10-MAY-81 15:04:03 _ifdef(MACRO) ## gtoken - get alphanumeric string or single non-alph for macro character function gtoken(token, toksiz) character ngetch, type integer i, toksiz character token (ARB) for (i = 1; i < toksiz; i = i+1) { gtoken = type( ngetch(token(i))) if (gtoken != LETTER & gtoken != DIGIT & gtoken != UNDERLINE) break } if (token(1) == ACCENT) { # leave stuff in here alone for (i = 2; i < toksiz; i = i+1) if (ngetch(token(i)) == ACCENT) { if (ngetch(token(i+1)) != ACCENT) { call putbak(token(i+1)) break } else i = i+1 } else if (token(i) == EOF) { call synerr("EOF in literal string.") call putbak(EOF) token(i) = ACCENT break } } if (i >= toksiz) call fatal ("token too long.") if (i > 1 & token(1) != ACCENT) { # some alpha was seen call putbak (token(i)) i = i - 1 gtoken = ALPHA } # else single character token token(i+1) = EOS return end _enddef # ARCHIVE PBNUM.RAT 28 10-MAY-81 15:04:03 ## pbnum - convert number to string, push back on input /*/sor/macror/pbnum subroutine pbnum(n) integer mod, iabs integer m, n, num # 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/ num = iabs(n) repeat { m = mod(num, 10) call putbak(digits(m+1)) num = num / 10 } until (num == 0) if (n < 0) call putbak(MINUS) return end # ARCHIVE PUSH.RAT 10 10-MAY-81 15:04:04 ## push - push ep onto argstk, return new pointer ap /*/sor/macror/push integer function push(ep, argstk, ap) integer ap, argstk(ARGSIZE), ep if (ap > ARGSIZE) call fatal("argument stack overflow.") argstk(ap) = ep push = ap + 1 return end # ARCHIVE PUTTOK.RAT 9 10-MAY-81 15:04:05 ## puttok-put token either on output or into eval stack /*/sor/macror/puttok subroutine puttok(str) character str(MAXTOK) integer i for (i = 1; str(i) != EOS; i = i + 1) call putchr(str(i)) return end # ARCHIVE PUTCHR.RAT 11 10-MAY-81 15:04:05 ## putchr - put single char into eval stack subroutine putchr(c) character c include cmacro if (ep > EVALSIZE) call fatal("evaluation stack overflow.") evalst(ep) = c ep = ep + 1 return end # ARCHIVE DOARTH.RAT 30 12-MAY-81 13:21:47 ## doarth - arithmetic interpreter subroutine doarth(iargs, nargs) integer iargs, nargs integer ctoi integer k,op1,op2,a character op include cmacro if (nargs > 0) { a = arg(1) op1 = ctoi(evalst, a) for (k = 2; k+1 <= nargs; k = k+2) { op = evalst(arg(k)) a = arg(k+1) op2 = ctoi(evalst, a) if (op == PLUS) op1 = op1 + op2 else if (op == MINUS) op1 = op1 - op2 else if (op == STAR) op1 = op1 * op2 else if (op == SLASH) op1 = op1 / op2 else call synerr("arith error.") } } call pbnum(op1) return end # ARCHIVE INSTAL.RAT 30 10-MAY-81 15:04:06 ## instal - add name and definition to table subroutine instal(name, defn, flag) character defn(MAXDEF), name(MAXTOK), c integer length integer dlen, nlen, flag include clook if (name(1) != EOS) { nlen = length(name) + 1 dlen = length(defn) + 1 if (dlen > MAXDEF) { call errlin(name) call synerr("definition too long.") return } if (avail + nlen + dlen + 2*CHARSPERINT > MAXTBL+1) { call errlin(name) call synerr("too many definitions.") return } call setint(table(avail+CHARSPERINT), flag) call scopy (name, 1, table, avail+2*CHARSPERINT) call scopy (defn, 1, table, avail+nlen+2*CHARSPERINT) c = table(avail+2*CHARSPERINT) call setint(table(avail), tabptr(c)) tabptr(c) = avail avail = avail + nlen + dlen + 2*CHARSPERINT } return end # ARCHIVE LOOKUP.RAT 13 10-MAY-81 15:04:07 ## lookup - locate name, extract definition from table integer function lookup(name, defn, flag) character defn(MAXDEF), name(MAXTOK), c integer flag, i, j, locdef, getint include clook lookup = locdef(name, i, j, c) if (lookup == YES) { call scopy(table, j, defn, 1) flag = getint(table(i+CHARSPERINT)) } return end # ARCHIVE UNDEF.RAT 33 10-MAY-81 15:04:07 # undef - undefine a macro and garbage collect subroutine undef(name) character name(MAXTOK), c integer i, j, k, knext, l, deflen, locdef, length, getint include clook if (locdef(name, i, j, c) == YES) { if (tabptr(c) == i) tabptr(c) = getint(table(i)) else { for (k = tabptr(c); getint(table(k)) != i; k = getint(table(k))) ; call setint(table(k), getint(table(i))) } j = j + length(table(j)) + 1 deflen = j - i do l = 1, 127 if (tabptr(l) > i) { k = tabptr(l) tabptr(l) = tabptr(l) - deflen for ( ; getint(table(k)) > i; k = knext) { knext = getint(table(k)) call setint(table(k), knext - deflen) } } for ( ; j < avail; j = j+1) { table(i) = table(j) i = i+1 } avail = i } return end # ARCHIVE LOCDEF.RAT 23 10-MAY-81 15:04:08 ## locdef - locate name, extract definition from table integer function locdef(name, i, j, c) character name(MAXTOK) integer i, j, k, c integer getint include clook if (name(1) != EOS) { c = name(1) for (i = tabptr(c); i > 0; i = getint(table(i))) { j = i + 2*CHARSPERINT for (k = 1; name(k) == table(j) & name(k) != EOS; k = k + 1) j = j + 1 if (name(k) == table(j)) { # got one j = j+1 locdef = YES return } } } locdef = NO return end # ARCHIVE NGETCH.RAT 27 10-MAY-81 15:04:09 ## ngetch - get a (possibly pushed back) character character function ngetch(c) character getch character c, c2 include cdefio include cline if (bp > 0) { c = buf(bp) bp = bp - 1 } else { 10 c = getch(c, infile(level)) if (c == UNDERLINE) { c2 = getch(c2, infile(level)) if (c2 == NEWLINE) { linect(level) = linect(level) + 1 goto 10 } call putbak(c2) } } if (c == NEWLINE) linect(level) = linect(level) + 1 ngetch = c return end # ARCHIVE PBSTR.RAT 10 10-MAY-81 15:04:09 ## 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 14 10-MAY-81 15:04:10 ## putbak - push character back onto input subroutine putbak(c) character c include cline include cdefio bp = bp + 1 if (bp > BUFSIZE) call fatal("too many characters pushed back.") buf(bp) = c if (c == NEWLINE) linect(level) = linect(level) - 1 return end # ARCHIVE SETINT.RAT 8 10-MAY-81 15:04:10 # setint - put an integer into table subroutine setint(table, val) byte table(CHARSPERINT), val(CHARSPERINT) do i = 1, CHARSPERINT table(i) = val(i) return end # ARCHIVE GETINT.RAT 11 10-MAY-81 15:04:11 # getint - get an integer from table integer function getint(table) character table(CHARSPERINT), c(CHARSPERINT) integer i, j equivalence (i, c) do j = 1, CHARSPERINT c(j) = table(j) getint = i return end # ARCHIVE DOIND.RAT 12 10-MAY-81 15:04:11 # doind - get index of arg2 in arg1 subroutine doind(iargs, nargs) integer iargs, nargs integer index include cmacro if (nargs == 1) call pbnum(0) else if (nargs >= 2) call pbnum(index(evalst(arg(1)), evalst(arg(2)))) return end # ARCHIVE DOLEN.RAT 12 10-MAY-81 15:04:12 # dolen - get length of argument subroutine dolen(iargs, nargs) integer iargs, nargs integer length include cmacro if (nargs < 1) call pbnum(0) else call pbnum(length(evalst(arg(1)))) return end # ARCHIVE DOIFD.RAT 18 10-MAY-81 15:04:12 # doifd - do ifdef builtin macro subroutine doifd(iargs, nargs) integer iargs, nargs, locdef, junk1, junk2 character c, ngetch include cmacro defcnt = defcnt + 1 if (defcnt > DEFSTACKSIZE) call fatal("_ifdefs nested too deeply.") defstk(defcnt) = defstk(defcnt-1) if (defstk(defcnt)) if (nargs > 0) if (locdef(evalst(arg(1)), junk1, junk2, c) != YES) defstk(defcnt) = .false. if (ngetch(c) != NEWLINE) call putbak(c) return end # ARCHIVE NOEVAL.RAT 9 10-MAY-81 15:04:13 # noeval - check if macro arguments should be evaluated now integer function noeval(cp, ap, callst, argstk) integer cp, ap, callst(ARB), argstk(ARB), isset noeval = NO if (cp != 0) noeval = isset(argstk(callst(cp)), ap - callst(cp) - 3) return end # ARCHIVE DOELSD.RAT 13 10-MAY-81 15:04:13 # doelsd - handle _elsedef subroutine doelsd character c, ngetch include cmacro if (defcnt <= 1) call synerr("bad _elsedef.") else defstk(defcnt) = defstk(defcnt-1) & !defstk(defcnt) if (ngetch(c) != NEWLINE) call putbak(c) return end # ARCHIVE DOENDD.RAT 13 10-MAY-81 15:04:14 # doendd - handle _enddef subroutine doendd character c, ngetch include cmacro if (defcnt <= 1) call synerr("bad _enddef.") else defcnt = defcnt - 1 if (ngetch(c) != NEWLINE) call putbak(c) return end # ARCHIVE DOINCL.RAT 33 13-MAY-81 20:20:23 # doincl - handle file inclusion for macro subroutine doincl(iargs, nargs) integer iargs, nargs, i, j, a character ngetch, c, file(FILENAMESIZE) include cmacro include cline string incerr "include file name too long." if (ngetch(c) != NEWLINE) call putbak(c) i = 0 for (j = 1; j <= nargs; j = j+1) { for (a = arg(j); evalst(a) != EOS; a = a+1) { i = i+1 if (i >= FILENAMESIZE) { call synerr(incerr) return } file(i) = evalst(a) } if (j < nargs) { i = i+1 if (i >= FILENAMESIZE) { call synerr(incerr) return } file(i) = COMMA } } file(i+1) = EOS call includ(file, c) return end # ARCHIVE DEFTOK.RAT 124 10-MAY-81 15:04:15 # deftok - get token, process macro invocations character function deftok(token, toksiz) character token(ARB), defn(MAXDEF) integer j, nlb, toksiz, argty character balp(3) character gtoken integer lookup, push, length, isset, noeval include cmacro include clook include cdefio include cline data balp /LPAREN, RPAREN, EOS/ for ( ; level > 0; level = level-1) { for (deftok = gtoken(token, toksiz); deftok != EOF; deftok = gtoken(token, toksiz)) { if (! defstk(defcnt)) { if (lookup(token, defn, argty) == YES) if (defn(1) == IFDEFTYPE) call doifd(0, 0, 0) else if (defn(1) == ELSEDEFTYPE) call doelsd else if (defn(1) == ENDDEFTYPE) call doendd } else if (deftok == ALPHA) { if (lookup(token, defn, argty) == NO) if (cp == 0) return else call puttok(token) else if (noeval(cp, ap, callst, argstk) == YES) call puttok(token) else { # defined; put it in eval stack cp = cp + 1 if (cp > CALLSIZE) call fatal("call stack overflow.") callst(cp) = ap ap = push(argty, argstk, ap) ap = push(ep, argstk, ap) call puttok(defn) # stack definition call putchr(EOS) ap = push(ep, argstk, ap) call puttok(token) # stack name call putchr(EOS) ap = push(ep, argstk, ap) if (isset(argty, HASARGS) == YES) { j = 0 repeat { deftok = gtoken(token, toksiz) # peek at next j = j + 1 } until (deftok != BLANK) call pbstr(token) if (deftok != LPAREN) { # add ( ) if not present for ( ; j > 1; j = j-1) call putbak(BLANK) call pbstr(balp) } } else call pbstr(balp) plev(cp) = 0 } } else if (cp == 0) # not in a macro at all return else if (deftok == LBRACK) { if (noeval(cp, ap, callst, argstk) == YES) call puttok(token) else { # strip one level of [] nlb = 1 repeat { deftok = gtoken(token, toksiz) if (deftok == LBRACK) nlb = nlb + 1 else if (deftok == RBRACK) { nlb = nlb - 1 if (nlb == 0) break } else if (deftok == EOF) { call synerr("EOF in bracketed string.") call putbak(EOF) break } call puttok(token) } } } else if (deftok == LPAREN) { if (plev(cp) > 0) call puttok(token) plev(cp) = plev(cp) + 1 } else if (deftok == RPAREN) { plev(cp) = plev(cp) - 1 if (plev(cp) > 0) call puttok(token) else { # end of argument list call putchr(EOS) call eval(callst(cp) + 1, callst(cp) + 2, ap - callst(cp) - 3) ap = callst(cp) # pop eval stack ep = argstk(ap+1) cp = cp - 1 } } else if (deftok == COMMA & plev(cp) == 1) { # new argument call putchr(EOS) ap = push(ep, argstk, ap) } else call puttok(token) # just stack it } if (infile(level) != STDIN) # here on EOF; pop back to last file call close(infile(level)) } if (cp != 0) call synerr("unexpected EOF.") deftok = EOF # in case called more than once token(1) = EOF token(2) = EOS return end # ARCHIVE INIMAC.RAT 73 10-MAY-81 15:04:17 # inimac - initialize macro preproccessor subroutine inimac include cmacro include clook include cdefio include cerrbf integer set character macnam(7), mactyp(2) character undnam(7), undtyp(2) character incnam(6), inctyp(2) character subnam(8), subtyp(2) character ifenam(8), ifetyp(2) character arinam(7), arityp(2) character lennam(5), lentyp(2) character indnam(7), indtyp(2) character ifdnam(7), ifdtyp(2) character elsnam(9), elstyp(2) character endnam(8), endtyp(2) character iclnam(9), icltyp(2) data macnam /UNDERLINE, LETM, LETA, LETC, LETR, LETO, EOS/, mactyp /DEFINETYPE, EOS/ data undnam /UNDERLINE, LETU, LETN, LETD, LETE, LETF, EOS/, undtyp /UNDEFTYPE, EOS/ data incnam /UNDERLINE, LETI, LETN, LETC, LETR, EOS/, inctyp /INCRTYPE, EOS/ data subnam /UNDERLINE, LETS, LETU, LETB, LETS, LETT, LETR, EOS/, subtyp /SUBSTRTYPE, EOS/ data ifenam /UNDERLINE, LETI, LETF, LETE, LETL, LETS, LETE, EOS/, ifetyp /IFELSETYPE, EOS/ data arinam /UNDERLINE, LETA, LETR, LETI, LETT, LETH, EOS/, arityp /ARITHTYPE, EOS/ data lennam /UNDERLINE, LETL, LETE, LETN, EOS/, lentyp /LENTYPE, EOS/ data indnam /UNDERLINE, LETI, LETN, LETD, LETE, LETX, EOS/, indtyp /INDEXTYPE, EOS/ data ifdnam /UNDERLINE, LETI, LETF, LETD, LETE, LETF, EOS/, ifdtyp /IFDEFTYPE, EOS/ data elsnam /UNDERLINE, LETE, LETL, LETS, LETE, LETD, LETE, LETF, EOS/, elstyp /ELSEDEFTYPE, EOS/ data endnam /UNDERLINE, LETE, LETN, LETD, LETD, LETE, LETF, EOS/, endtyp /ENDDEFTYPE, EOS/ data iclnam /UNDERLINE, LETI, LETN, LETC, LETL, LETU, LETD, LETE, EOS/, icltyp /INCLUDETYPE, EOS/ avail = 1 for (i = 1; i <= 127; i = i+1) tabptr(i) = 0 call insupl(macnam, mactyp, set(set(set(0, HASARGS), 1), 2)) call insupl(undnam, undtyp, set(set(0, HASARGS), 1)) call insupl(incnam, inctyp, set(0, HASARGS)) call insupl(subnam, subtyp, set(0, HASARGS)) call insupl(ifenam, ifetyp, set(set(set(0, HASARGS), 3), 4)) call insupl(arinam, arityp, set(0, HASARGS)) call insupl(lennam, lentyp, set(0, HASARGS)) call insupl(indnam, indtyp, set(0, HASARGS)) call insupl(ifdnam, ifdtyp, set(set(0, HASARGS), 1)) call insupl(elsnam, elstyp, 0) call insupl(endnam, endtyp, 0) call insupl(iclnam, icltyp, set(set(0, HASARGS), 1)) # initialize pointers, etc. bp = 0 cp = 0 ap = 1 ep = 1 defcnt = 1 defstk(1) = .true. errbuf(1) = EOS return end # ARCHIVE DOUND.RAT 12 10-MAY-81 15:04:18 # dound - undefine a macro and garbage collect subroutine dound(iargs, nargs) integer iargs, nargs character ngetch, c include cmacro if (nargs >= 1) call undef(evalst(arg(1))) if (ngetch(c) != NEWLINE) call putbak(c) return end # ARCHIVE INCLUD.RAT 30 10-MAY-81 15:42:26 # includ - handle file inclusion integer function includ(file, c) character file(ARB), c integer length, open, tlev include cline includ = NO tlev = level if (c == NEWLINE) linect(tlev) = linect(tlev) - 1 # so error line numbers correct if (level >= NFILES) call synerr("includes nested too deeply.") else { infile(level+1) = open(file, READ) if (infile(level+1) == ERR) { call errlin(file) call synerr("can't open include.") } else { level = level+1 linect(level) = 1 fnamp(level) = fnamp(level-1) + length(fnames(fnamp(level-1))) + 1 call scopy(file, 1, fnames, fnamp(level)) includ = YES } } if (c == NEWLINE) linect(tlev) = linect(tlev) + 1 return end # ARCHIVE ERRLIN.RAT 9 10-MAY-81 15:04:19 # errlin - output a string to STDOUT and to ERROUT subroutine errlin(mess) character mess(ARB) integer length include cerrbf call scopy(mess, 1, errbuf, length(errbuf)+1) return end # ARCHIVE INSUPL.RAT 11 10-MAY-81 15:04:20 # insupl - install upper and lower case vesions of name subroutine insupl(name, defn, flag) character name(MAXTOK), defn(MAXDEF), fname(MAXTOK) integer flag call instal(name, defn, flag) call scopy(name, 1, fname, 1) call upper(fname) call instal(fname, defn, flag) return end # ARCHIVE SYNERR.RAT 13 10-MAY-81 15:04:20 # synerr - report ratfiv syntax error subroutine synerr(msg) character msg(ARB) include cerrbf call xitsta(3) call putlin(errbuf, ERROUT) call syn2(msg, ERROUT) call putlin(errbuf, STDOUT) call syn2(msg, STDOUT) errbuf(1) = EOS return end # ARCHIVE SYN2.RAT 49 10-MAY-81 15:04:21 ## syn2 - report Ratfiv 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) call putlin(in, f) call putlin(fnames(fnamp(i)), f) call putch(COLON, f) call putch(BLANK, f) call putlin(msg, f) call putch(NEWLINE, f) return end # ARCHIVE ARGTYP.RAT 36 10-MAY-81 15:04:22 # argtyp - return flags for argument types in defn integer function argtyp(defn) character defn(ARB), digits(11) integer i, n, found(10), set data digits /DIG0, DIG1, DIG2, DIG3, DIG4, DIG5, DIG6, DIG7, DIG8, DIG9, EOS/ do i = 1, 10 found(i) = NOTARG argtyp = 0 for (i = 1; defn(i) != EOS; i = i+1) if (defn(i) == EVALARG) { n = index(digits, defn(i+1)) if (n != 0) { defn(i) = ARGFLAG argtyp = set(argtyp, HASARGS) if (found(n) == NOEVALARG) call synerr("argument cannot be both eval type and noeval type.") else found(n) = EVALARG } } else if (defn(i) == NOEVALARG) { n = index(digits, defn(i+1)) if (n != 0) { defn(i) = ARGFLAG argtyp = set(argtyp, HASARGS) if (found(n) == EVALARG) call synerr("argument cannot be both eval type and noeval type.") else { found(n) = NOEVALARG argtyp = set(argtyp, n-1) } } } return end # ARCHIVE SET.RAT 11 10-MAY-81 15:04:22 # set - return flags with bit n set integer function set(flags, n) integer flags, n integer bitmsk(11), isset data bitmsk /1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024/ set = flags if (isset(flags, n) != YES) set = flags + bitmsk(n+1) return end # ARCHIVE ISSET.RAT 11 10-MAY-81 15:04:23 # isset - return YES if bit n is set in flags integer function isset(flags, n) integer flags, n integer bitmsk(11) data bitmsk /1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024/ isset = NO if (mod(flags/bitmsk(n+1), 2) == 1) isset = YES return end # ARCHIVE FATAL.RAT 8 13-MAY-81 15:12:43 # fatal - handle fatal error subroutine fatal(mess) character mess(ARB) call synerr(mess) call error(EOS) return end