#-h- common 2163 local 12/01/80 15:50:08 # Common blocks used by the Ratfor preprocessor # Place on a file called 'common' common /cdefio/ bp, buf (BUFSIZE) integer bp # next available character; init = 0 character buf # pushed-back characters common /cfname/ fcname (MAXNAME) character fcname # text of current function name common /cfor/ fordep, forstk (MAXFORSTK) integer fordep # current depth of for statements character forstk # stack of reinit strings common /cgoto/ xfer integer xfer # YES if just made transfer, NO otherwise common /clabel/ label integer label # next label returned by labgen common /cline/ level, linect (NFILES), infile (NFILES), fnamp, fnames (MAXFNAMES) integer level # level of file inclusion; init = 1 integer linect # line count on input file (level); init = 1 integer infile # file number (level); init infile (1) = STDIN integer fnamp # next free slot in fnames; init = 2 character fnames # stack of include names; init fnames (1) = EOS common /cmacro/ cp, ep, evalst (EVALSIZE), deftbl integer cp # current call stack pointer integer ep # next free position in evalst character evalst # evaluation stack pointer deftbl # symbol table holding macro names common /coutln/ outp, outbuf (74) integer outp # last position filled in outbuf; init = 0 character outbuf # output lines collected here common /csbuf/ sbp, sbuf (SBUFSIZE) integer sbp # next available character position; init = 1 character sbuf # saved for data statements common /cswtch/ swtop, swlast, swstak (MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words common /clname/ fkwtbl, namtbl, gentbl pointer fkwtbl # a list of long Fortran keywords pointer namtbl # map of long-form names to short-form names pointer gentbl # list of generated names DS_DECL(mem, MEMSIZE) #-t- common 2163 local 12/01/80 15:50:08 #-h- ratfor.r 69694 local 12/01/80 15:56:25 #-h- ratfor 4496 local 12/01/80 15:53:43 # Ratfor preprocessor # include ratdef #--------------------------------------------------------------- # The definition STDEFNS defines the file which contains the # standard definitions to be used when preprocessing a file. # It is opened and read automatically by the ratfor preprocessor. # Set STDEFNS to the name of the file in which the standard # definitions reside. If you don't want the preprocessor to # automatically open this file, set STDENFS to "". # #--------------------------------------------------------------- # If you want the preprocessor to output upper case only, # set the following definition: # # define (UPPERC,) # #--------------------------------------------------------------- # Some of the buffer sizes and other symbols might have to be # changed. Especially check the following: # # MAXDEF (number of characters in a definition) # SBUFSIZE (nbr string declarations allowed per module) # MAXSTRTBL (size of table to buffer string declarations) # MAXSWITCH (max stack for switch statement) # #----------------------------------------------------------------- define (STDEFNS,"ratdef") # name of file containing standard defns define (UPPERC,) # define if Fortran compiler wants upper case define (RADIX,PERCENT) # % indicates alternate radix define (TOGGLE,PERCENT) # toggle for literal lines define (ARGFLAG,DOLLAR) define (CUTOFF,3) # min nbr of cases to generate branch table # (for switch statement) define (DENSITY,2) # reciprocal of density necessary for # branch table define (FILLCHAR,DIG0) # used in long-name uniquing define (MAXIDLENGTH,6) # for Fortran 66 and 77 # Lexical items: define (LEXBREAK,-8) define (LEXCASE,-25) define (LEXDEFAULT,-26) define (LEXDIGITS,-9) define (LEXDO,-10) define (LEXELSE,-11) define (LEXEND,-21) define (LEXFOR,-16) define (LEXIF,-19) define (LEXLITERAL,-27) define (LEXNEXT,-13) define (LEXOTHER,-14) define (LEXREPEAT,-17) define (LEXRETURN,-20) define (LEXSTOP,-22) define (LEXSTRING,-23) define (LEXSWITCH,-24) define (LEXUNTIL,-18) define (LEXWHILE,-15) define (LSTRIPC,-10) define (RSTRIPC,-11) # Built-in macro functions: define (DEFTYPE,-4) define (MACTYPE,-10) define (IFTYPE,-11) define (INCTYPE,-12) define (SUBTYPE,-13) define (ARITHTYPE,-14) define (IFDEFTYPE,-15) define (IFNOTDEFTYPE,-16) # Size-limiting definitions: define (MEMSIZE,10000) # space allotted to symbol tables and macro text define (BUFSIZE,400) # pushback buffer for ngetch and putbak define (PBPOINT,300) # point in buffer where pushback begins define (SBUFSIZE,500) # buffer for string statements define (MAXDEF,250) # max chars in a defn define (MAXFORSTK,200) # max space for for reinit clauses define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) define (MAXSTACK,100) # max stack depth for parser define (MAXSWITCH,1000) # max stack for switch statement define (MAXTOK,100) # max chars in a token define (NFILES,5) # max number of include file nesting define (MAXNBRSTR,20) #max nbr string declarations per module define (CALLSIZE,50) define (ARGSIZE,100) define (EVALSIZE,500) # Where to find the common blocks: define(COMMON_BLOCKS,"common") DRIVER(ratfor) include COMMON_BLOCKS integer i, n integer getarg, open character arg (FILENAMESIZE) string defns STDEFNS # name of standard definitions file call initkw # initialize variables # Read file containing standard definitions # If this isn't desired, define (STDEFNS,"") if (defns (1) != EOS) { infile (1) = open (defns, READ) if (infile (1) == ERR) call remark ("can't open standard definitions file.") else { call parse call close (infile (1)) } } n = 1 for (i = 1; getarg (i, arg, FILENAMESIZE) != EOF; i = i + 1) { n = n + 1 call query ("usage: ratfor [files] >outfile.") if (arg (1) == MINUS & arg (2) == EOS) infile (1) = STDIN else { infile (1) = open (arg, READ) if (infile (1) == ERR) call cant (arg) } call parse if (infile (1) != STDIN) call close (infile (1)) } if (n == 1) { # no files given on command line, use STDIN infile (1) = STDIN call parse } call lndict DRETURN end #-t- ratfor 4496 local 12/01/80 15:53:43 #-h- addchr 254 local 12/01/80 15:53:44 # 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 baderr ("buffer overflow.") buf (bp) = c bp = bp + 1 return end #-t- addchr 254 local 12/01/80 15:53:44 #-h- allblk 486 local 12/01/80 15:53:44 # allblk - determine if line consists of all blanks # this routine is called by outdon, and is here to fix # a bug which sometimes occurs if two or more includes precede the # first line of executable code. Could not trace down the cause integer function allblk (buf) character buf (ARB) integer i allblk = YES for (i = 1; buf (i) != NEWLINE & buf (i) != EOS; i = i + 1) if (buf (i) != BLANK) { allblk = NO break } return end #-t- allblk 486 local 12/01/80 15:53:44 #-h- alldig 306 local 12/01/80 15:53:45 # alldig - return YES if str is all digits integer function alldig (str) character str (ARB) character type integer i alldig = NO if (str (1) == EOS) return for (i = 1; str (i) != EOS; i = i + 1) if (!IS_DIGIT(str (i))) return alldig = YES return end #-t- alldig 306 local 12/01/80 15:53:45 #-h- baderr 144 local 12/01/80 15:53:45 # baderr --- report fatal error message, then die subroutine baderr (msg) character msg (ARB) call synerr (msg) call endst end #-t- baderr 144 local 12/01/80 15:53:45 #-h- balpar 854 local 12/01/80 15:53:46 # balpar - copy balanced paren string subroutine balpar character t, token (MAXTOK) character gettok, gnbtok integer nlpar if (gnbtok (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 if (t == ALPHA) call squash (token) # else nothing special call outstr (token) } until (nlpar <= 0) if (nlpar != 0) call synerr ("missing parenthesis in condition.") return end #-t- balpar 854 local 12/01/80 15:53:46 #-h- brknxt 1077 local 12/01/80 15:53:46 # 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 integer alldig, ctoi character t, ptoken (MAXTOK) character gnbtok include COMMON_BLOCKS n = 0 t = gnbtok (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 } else if (token == LEXBREAK) call outgo (labval (i) + 1) else call outgo (labval (i)) xfer = YES return } if (token == LEXBREAK) call synerr ("illegal break.") else call synerr ("illegal next.") return end #-t- brknxt 1077 local 12/01/80 15:53:46 #-h- cascod 1876 local 12/01/80 15:53:46 # cascod - generate code for case or default label subroutine cascod (lab, token) integer lab, token include COMMON_BLOCKS integer t, l, lb, ub, i, j, junk integer caslab, labgen, gnbtok character tok (MAXTOK) if (swtop <= 0) { call synerr ("illegal case or default.") return } call outgo (lab + 1) # 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 baderr ("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 = gnbtok (tok, MAXTOK) if (swstak (swtop + 2) != 0) call error ("multiple defaults in switch statement.") else swstak (swtop + 2) = l } if (t == EOF) call synerr ("unexpected EOF.") else if (t != COLON) call error ("missing colon in case or default label.") xfer = NO call outcon (l) return end #-t- cascod 1876 local 12/01/80 15:53:46 #-h- caslab 624 local 12/01/80 15:53:47 # caslab - get one case label integer function caslab (n, t) integer n, t character tok (MAXTOK) integer i, s integer gnbtok, ctoi t = gnbtok (tok, MAXTOK) while (t == NEWLINE) t = gnbtok (tok, MAXTOK) if (t == EOF) return (t) if (t == MINUS) s = -1 else s = +1 if (t == MINUS | t == PLUS) t = gnbtok (tok, MAXTOK) if (t != DIGIT) { call synerr ("invalid case label.") n = 0 } else { i = 1 n = s * ctoi (tok, i) } t = gnbtok (tok, MAXTOK) while (t == NEWLINE) t = gnbtok (tok, MAXTOK) return end #-t- caslab 624 local 12/01/80 15:53:47 #-h- deftok 4116 local 12/01/80 15:53:47 # deftok - get token; process macro calls and invocations # this routine has been disabled to allow defines with parameters to be added # character function deftok (token, toksiz) # character gtok # integer toksiz # character defn (MAXDEF), t, token (MAXTOK) # integer ludef # include COMMON_BLOCKS # # for (t = gtok (token, toksiz); t!=EOF; t = gtok (token, toksiz)) { # if (t != ALPHA) # non-alpha # break # if (ludef (token, defn, deftbl) == NO) # undefined # break # if (defn (1) == DEFTYPE) { # get definition # call getdef (token, toksiz, defn, MAXDEF) # call entdef (token, defn, deftbl) # } # else # call pbstr (defn) # push replacement onto input # } # deftok = t # if (deftok == ALPHA) # convert to single case # call fold (token) # return # end # deftok - get token; process macro calls and invocations character function deftok (token, toksiz) character token (MAXTOK) integer toksiz include COMMON_BLOCKS character t, c, defn (MAXDEF), mdefn (MAXDEF) character gtok integer ap, argstk (ARGSIZE), callst (CALLSIZE), nlb, plev (CALLSIZE), ifl integer ludef, push, ifparm string balp "()" cp = 0 ap = 1 ep = 1 for (t = gtok (token, toksiz); t != EOF; t = gtok (token, toksiz)) { if (t == ALPHA) if (ludef (token, defn, deftbl) == NO) if (cp == 0) break else call puttok (token) else if (defn (1) == DEFTYPE) { # process defines directly call getdef (token, toksiz, defn, MAXDEF) call entdef (token, defn, deftbl) } else if (defn (1) == IFDEFTYPE | defn (1) == IFNOTDEFTYPE) { c = defn (1) call getdef (token, toksiz, defn, MAXDEF) ifl = ludef (token, mdefn, deftbl) if ((ifl == YES & c == IFDEFTYPE) | (ifl == NO & c == IFNOTDEFTYPE)) call pbstr (defn) } else { cp = cp + 1 if (cp > CALLSIZE) call baderr ("call stack overflow.") callst (cp) = ap ap = push (ep, argstk, ap) call puttok (defn) call putchr (EOS) ap = push (ep, argstk, ap) call puttok (token) call putchr (EOS) ap = push (ep, argstk, ap) t = gtok (token, toksiz) if (t == BLANK) { # allow blanks before arguments t = gtok (token, toksiz) call pbstr (token) if (t != LPAREN) call putbak (BLANK) } else call pbstr (token) if (t != LPAREN) call pbstr (balp) else if (ifparm (defn) == NO) call pbstr (balp) plev (cp) = 0 } else if (t == LSTRIPC) { nlb = 1 repeat { t = gtok (token, toksiz) if (t == LSTRIPC) nlb = nlb + 1 else if (t == RSTRIPC) { nlb = nlb - 1 if (nlb == 0) break } else if (t == EOF) call baderr ("EOF in string.") call puttok (token) } } else if (cp == 0) break else if (t == LPAREN) { if (plev (cp) > 0) call puttok (token) plev (cp) = plev (cp) + 1 } else if (t == RPAREN) { plev (cp) = plev (cp) - 1 if (plev (cp) > 0) call puttok (token) else { call putchr (EOS) call evalr (argstk, callst (cp), ap - 1) ap = callst (cp) ep = argstk (ap) cp = cp - 1 } } else if (t == COMMA & plev (cp) == 1) { call putchr (EOS) ap = push (ep, argstk, ap) } else call puttok (token) } deftok = t if (t == ALPHA) call fold (token) return end #-t- deftok 4116 local 12/01/80 15:53:47 #-h- doarth 636 local 12/01/80 15:53:48 # doarth - do arithmetic operation subroutine doarth (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer k, l integer ctoi character op k = argstk (i + 2) l = argstk (i + 4) op = evalst (argstk (i + 3)) if (op == PLUS) call pbnum (ctoi (evalst, k) + ctoi (evalst, l)) else if (op == MINUS) call pbnum (ctoi (evalst, k) - ctoi (evalst, l)) else if (op == STAR ) call pbnum (ctoi (evalst, k) * ctoi (evalst, l)) else if (op == SLASH ) call pbnum (ctoi (evalst, k) / ctoi (evalst, l)) else call remark ('arith error') return end #-t- doarth 636 local 12/01/80 15:53:48 #-h- docode 522 local 12/01/80 15:53:49 # docode - generate code for beginning of do subroutine docode (lab) integer lab integer labgen include COMMON_BLOCKS character gnbtok character lexstr (MAXTOK) string sdo "do" xfer = NO call outtab call outstr (sdo) call outch (BLANK) lab = labgen (2) if (gnbtok (lexstr, MAXTOK) == DIGIT) # check for fortran DO call outstr (lexstr) else { call pbstr (lexstr) call outnum (lab) } call outch (BLANK) call eatup call outdon return end #-t- docode 522 local 12/01/80 15:53:49 #-h- doif 458 local 12/01/80 15:53:49 # doif - select one of two (macro) arguments subroutine doif (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer a2, a3, a4, a5 integer equal if (j - i < 5) return a2 = argstk (i + 2) a3 = argstk (i + 3) a4 = argstk (i + 4) a5 = argstk (i + 5) if (equal (evalst (a2), evalst (a3)) == YES) # subarrays call pbstr (evalst (a4)) else call pbstr (evalst (a5)) return end #-t- doif 458 local 12/01/80 15:53:49 #-h- doincr 246 local 12/01/80 15:53:49 # doincr - increment macro argument by 1 subroutine doincr (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer k integer ctoi k = argstk (i + 2) call pbnum (ctoi (evalst, k) + 1) return end #-t- doincr 246 local 12/01/80 15:53:49 #-h- domac 326 local 12/01/80 15:53:49 # domac - install macro definition in table subroutine domac (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer a2, a3 if (j - i > 2) { a2 = argstk (i + 2) a3 = argstk (i + 3) call entdef (evalst (a2), evalst (a3), deftbl) # subarrays } return end #-t- domac 326 local 12/01/80 15:53:49 #-h- dostat 156 local 12/01/80 15:53:50 # dostat - generate code for end of do statement subroutine dostat (lab) integer lab call outcon (lab) call outcon (lab + 1) return end #-t- dostat 156 local 12/01/80 15:53:50 #-h- dosub 709 local 12/01/80 15:53:50 # dosub - select macro substring subroutine dosub (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer ap, fc, k, nc integer ctoi, length if (j - i < 3) return if (j - i < 4) nc = MAXTOK else { k = argstk (i + 4) nc = ctoi (evalst, k) # number of characters } k = argstk (i + 3) # origin ap = argstk (i + 2) # target string fc = ap + ctoi (evalst, k) - 1 # first char of substring if (fc >= ap & fc < ap + length (evalst (ap))) { # subarrays k = fc + min (nc, length (evalst (fc))) - 1 for ( ; k >= fc; k = k - 1) call putbak (evalst (k)) } return end #-t- dosub 709 local 12/01/80 15:53:50 #-h- eatup 1137 local 12/01/80 15:53:50 # eatup - process rest of statement; interpret continuations subroutine eatup character ptoken (MAXTOK), t, token (MAXTOK) character gettok integer nlpar 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 == TILDE | t == NOT | t == CARET | t == EQUALS | t == UNDERLINE) { while (gettok (ptoken, MAXTOK) == NEWLINE) ; call pbstr (ptoken) if (t == UNDERLINE) token (1) = EOS } if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == ALPHA) call squash (token) call outstr (token) } until (nlpar < 0) if (nlpar != 0) call synerr ("unbalanced parentheses.") return end #-t- eatup 1137 local 12/01/80 15:53:50 #-h- elseif 155 local 12/01/80 15:53:51 # elseif - generate code for end of if before else subroutine elseif (lab) integer lab call outgo (lab+1) call outcon (lab) return end #-t- elseif 155 local 12/01/80 15:53:51 #-h- entdef 387 local 12/01/80 15:53:51 # entdef - enter a new symbol definition, discarding any old one subroutine entdef (name, defn, table) character name (MAXTOK), defn (ARB) pointer table integer lookup pointer text pointer sdupl if (lookup (name, text, table) == YES) call dsfree (text) # this is how to do UNDEFINE, by the way call enter (name, sdupl (defn), table) return end #-t- entdef 387 local 12/01/80 15:53:51 #-h- entdkw 975 local 12/01/80 15:54:05 # entdkw --- install macro processor keywords subroutine entdkw character deft (2), inct (2), subt (2), ift (2), art (2), ifdft (2), ifndt (2), mact (2) string defnam "define" string macnam "mdefine" string incnam "incr" string subnam "substr" string ifnam "ifelse" string arnam "arith" string ifdfnm "ifdef" string ifndnm "ifnotdef" data deft (1), deft (2) /DEFTYPE, EOS/ data mact (1), mact (2) /MACTYPE, EOS/ data inct (1), inct (2) /INCTYPE, EOS/ data subt (1), subt (2) /SUBTYPE, EOS/ data ift (1), ift (2) /IFTYPE, EOS/ data art (1), art (2) /ARITHTYPE, EOS/ data ifdft (1), ifdft (2) /IFDEFTYPE, EOS/ data ifndt (1), ifndt (2) /IFNOTDEFTYPE, EOS/ call ulstal (defnam, deft) call ulstal (macnam, mact) call ulstal (incnam, inct) call ulstal (subnam, subt) call ulstal (ifnam, ift) call ulstal (arnam, art) call ulstal (ifdfnm, ifdft) call ulstal (ifndnm, ifndt) return end #-t- entdkw 975 local 12/01/80 15:54:05 #-h- entfkw 981 local 12/01/80 15:54:06 # entfkw - place Fortran keywords in symbol table subroutine entfkw include COMMON_BLOCKS # Place in the following table any long (> 6 characters) # keyword that is used by your Fortran compiler: string sconti "continue" string scompl "complex" string slogic "logical" string simpli "implicit" string sparam "parameter" string sexter "external" string sdimen "dimension" string sinteg "integer" string sequiv "equivalence" string sfunct "function" string ssubro "subroutine" string spreci "precision" call enter (sconti, 0, fkwtbl) call enter (scompl, 0, fkwtbl) call enter (slogic, 0, fkwtbl) call enter (simpli, 0, fkwtbl) call enter (sparam, 0, fkwtbl) call enter (sexter, 0, fkwtbl) call enter (sdimen, 0, fkwtbl) call enter (sinteg, 0, fkwtbl) call enter (sequiv, 0, fkwtbl) call enter (sfunct, 0, fkwtbl) call enter (ssubro, 0, fkwtbl) call enter (spreci, 0, fkwtbl) return end #-t- entfkw 981 local 12/01/80 15:54:06 #-h- entrkw 1003 local 12/01/80 15:54:06 # entrkw --- install Ratfor keywords in symbol table subroutine entrkw include COMMON_BLOCKS string sif "if" string selse "else" string swhile "while" string sdo "do" string sbreak "break" string snext "next" string sfor "for" string srept "repeat" string suntil "until" string sret "return" string sstr "string" string sswtch "switch" string scase "case" string sdeflt "default" call enter (sif, LEXIF, rkwtbl) call enter (selse, LEXELSE, rkwtbl) call enter (swhile, LEXWHILE, rkwtbl) call enter (sdo, LEXDO, rkwtbl) call enter (sbreak, LEXBREAK, rkwtbl) call enter (snext, LEXNEXT, rkwtbl) call enter (sfor, LEXFOR, rkwtbl) call enter (srept, LEXREPEAT, rkwtbl) call enter (suntil, LEXUNTIL, rkwtbl) call enter (sret, LEXRETURN, rkwtbl) call enter (sstr, LEXSTRING, rkwtbl) call enter (sswtch, LEXSWITCH, rkwtbl) call enter (scase, LEXCASE, rkwtbl) call enter (sdeflt, LEXDEFAULT, rkwtbl) return end #-t- entrkw 1003 local 12/01/80 15:54:06 #-h- evalr 1126 local 12/01/80 15:54:06 # evalr - expand args i through j: evaluate builtin or push back defn subroutine evalr (argstk, i, j) integer argstk (ARGSIZE), i, j include COMMON_BLOCKS integer argno, k, m, n, t, td integer index, length string digits '0123456789' t = argstk (i) td = evalst (t) if (td == MACTYPE) call domac (argstk, i, j) else if (td == INCTYPE) call doincr (argstk, i, j) else if (td == SUBTYPE) call dosub (argstk, i, j) else if (td == IFTYPE) call doif (argstk, i, j) else if (td == ARITHTYPE) call doarth (argstk, i, j) 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 < j - i) { n = i + argno + 1 m = argstk (n) call pbstr (evalst (m)) } k = k - 1 # skip over $ } if (k == t) # do last character call putbak (evalst (k)) } return end #-t- evalr 1126 local 12/01/80 15:54:06 #-h- finit 432 local 12/01/80 15:54:07 # finit - initialize for each input file subroutine finit include COMMON_BLOCKS outp = 0 # output character pointer level = 1 # file control linect (1) = 0 sbp = 1 fnamp = 2 fnames (1) = EOS bp = PBPOINT buf (bp) = EOS # to force a read on next call to 'ngetch' fordep = 0 # for stack fcname (1) = EOS # current function name swtop = 0 # switch stack swlast = 1 return end #-t- finit 432 local 12/01/80 15:54:07 #-h- forcod 2259 local 12/01/80 15:54:07 # forcod - beginning of for statement subroutine forcod (lab) integer lab include COMMON_BLOCKS character t, token (MAXTOK) character gettok, gnbtok integer i, j, nlpar integer length, labgen string ifnot "if (.not." lab = labgen (3) call outcon (0) if (gnbtok (token, MAXTOK) != LPAREN) { call synerr ("missing left paren.") return } if (gnbtok (token, MAXTOK) != SEMICOL) { # real init clause call pbstr (token) call outtab call eatup call outdon } if (gnbtok (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 == ALPHA) call squash (token) if (t != NEWLINE & t != UNDERLINE) call outstr (token) } call outch (RPAREN) call outch (RPAREN) call outgo (lab+2) if (nlpar < 0) call synerr ("invalid for clause.") } fordep = fordep + 1 # stack reinit clause j = 1 for (i = 1; i < fordep; i = i + 1) # find end j = j + length (forstk (j)) + 1 forstk (j) = EOS # null, in case no reinit nlpar = 0 t = gnbtok (token, MAXTOK) call pbstr (token) 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 & t != UNDERLINE) { if (t == ALPHA) call squash (token) if (j + length (token) >= MAXFORSTK) call baderr ("for clause too long.") call scopy (token, 1, forstk, j) j = j + length (token) } } lab = lab + 1 # label for next's return end #-t- forcod 2259 local 12/01/80 15:54:07 #-h- fors 458 local 12/01/80 15:54:08 # fors - process end of for statement subroutine fors (lab) integer lab include COMMON_BLOCKS integer i, j integer length 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 - 1) call outcon (lab + 1) fordep = fordep - 1 return end #-t- fors 458 local 12/01/80 15:54:08 #-h- getdef 1634 local 12/01/80 15:54:08 # getdef (for no arguments) - get name and definition subroutine getdef (token, toksiz, defn, defsiz) character token (MAXTOK), defn (MAXDEF) integer toksiz, defsiz include COMMON_BLOCKS character c, t, ptoken (MAXTOK) character gtok, ngetch integer i, nlpar call skpblk c = gtok (ptoken, MAXTOK) if (c == LPAREN) t = LPAREN # define (name, defn) else { t = BLANK # define name defn call pbstr (ptoken) } call skpblk if (gtok (token, toksiz) != ALPHA) call baderr ("non-alphanumeric name.") call skpblk c = gtok (ptoken, MAXTOK) if (t == BLANK) { # define name defn call pbstr (ptoken) i = 1 repeat { c = ngetch (c) if (i > defsiz) call baderr ("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 baderr ("missing comma in define.") # else got (name, nlpar = 0 for (i = 1; nlpar >= 0; i = i + 1) if (i > defsiz) call baderr ("definition too long.") else if (ngetch (defn (i)) == EOF) call baderr ("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 baderr ("getdef is confused.") defn (i - 1) = EOS return end #-t- getdef 1634 local 12/01/80 15:54:08 #-h- gettok 2076 local 12/01/80 15:54:09 # gettok - get token. handles file inclusion and line numbers character function gettok (token, toksiz) character token (MAXTOK) integer toksiz include COMMON_BLOCKS integer i, len integer equal, open, length character name (MAXNAME), t character deftok string fncn "function" string incl "include" for ( ; level > 0; level = level - 1) { for (gettok = deftok (token, toksiz); gettok != EOF; gettok = deftok (token, toksiz)) { if (equal (token, fncn) == YES) { call skpblk t = deftok (fcname, MAXNAME) call pbstr (fcname) if (t != ALPHA) call synerr ("missing function name.") call putbak (BLANK) return } else if (equal (token, incl) == NO) return # process 'include' statements: call skpblk t = deftok (name, MAXNAME) if (t == SQUOTE | t == DQUOTE) { len = length (name) - 1 for (i = 1; i < len; i = i + 1) name (i) = name (i + 1) name (i) = EOS } i = length (name) + 1 if (level >= NFILES) call synerr ("includes nested too deeply.") else { infile (level + 1) = open (name, READ) linect (level + 1) = 0 if (infile (level + 1) == ERR) call synerr ("can't open include.") else { level = level + 1 if (fnamp + i <= MAXFNAMES) { call scopy (name, 1, fnames, fnamp) fnamp = fnamp + i # push file name stack } } } } if (level > 1) { # close include file 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 #-t- gettok 2076 local 12/01/80 15:54:09 #-h- gnbtok 237 local 12/01/80 15:54:09 # gnbtok - get nonblank token character function gnbtok (token, toksiz) character token (MAXTOK) integer toksiz include COMMON_BLOCKS character gettok call skpblk gnbtok = gettok (token, toksiz) return end #-t- gnbtok 237 local 12/01/80 15:54:09 #-h- gtok 3278 local 12/01/80 15:54:10 # gtok - get token for Ratfor character function gtok (lexstr, toksiz) character lexstr (MAXTOK) integer toksiz include COMMON_BLOCKS character c character ngetch, type, clower integer i, b, n, d integer itoc, index string digits "0123456789abcdefghijklmnopqrstuvwxyz" c = ngetch (lexstr (1)) if (c == BLANK | c == TAB) { lexstr (1) = BLANK while (c == BLANK | c == TAB) # compress many blanks to one c = ngetch (c) if (c == SHARP) while (ngetch (c) != NEWLINE) # strip comments ; if (c != NEWLINE) call putbak (c) else lexstr (1) = NEWLINE lexstr (2) = EOS gtok = lexstr (1) return } i = 1 if (IS_LETTER(c)) { # alpha for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) if (!IS_LETTER(c) & !IS_DIGIT(c) & c != UNDERLINE) break } call putbak (c) gtok = ALPHA } else if (IS_DIGIT(c)) { # digits b = c - DIG0 # in case alternate base number for (i = 1; i < toksiz - 2; i = i + 1) { c = ngetch (lexstr (i + 1)) if (!IS_DIGIT(c)) break b = 10 * b + c - DIG0 } if (c == RADIX & b >= 2 & b <= 36) { #n%ddd... n = 0 repeat { d = index (digits, clower (ngetch (c))) - 1 if (d < 0) break n = b * n + d } call putbak (c) i = itoc (n, lexstr, toksiz) } else call putbak (c) gtok = DIGIT } else if (c == LBRACK) { # allow [ for { lexstr (1) = LBRACE gtok = LBRACE } else if (c == RBRACK) { # allow ] for } lexstr (1) = RBRACE gtok = RBRACE } else if (c == DOLLAR) { # $( and $) now used by macro processor if (ngetch (lexstr (2)) == LPAREN) { i = 2 gtok = LSTRIPC } else if (lexstr (2) == RPAREN) { i = 2 gtok = RSTRIPC } else { call putbak (lexstr (2)) gtok = DOLLAR } } else if (c == SQUOTE | c == DQUOTE) { gtok = c for (i = 2; ngetch (lexstr (i)) != lexstr (1); i = i + 1) { if (lexstr (i) == UNDERLINE) if (ngetch (c) == NEWLINE) { while (c == NEWLINE | c == BLANK | c == TAB) c = ngetch (c) lexstr (i) = c } else call putbak (c) if (lexstr (i) == NEWLINE | i >= toksiz - 1) { call synerr ("missing quote.") lexstr (i) = lexstr (1) call putbak (NEWLINE) break } } } else if (c == SHARP) { # strip comments while (ngetch (lexstr (1)) != NEWLINE) ; gtok = NEWLINE } else if (c == GREATER | c == LESS | c == NOT | c == BANG | c == TILDE | c == CARET | c == EQUALS | c == AND | c == OR) { call relate (lexstr, i) gtok = c } else gtok = c if (i >= toksiz - 1) call synerr ("token too long.") lexstr (i + 1) = EOS # Note: line number accounting is now done in 'ngetch' return end #-t- gtok 3278 local 12/01/80 15:54:10 #-h- ifcode 198 local 12/01/80 15:54:10 # ifcode - generate initial code for if subroutine ifcode (lab) integer lab include COMMON_BLOCKS integer labgen xfer = NO lab = labgen (2) call ifgo (lab) return end #-t- ifcode 198 local 12/01/80 15:54:10 #-h- ifgo 347 local 12/01/80 15:54:11 # ifgo - generate "if (.not.(...))goto lab" subroutine ifgo (lab) integer lab string ifnot "if (.not." call outtab # get to column 7 call outstr (ifnot) # " if (.not. " call balpar # collect and output condition call outch (RPAREN) # " ) " call outgo (lab) # " goto lab " return end #-t- ifgo 347 local 12/01/80 15:54:11 #-h- ifparm 689 local 12/01/80 15:54:11 # ifparm - determines if the defined symbol has arguments in its # definition. This effects how the macro is expanded. integer function ifparm (strng) character strng (ARB) character c integer i, index, type c = strng (1) if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | c == MACTYPE) ifparm = YES else { ifparm = NO for (i = 1; index (strng (i), ARGFLAG) > 0; ) { i = i + index (strng (i), ARGFLAG) # i points at char after ARGFLAG if (type (strng (i)) == DIGIT) andif (type (strng (i + 1)) != DIGIT) { ifparm = YES break } } } return end #-t- ifparm 689 local 12/01/80 15:54:11 #-h- initkw 549 local 12/01/80 15:54:11 # initkw - initialize tables and important global variables subroutine initkw include COMMON_BLOCKS pointer mktabl call dsinit (MEMSIZE) deftbl = mktabl (1) # symbol table for definitions call entdkw rkwtbl = mktabl (1) # symbol table for Ratfor key words call entrkw fkwtbl = mktabl (0) # symbol table for Fortran key words call entfkw namtbl = mktabl (1) # symbol table for long identifiers gentbl = mktabl (0) # symbol table for generated identifiers label = 23000 return end #-t- initkw 549 local 12/01/80 15:54:11 #-h- labelc 404 local 12/01/80 15:54:12 # labelc - output statement number subroutine labelc (lexstr) character lexstr (ARB) include COMMON_BLOCKS integer length xfer = NO # can't suppress goto's now if (length (lexstr) == 5) # warn about 23xxx labels if (lexstr (1) == DIG2 & lexstr (2) == DIG3) call synerr ("warning: possible label conflict.") call outstr (lexstr) call outtab return end #-t- labelc 404 local 12/01/80 15:54:12 #-h- labgen 189 local 12/01/80 15:54:12 # labgen - generate n consecutive labels, return first one integer function labgen (n) integer n include COMMON_BLOCKS labgen = label label = label + n return end #-t- labgen 189 local 12/01/80 15:54:12 #-h- lex 543 local 12/01/80 15:54:12 # lex - return lexical type of token integer function lex (lexstr) character lexstr (MAXTOK) include COMMON_BLOCKS character gnbtok integer lookup for (lex = gnbtok (lexstr, MAXTOK); lex == NEWLINE; lex = gnbtok (lexstr, MAXTOK)) ; if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE) return if (lex == DIGIT) lex = LEXDIGITS else if (lex == TOGGLE) lex = LEXLITERAL else if (lookup (lexstr, lex, rkwtbl) == YES) ; else lex = LEXOTHER return end #-t- lex 543 local 12/01/80 15:54:12 #-h- litral 316 local 12/01/80 15:54:13 # litral - process literal Fortran line subroutine litral include COMMON_BLOCKS character ngetch # Finish off any left-over characters if (outp > 0) call outdon for (outp = 1; ngetch (outbuf (outp)) != NEWLINE; outp = outp + 1) ; outp = outp - 1 call outdon return end #-t- litral 316 local 12/01/80 15:54:13 #-h- lndict 678 local 12/01/80 15:54:13 # lndict - output long-name dictionary as a debugging aid subroutine lndict include COMMON_BLOCKS character sym (MAXTOK), c character cupper integer sctabl pointer posn, locn posn = 0 while (sctabl (namtbl, sym, locn, posn) != EOF) { ifdef (UPPERC, call outch (BIGC)) ifnotdef (UPPERC, call outch (LETC)) call outtab for (; mem (locn) != EOS; locn = locn + 1) { c = mem (locn) # kluge for people with LOGICAL*1 characters ifdef (UPPERC, c = cupper (c)) call outch (c) } call outch (BLANK) call outch (BLANK) call outstr (sym) call outdon } return end #-t- lndict 678 local 12/01/80 15:54:13 #-h- ludef 495 local 12/01/80 15:54:29 # ludef --- look up a defined identifier, return its definition integer function ludef (id, defn, table) character id (ARB), defn (ARB) pointer table include COMMON_BLOCKS integer i integer lookup pointer locn ludef = lookup (id, locn, table) if (ludef == YES) { i = 1 for (; mem (locn) != EOS; locn = locn + 1) { defn (i) = mem (locn) i = i + 1 } defn (i) = EOS } else defn (1) = EOS return end #-t- ludef 495 local 12/01/80 15:54:29 #-h- ngetch 442 local 12/01/80 15:54:30 # ngetch - get a (possibly pushed back) character character function ngetch (c) character c include COMMON_BLOCKS integer getlin if (buf (bp) == EOS) if (getlin (buf (PBPOINT), infile (level)) == EOF) c = EOF else { c = buf (PBPOINT) bp = PBPOINT + 1 linect (level) = linect (level) + 1 } else { c = buf (bp) bp = bp + 1 } return (c) end #-t- ngetch 442 local 12/01/80 15:54:30 #-h- otherc 284 local 12/01/80 15:54:30 # otherc - output ordinary Fortran statement subroutine otherc (lexstr) character lexstr (ARB) include COMMON_BLOCKS xfer = NO call outtab if (IS_LETTER(lexstr (1))) call squash (lexstr) call outstr (lexstr) call eatup call outdon return end #-t- otherc 284 local 12/01/80 15:54:30 #-h- outch 357 local 12/01/80 15:54:30 # outch - put one character into output buffer subroutine outch (c) character c include COMMON_BLOCKS integer i 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 #-t- outch 357 local 12/01/80 15:54:30 #-h- outcon 332 local 12/01/80 15:54:31 # outcon - output "n continue" subroutine outcon (n) integer n include COMMON_BLOCKS string contin "continue" xfer = NO if (n <= 0 & outp == 0) return # don't need unlabeled continues if (n > 0) call outnum (n) call outtab call outstr (contin) call outdon return end #-t- outcon 332 local 12/01/80 15:54:31 #-h- outdon 257 local 12/01/80 15:54:31 # outdon - finish off an output line subroutine outdon include COMMON_BLOCKS integer allblk outbuf (outp + 1) = NEWLINE outbuf (outp + 2) = EOS if (allblk (outbuf) == NO) call putlin (outbuf, STDOUT) outp = 0 return end #-t- outdon 257 local 12/01/80 15:54:31 #-h- outgo 239 local 12/01/80 15:54:31 # outgo - output "goto n" subroutine outgo (n) integer n include COMMON_BLOCKS string sgoto "goto " if (xfer == YES) return call outtab call outstr (sgoto) call outnum (n) call outdon return end #-t- outgo 239 local 12/01/80 15:54:31 #-h- outnum 381 local 12/01/80 15:54:32 # outnum - output decimal number subroutine outnum (n) integer n character chars (MAXCHARS) integer i, m m = iabs (n) i = 0 repeat { i = i + 1 chars (i) = mod (m, 10) + DIG0 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 #-t- outnum 381 local 12/01/80 15:54:32 #-h- outstr 687 local 12/01/80 15:54:32 # outstr - output string; handles quoted literals subroutine outstr (str) character str (ARB) character c character cupper integer i, j for (i = 1; str (i) != EOS; i = i + 1) { c = str (i) if (c != SQUOTE & c != DQUOTE) { # produce upper case fortran, if desired ifdef (UPPERC, c = cupper (c) ) call outch (c) } else { i = i + 1 for (j = i; str (j) != c; j = j + 1) # find end ; call outnum (j - i) call outch (BIGH) for ( ; i < j; i = i + 1) call outch (str (i)) } } return end #-t- outstr 687 local 12/01/80 15:54:32 #-h- outtab 140 local 12/01/80 15:54:32 # outtab - get past column 6 subroutine outtab include COMMON_BLOCKS while (outp < 6) call outch (BLANK) return end #-t- outtab 140 local 12/01/80 15:54:32 #-h- parse 2627 local 12/01/80 15:54:32 # parse - parse Ratfor source program subroutine parse include COMMON_BLOCKS character lexstr (MAXTOK) integer lab, labval (MAXSTACK), lextyp (MAXSTACK), sp, token, i integer lex call finit 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 == LEXSWITCH) call swcode (lab) else if (token == LEXCASE | token == LEXDEFAULT) { for (i = sp; i > 0; i = i - 1) # find for most recent switch if (lextyp (i) == LEXSWITCH) break if (i == 0) call synerr ("illegal case or default.") else call cascod (labval (i), token) } 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 == LEXSWITCH | token == LEXDO | token == LEXDIGITS | token == LBRACE) { sp = sp + 1 # beginning of statement if (sp > MAXSTACK) call baderr ("stack overflow in parser.") lextyp (sp) = token # stack type and value labval (sp) = lab } else if (token != LEXCASE & token != LEXDEFAULT) { if (token == RBRACE) { if (lextyp (sp) == LBRACE) sp = sp - 1 else if (lextyp (sp) == LEXSWITCH) { call swend (labval (sp)) sp = sp - 1 } else call synerr ("illegal right brace.") } else if (token == LEXOTHER) call otherc (lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt (sp, lextyp, labval, token) else if (token == LEXRETURN) call retcod else if (token == LEXSTRING) call strdcl 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 #-t- parse 2627 local 12/01/80 15:54:32 #-h- pbnum 304 local 12/01/80 15:54:33 # pbnum - convert number to string, push back on input subroutine pbnum (n) integer n integer m, num integer mod string digits '0123456789' num = n repeat { m = mod (num, 10) call putbak (digits (m + 1)) num = num / 10 } until (num == 0) return end #-t- pbnum 304 local 12/01/80 15:54:33 #-h- pbstr 207 local 12/01/80 15:54:33 # pbstr - push string back onto input subroutine pbstr (in) character in (ARB) integer i integer length for (i = length (in); i > 0; i = i - 1) call putbak (in (i)) return end #-t- pbstr 207 local 12/01/80 15:54:33 #-h- push 249 local 12/01/80 15:54:34 # push - push ep onto argstk, return new pointer ap integer function push (ep, argstk, ap) integer ap, argstk (ARGSIZE), ep if (ap > ARGSIZE) call baderr ('arg stack overflow.') argstk (ap) = ep push = ap + 1 return end #-t- push 249 local 12/01/80 15:54:34 #-h- putbak 254 local 12/01/80 15:54:34 # putbak - push character back onto input subroutine putbak (c) character c include COMMON_BLOCKS if (bp <= 1) call baderr ("too many characters pushed back.") else { bp = bp - 1 buf (bp) = c } return end #-t- putbak 254 local 12/01/80 15:54:34 #-h- putchr 233 local 12/01/80 15:54:34 # putchr - put single char into eval stack subroutine putchr (c) character c include COMMON_BLOCKS if (ep > EVALSIZE) call baderr ('evaluation stack overflow.') evalst (ep) = c ep = ep + 1 return end #-t- putchr 233 local 12/01/80 15:54:34 #-h- puttok 198 local 12/01/80 15:54:34 # puttok-put token into eval stack subroutine puttok (str) character str (MAXTOK) integer i for (i = 1; str (i) != EOS; i = i + 1) call putchr (str (i)) return end #-t- puttok 198 local 12/01/80 15:54:34 #-h- relate 1276 local 12/01/80 15:54:35 # relate - convert relational shorthands into long form subroutine relate (token, last) character token (ARB) integer last character ngetch integer length if (ngetch (token (2)) != EQUALS) { call putbak (token (2)) token (3) = LETT } else token (3) = LETE token (4) = PERIOD token (5) = EOS token (6) = EOS # for .not. and .and. if (token (1) == GREATER) token (2) = LETG else if (token (1) == LESS) token (2) = LETL else if (token (1) == NOT | token (1) == BANG | token (1) == CARET | token (1) == TILDE) { if (token (2) != EQUALS) { token (3) = LETO token (4) = LETT token (5) = PERIOD } token (2) = LETN } else if (token (1) == EQUALS) { if (token (2) != EQUALS) { token (2) = EOS last = 1 return } token (2) = LETE token (3) = LETQ } else if (token (1) == AND) { token (2) = LETA token (3) = LETN token (4) = LETD token (5) = PERIOD } else if (token (1) == OR) { token (2) = LETO token (3) = LETR } else # can't happen token (2) = EOS token (1) = PERIOD last = length (token) return end #-t- relate 1276 local 12/01/80 15:54:35 #-h- repcod 262 local 12/01/80 15:54:35 # repcod - generate code for beginning of repeat subroutine repcod (lab) integer lab integer labgen call outcon (0) # in case there was a label lab = labgen (3) call outcon (lab) lab = lab + 1 # label to go on next's return end #-t- repcod 262 local 12/01/80 15:54:35 #-h- retcod 580 local 12/01/80 15:54:35 # retcod - generate code for return subroutine retcod include COMMON_BLOCKS character token (MAXTOK), t character gnbtok string sret "return" t = gnbtok (token, MAXTOK) if (t != NEWLINE & t != SEMICOL & t != RBRACE) { call pbstr (token) call outtab call scopy (fcname, 1, token, 1) call squash (token) call outstr (token) call outch (EQUALS) call eatup call outdon } else if (t == RBRACE) call pbstr (token) call outtab call outstr (sret) call outdon xfer = YES return end #-t- retcod 580 local 12/01/80 15:54:35 #-h- sdupl 374 local 12/01/80 15:55:03 # sdupl --- duplicate a string in dynamic storage space pointer function sdupl (str) character str (ARB) DS_DECL(mem, MEMSIZE) integer i integer length pointer j pointer dsget j = dsget (length (str) + 1) sdupl = j for (i = 1; str (i) != EOS; i = i + 1) { mem (j) = str (i) j = j + 1 } mem (j) = EOS return end #-t- sdupl 374 local 12/01/80 15:55:03 #-h- skpblk 247 local 12/01/80 15:55:04 # skpblk - skip blanks and tabs in current input file subroutine skpblk include COMMON_BLOCKS character c character ngetch for (c = ngetch (c); c == BLANK | c == TAB; c = ngetch (c)) ; call putbak (c) return end #-t- skpblk 247 local 12/01/80 15:55:04 #-h- squash 1515 local 12/01/80 15:55:04 # squash - convert a long or special identifier into a Fortran variable subroutine squash (id) character id (MAXTOK) include COMMON_BLOCKS integer junk, i, j integer lookup character newid (MAXTOK), recdid (MAXTOK) j = 1 for (i = 1; id (i) != EOS; i = i + 1) if (IS_LETTER(id (i)) | IS_DIGIT(id (i))) { newid (j) = id (i) j = j + 1 } newid (j) = EOS if (i - 1 < MAXIDLENGTH & i == j) return # an ordinary (short) Fortran variable if (i - 1 == MAXIDLENGTH & i == j) if (id (MAXIDLENGTH) != FILLCHAR) return # a 6-character variable, but no possible conflict # Otherwise, the identifier (1) is longer than Fortran allows, # (2) contains special characters (_ or .), or (3) is exactly # MAXIDLENGTH characters long and ends with the "fill character." # The first two cases obviously call for name conversion; the last # case requires conversion to avoid accidental conflicts with # automatically generated names. if (lookup (id, junk, fkwtbl) == YES) # Fortran key word? return # (must be treated as reserved) if (ludef (id, recdid, namtbl) == YES) { # have we seen this before? call scopy (recdid, 1, id, 1) return } call uniqid (newid) # get an identifier never before seen call entdef (id, newid, namtbl) # record it for posterity call scopy (newid, 1, id, 1) # and substitute it for the old one return end #-t- squash 1515 local 12/01/80 15:55:04 #-h- strdcl 2575 local 12/01/80 15:55:05 # strdcl - generate code for string declaration subroutine strdcl include COMMON_BLOCKS character t, token (MAXTOK), dchar (MAXTOK) character gnbtok integer i, j, k, n, len integer length, ctoi, lex string char "character/" string dat "data " string eoss "EOS/" t = gnbtok (token, MAXTOK) if (t != ALPHA) call synerr ("missing string token.") call squash (token) call outtab call pbstr (char) # use defined meaning of "character" repeat { t = gnbtok (dchar, MAXTOK) if (t == SLASH) break call outstr (dchar) } call outch (BLANK) # separator in declaration call outstr (token) call addstr (token, sbuf, sbp, SBUFSIZE) # save for later call addchr (EOS, sbuf, sbp, SBUFSIZE) if (gnbtok (token, MAXTOK) != LPAREN) { # make size same as initial value len = length (token) + 1 if (token (1) == SQUOTE | token (1) == DQUOTE) len = len - 2 } else { # form is string name (size) init t = gnbtok (token, MAXTOK) i = 1 len = ctoi (token, i) if (token (i) != EOS) call synerr ("invalid string size.") if (gnbtok (token, MAXTOK) != RPAREN) call synerr ("missing right paren.") else t = gnbtok (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, SBUFSIZE) } else call addstr (token, sbuf, sbp, SBUFSIZE) call addchr (EOS, sbuf, sbp, SBUFSIZE) 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 = sbuf (j) call outnum (n) call outch (SLASH) k = k + 1 } call pbstr (eoss) # use defined meaning of EOS repeat { t = gnbtok (token, MAXTOK) call outstr (token) } until (t == SLASH) call outdon } sbp = 1 } return end #-t- strdcl 2575 local 12/01/80 15:55:05 #-h- swcode 746 local 12/01/80 15:55:06 # swcode - generate code for beginning of switch statement subroutine swcode (lab) integer lab include COMMON_BLOCKS character tok (MAXTOK) integer labgen, gnbtok lab = labgen (2) if (swlast + 3 > MAXSWITCH) call baderr ("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 while (gnbtok (tok, MAXTOK) == NEWLINE) ; if (tok (1) != LBRACE) { call synerr ("missing left brace in switch statement.") call pbstr (tok) } return end #-t- swcode 746 local 12/01/80 15:55:06 #-h- swend 2714 local 12/01/80 15:55:07 # swend - finish off switch statement; generate dispatch code subroutine swend (lab) integer lab include COMMON_BLOCKS integer lb, ub, n, i, j 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 + 1) # terminate last case if (swstak (swtop + 2) == 0) swstak (swtop + 2) = lab + 1 # 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 j = swstak (i + 1) + 1 if (i < swlast - 3) call outch (COMMA) } call outch (RPAREN) call outch (COMMA) 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 + 1 != swstak (swtop + 2)) call outgo (swstak (swtop + 2)) } call outcon (lab + 1) # L+1 continue swlast = swtop # pop switch stack swtop = swstak (swtop) return end #-t- swend 2714 local 12/01/80 15:55:07 #-h- swvar 157 local 12/01/80 15:55:08 # swvar - output switch variable Innn, where nnn = lab subroutine swvar (lab) integer lab call outch (BIGI) call outnum (lab) return end #-t- swvar 157 local 12/01/80 15:55:08 #-h- synerr 703 local 12/01/80 15:55:08 # synerr --- report non-fatal error subroutine synerr (msg) character msg (ARB) include COMMON_BLOCKS character lc (MAXCHARS) integer i, junk integer itoc string in " in " string errmsg "error at line " call putlin (errmsg, ERROUT) if (level >= 1) i = level else i = 1 # for EOF errors junk = itoc (linect (i), lc, MAXCHARS) call putlin (lc, ERROUT) for (i = fnamp - 1; i > 1; i = i - 1) if (fnames (i - 1) == EOS) { # print file name call putlin (in, ERROUT) call putlin (fnames (i), ERROUT) break } call putch (COLON, ERROUT) call putch (BLANK, ERROUT) call remark (msg) return end #-t- synerr 703 local 12/01/80 15:55:08 #-h- ulstal 268 local 12/01/80 15:55:09 # ulstal - install lower and upper case versions of symbol subroutine ulstal (name, defn) character name (ARB), defn (ARB) include COMMON_BLOCKS call entdef (name, defn, deftbl) call upper (name) call entdef (name, defn, deftbl) return end #-t- ulstal 268 local 12/01/80 15:55:09 #-h- uniqid 1825 local 12/01/80 15:55:09 # uniqid - convert an identifier to one never before seen subroutine uniqid (id) character id (MAXTOK) include COMMON_BLOCKS integer i, j, junk, idchl, carry integer lookup, index, length character start (MAXIDLENGTH) string idch "0123456789abcdefghijklmnopqrstuvwxyz" # legal id characters # Pad the identifer out to length 6 with FILLCHARs: for (i = 1; id (i) != EOS; i = i + 1) ; for (; i <= MAXIDLENGTH; i = i + 1) id (i) = FILLCHAR i = MAXIDLENGTH + 1 id (i) = EOS id (i - 1) = FILLCHAR # Look it up in the table of generated names. If it's not there, # it's unique. If it is there, it has been generated previously; # modify it and try again. Assume this procedure always succeeds, # since to fail implies there are very, very many identifiers in # the symbol table. # Note that we must preserve the first and last characters of the # id, so as not to disturb implicit typing and to provide a flag # to catch potentially conflicting user-defined identifiers without # a lookup. if (lookup (id, junk, gentbl) == YES) { # (not very likely) idchl = length (idch) for (i = 2; i < MAXIDLENGTH; i = i + 1) start (i) = id (i) repeat { # until we get a unique id for (i = MAXIDLENGTH - 1; i > 1; i = i - 1) { j = mod (index (idch, id (i)), idchl) + 1 id (i) = idch (j) if (id (i) != start (i)) break } if (i == 1) call baderr ("cannot make identifier unique.") } until (lookup (id, junk, gentbl) == NO) } # At this point, 'id' contains a unique identifier, not previously # seen in this compilation. Save it for future reference. call enter (id, 0, gentbl) return end #-t- uniqid 1825 local 12/01/80 15:55:09 #-h- unstak 854 local 12/01/80 15:55:10 # 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 | lextyp (sp) == LEXSWITCH) break if (lextyp (sp) == LEXIF & token == LEXELSE) break if (lextyp (sp) == LEXIF) call outcon (labval (sp)) else if (lextyp (sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon (labval (sp) + 1) } else if (lextyp (sp) == LEXDO) call dostat (labval (sp)) else if (lextyp (sp) == LEXWHILE) call whiles (labval (sp)) else if (lextyp (sp) == LEXFOR) call fors (labval (sp)) else if (lextyp (sp) == LEXREPEAT) call untils (labval (sp), token) } return end #-t- unstak 854 local 12/01/80 15:55:10 #-h- untils 397 local 12/01/80 15:55:11 # untils - generate code for until or end of repeat subroutine untils (lab, token) integer lab, token include COMMON_BLOCKS character ptoken (MAXTOK) integer junk integer lex xfer = NO call outnum (lab) if (token == LEXUNTIL) { junk = lex (ptoken) call ifgo (lab - 1) } else call outgo (lab - 1) call outcon (lab + 1) return end #-t- untils 397 local 12/01/80 15:55:11 #-h- whilec 262 local 12/01/80 15:55:11 # whilec - generate code for beginning of while subroutine whilec (lab) integer lab integer labgen call outcon (0) # unlabeled continue, in case there was a label lab = labgen (2) call outnum (lab) call ifgo (lab + 1) return end #-t- whilec 262 local 12/01/80 15:55:11 #-h- whiles 148 local 12/01/80 15:55:12 # whiles - generate code for end of while subroutine whiles (lab) integer lab call outgo (lab) call outcon (lab + 1) return end #-t- whiles 148 local 12/01/80 15:55:12 #-t- ratfor.r 69694 local 12/01/80 15:56:25 nk = lex (ptoken)