#-h- rat4cbl 9467 asc 7-oct-80 08:03:01 #-h- rat4sym 4651 asc 7-oct-80 07:30:14 # Definitions used by the ratfor preprocessor # Should be put on a file called 'rat4sym' # Used by ratfor preprocessor, macro, and form tools #--------------------------------------------------------------- # # 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 "". # #--------------------------------------------------------------- # Some of the buffer sizes and other symbols might have to be # changed. Especially check the following: # # NFILES (max depth of file inclusion) # MAXDEF (number of characters in a definition) # MAXFNAMES (number of characters in file name stack) # MAXTBL (size of definition table) # MAXPTR (nbr of defines in lookup) # SBUFSIZE (nbr string declarations allowed per module) # MAXSTRTBL (size of table to buffer string declarations) # MAXSWITCH (max stack for switch statement) # #----------------------------------------------------------------- # # Also, all the LEX-- definitions might have to be altered for # systems where 'character' is not defined as 'integer'. # #----------------------------------------------------------------- # # # define(STDEFNS,"ratdef") #name of file containing standard defns define(STDEFNS,"symbols") define(RADIX,PERCENT) # % indicates alternate radix define(TOGGLE,PERCENT) # toggle for literal lines define(BUFSIZE,300) # pushback buffer for ngetch and putbak define(SBUFSIZE,500) # buffer for string statements define(DEFTYPE,10010) # or define(DEFTYPE,-4) define(MAXCHARS,10) # characters for outnum define(MAXDEF,200) # max chars in a defn define(MAXFORSTK,200) # max space for for reinit clauses define(MAXPTR,625) # nbr of defines in lookup define(MAXSTACK,100) # max stack depth for parser define(MAXSWITCH,1000) # max stack for switch statement define(MAXTBL,6250) # max chars in all definitions define(MAXTOK,100) # max chars in a token define(NFILES,arith(MAXOFILES,-,3)) # max depth of file inclusion define(MAXFNAMES,arith(NFILES,*,FILENAMESIZE)) # max chars in file name # stack = NFILES * FILENAMESIZE define(NHASHPTR,37) #number of pointer listheads for hash table define(MAXNBRSTR,20) #max nbr string declarations per module 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(LEXBREAK,10264) #or define(LEXBREAK,-8) define(LEXCASE,10276) #or define(LEXCASE,-25) define(LEXDEFAULT,10277) #or define(LEXDEFAULT,-26) define(LEXDIGITS,10260) #or define(LEXDIGITS,-9) define(LEXDO,0266) #or define(LEXDO,-10) define(LEXELSE,10262) #or define(LEXELSE,-11) define(LEXEND,10272) #or define(LEXEND,-21) define(LEXFOR,10268) #or define(LEXFOR,-16) define(LEXIF,10261) #or define(LEXIF,-19) define(LEXLITERAL,10278) #or define(LEXLITERAL,-27) define(LEXNEXT,10265) #or define(LEXNEXT,-13) define(LEXOTHER,10267) #or define(LEXOTHER,-14) define(LEXREPEAT,10269) #or define(LEXREPEAT,-17) define(LEXRETURN,10271) #or define(LEXRETURN,-20) define(LEXSTOP,10273) #or define(LEXSTOP,-22) define(LEXSTRING,10274) #or define(LEXSTRING,-23) define(LEXSWITCH,10275) #or define(LEXSWITCH,-24) define(LEXUNTIL,10270) #or define(LEXUNTIL,-18) define(LEXWHILE,10263) #or define(LEXWHILE,-15) #-------------------------------------------------------------- # Special definitions for VAX/VMS implementation # Remove for portable version define(DEFTYPE,-4) 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(MAXNAME,FILENAMESIZE) define(initst,initr4) define(endst,endr4) define(LSTRIPC,-10) define(RSTRIPC,-11) #-h- cdefio 297 asc 7-oct-80 07:30:15 ## Preprocessor common block to hold input characters # Put on a file called 'cdefio' # Used by ratfor preprocessor, macro, roff, form, and shell tools common /cdefio/ bp, buf(BUFSIZE) integer bp # next available character; init = 0 character buf # pushed-back characters #-h- cfname 219 asc 7-oct-80 07:30:16 ## Preprocessor common block used to hold current function name # Put on a file named 'cfname' # Used by ratfor preprocessor common /cfname/ fcname(MAXNAME) character fcname # text of current function name #-h- cfor 273 asc 7-oct-80 07:30:16 ## Preprocessor common block to hold info about 'for' statement # Put on a file named 'cfor' # Used by ratfor preprocessor common /cfor/ fordep, forstk(MAXFORSTK) integer fordep # current depth of for statements character forstk # stack of reinit strings #-h- cgoto 205 asc 7-oct-80 07:30:16 ## Preprocessor common block used to hold 'goto' flag # Put on a file named 'cgoto' # Used by ratfor preprocessor common /cgoto/ xfer integer xfer # YES if just made transfer, NO otherwise #-h- clabel 202 asc 7-oct-80 07:30:17 ## Preprocessor common block used to hold statement label # Put on a file called 'clabel' # Used by ratfor preprocessor common /clabel/ label integer label # next label returned by labgen #-h- cline 544 asc 7-oct-80 07:30:17 ## Preprocessor common block used to hold info about lines # and included files # Put on a file named 'cline' # Used only by ratfor preprocessor 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 #-h- clook 894 asc 7-oct-80 07:30:18 ## Common block used to hold hash table and definitions # Put on a file named 'clook' # Used by ratfor preprocessor, macro, roff, and form tools common /clook/ lastp, lastt, hshptr(NHASHPTR), tabptr(2,MAXPTR), table(MAXTBL) integer lastp # last used tabptr entry; init = 0 integer lastt # last used table entry; init = 0 integer hshptr # listheads for linked list of pointers; init=0 integer tabptr # linked list of pointers to table # tabptr(1,n) points to next element of linked # list # tabptr(2,n) points to (name,defn) combo in # table # init all entries to 0; end of linked list has # tabprt(1,n) = 0 character table # actual text of names and definitions #-h- coutln 283 asc 7-oct-80 07:30:18 ## Preprocessor common block used to hold output characters # Put on a file named 'coutln' # Used only by ratfor preprocessor common /coutln/ outp, outbuf(74) integer outp # last position filled in outbuf; init = 0 character outbuf # output lines collected here #-h- csbuf 286 asc 7-oct-80 07:30:18 ## preprocessor common block for holding string statement info # Put on a file called 'csbuf' # Used only by ratfor preprocessor common /csbuf/ sbp, sbuf(SBUFSIZE) integer sbp # next available character position; init = 1 character sbuf # saved for data statements #-h- cswtch 320 asc 7-oct-80 07:30:19 ## Preprocessor common block used to hold switch info # Put on a file named 'cswtch' # Used only by ratfor preprocessor common /cswtch/ swtop, swlast, swstak(MAXSWITCH) integer swtop # current switch entry; init = 0 integer swlast # next available position; init = 1 integer swstak # switch information #-h- macsym 370 asc 7-oct-80 08:02:46 ## /macsym/ - definitions for macro processor # put on a file named 'macsym' # used by the macro and rat4 tools define(CALLSIZE,50) define(ARGSIZE,100) define(ARGFLAG,DOLLAR) define(MACTYPE,-10) define(IFTYPE,-11) define(INCTYPE,-12) define(SUBTYPE,-13) define(ARITHTYPE,-14) define(IFDEFTYPE,-15) define(IFNOTDEFTYPE,-16) define(EVALSIZE,500) #-h- cmacro 286 asc 7-oct-80 07:30:20 # -cmacro- common block # put on a file called 'cmacro' # Used only by the macro tool common /cmacro/ cp, ep, evalst(EVALSIZE) integer cp # current call stack pointer integer ep # next free position in evalst character evalst # evaluation stack #-h- defns 88 asc 03-jul-80 09:32:12 ## include all required definitions # include ratdef include rat4sym include macsym #-h- getdef 1703 asc 03-jul-80 08:23:04 # define statement and symbol table # routines in this group are getdef, instal, lookup, hshfcn, tbinit # getdef (for no arguments) - get name and definition subroutine getdef(token, toksiz, defn, defsiz, fd) character gtok, ngetch integer defsiz, fd, i, nlpar, toksiz character c, defn(MAXDEF), token(MAXTOK), t, ptoken(MAXTOK) call skpblk(fd) c = gtok(ptoken, MAXTOK, fd) if (c == LPAREN) t = LPAREN # define (name, defn) else { t = BLANK # define name defn call pbstr(ptoken) } call skpblk(fd) if (gtok(token, toksiz, fd) ^= ALPHA) call baderr("non-alphanumeric name.") call skpblk(fd) c = gtok(ptoken, MAXTOK, fd) if (t == BLANK) { # define name defn call pbstr(ptoken) i = 1 repeat { c = ngetch(c, fd) if (i > defsiz) call 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), fd) == 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 #-h- instal 681 asc 03-jul-80 08:23:07 ## instal - add name and definition to table subroutine instal(name, defn) character name(MAXTOK), defn(MAXDEF) integer nlen, dlen, length, c, hshfcn # include commonblocks include clook nlen = length(name) + 1 dlen = length(defn) + 1 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR) { call putlin(name, ERROUT) call remark(" : too many definitions.") } else { lastp = lastp + 1 tabptr(2, lastp) = lastt + 1 c = hshfcn(name, NHASHPTR) tabptr(1, lastp) = hshptr(c) hshptr(c) = lastp call scopy(name, 1, table, lastt + 1) call scopy(defn, 1, table, lastt + nlen + 1) lastt = lastt + nlen + dlen } return end #-h- lookup 518 asc 03-jul-80 08:23:08 ## lookup - lookup up definition in table integer function lookup(name, defn) character name(MAXTOK), defn(MAXDEF) integer c, hshfcn, i, j, k # include commonblocks include clook c = hshfcn(name, NHASHPTR) lookup = NO for (i=hshptr(c); i > 0; i=tabptr(1,i)) { j = tabptr(2, i) for (k=1; name(k) == table(j) & name(k) != EOS; k=k+1) j = j + 1 if (name(k) == table(j)) { call scopy(table, j+1, defn, 1) lookup = YES break } } return end #-h- hshfcn 388 asc 03-jul-80 08:23:10 ## hshfcn - hash function # # this is a portable version of the hash function. It takes the first # and last characters of the string, sums them, and then returns # the (sum modulo n) + 1. # integer function hshfcn(strng, n) character strng(ARB) integer n, i, length, i1, i2 i = length(strng) i = max(i, 1) i1 = strng(1) i2 = strng(i) hshfcn = mod(i1+i2, n) + 1 return end #-h- tbinit 204 asc 03-jul-80 08:23:12 ## tbinit - initialize hash table subroutine tbinit # include commonblocks include clook #initialize hash table lastp = 0 lastt = 0 for (i=1; i<=NHASHPTR; i=i+1) hshptr(i) = 0 return end #-h- docode 566 asc 03-jul-80 08:24:51 # do statement - routines in this group are docode, dostat # docode - generate code for beginning of do subroutine docode(lab) integer labgen integer lab character gnbtok character lexstr(MAXTOK) # include commonblocks include cgoto 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 #-h- dostat 153 asc 03-jul-80 08:24:53 # dostat - generate code for end of do statement subroutine dostat(lab) integer lab call outcon(lab) call outcon(lab+1) return end #-h- baderr 146 asc 03-jul-80 08:26:17 ## error processing - routines in this group are baderr, synerr subroutine baderr(msg) character msg(ARB) call synerr(msg) call endst end #-h- synerr 568 asc 03-jul-80 08:26:18 subroutine synerr(msg) character lc(MAXCHARS), msg(ARB) integer itoc integer i, junk # include commonblocks include cline 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 #-h- forcod 2175 asc 03-jul-80 08:28:27 # for statement - routines in this group are forcod, fors # forcod - beginning of for statement subroutine forcod(lab) character gettok, gnbtok character t, token(MAXTOK) integer length, labgen integer i, j, lab, nlpar # include commonblocks include cfor 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 ^= 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 (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 #-h- fors 465 asc 03-jul-80 08:28:30 # fors - process end of for statement subroutine fors(lab) integer length integer i, j, lab # include commonblocks 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-1) call outcon(lab+1) fordep = fordep - 1 return end #-h- balpar 857 asc 03-jul-80 08:31:17 # if statement - routines in this group are balpar, elseif, ifcode, ifgo # balpar - copy balanced paren string subroutine balpar character gettok, gnbtok character t, token(MAXTOK) 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 # else nothing special call outstr(token) } until (nlpar <= 0) if (nlpar ^= 0) call synerr("missing parenthesis in condition.") return end #-h- elseif 151 asc 03-jul-80 08:31:19 # elseif - generate code for end of if before else subroutine elseif(lab) integer lab call outgo(lab+1) call outcon(lab) return end #-h- ifcode 210 asc 03-jul-80 08:31:20 # ifcode - generate initial code for if subroutine ifcode(lab) integer labgen integer lab # include commonblocks include cgoto xfer = NO lab = labgen(2) call ifgo(lab) return end #-h- ifgo 339 asc 03-jul-80 08:31:21 # 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 #-h- gettok 3131 asc 03-jul-80 08:36:32 # lexical analyzer # routines in this group are gettok, gnbtok, gtok, lex, ngetch, # pbstr, putbak, relate # deftok - get token; process macro calls and invocations # this routine has been disabled to allow defines with parameters to be added # see deftok for the code for deftok # character function deftok(token, toksiz, fd) # character gtok # integer fd, toksiz # character defn(MAXDEF), t, token(MAXTOK) # integer lookup # # for (t=gtok(token, toksiz, fd); t^=EOF; t=gtok(token, toksiz, fd)) { # if (t ^= ALPHA) # non-alpha # break # if (lookup(token, defn) == NO) # undefined # break # if (defn(1) == DEFTYPE) { # get definition # call getdef(token, toksiz, defn, MAXDEF, fd) # call instal(token, defn) # } # else # call pbstr(defn) # push replacement onto input # } # deftok = t # if (deftok == ALPHA) # convert to single case # call fold(token) # return # end # gettok - get token. handles file inclusion and line numbers character function gettok(token, toksiz) integer equal, open, length integer i, toksiz, f, len character t character deftok, ngetch character getch character name(MAXNAME), token(MAXTOK) # include commonblocks include cline include cfname string fncn "function" string incl "include" for ( ; level > 0; level = level - 1) { f = infile(level) for (gettok = deftok(token, toksiz, f); gettok ^= EOF; gettok = deftok(token, toksiz, f)) { if (equal(token, fncn) == YES) { call skpblk(infile(level)) t = deftok(fcname, MAXNAME, f) call pbstr(fcname) if (t ^= ALPHA) call synerr("missing function name.") call putbak(BLANK) return } else if (equal(token, incl) == NO) return #process includes call skpblk(infile(level)) t = deftok(name, MAXNAME, infile(level)) 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) = 1 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 } f = infile(level) } } } if (level > 1) { # close include and pop file name stack call close(infile(level)) for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1) if (fnames(fnamp-1) == EOS) break } } token(1) = EOF # in case called more than once token(2) = EOS gettok = EOF return end #-h- gnbtok 252 asc 03-jul-80 08:36:37 # gnbtok - get nonblank token character function gnbtok(token, toksiz) integer toksiz character token(MAXTOK), gettok # include commonblocks include cline call skpblk(infile(level)) gnbtok = gettok(token, toksiz) return end #-h- gtok 3865 asc 03-jul-80 08:36:40 # gtok - get token for Ratfor character function gtok(lexstr, toksiz, fd) character ngetch, type integer fd, i, b, n, toksiz, itoc character c, lexstr(MAXTOK) # include commonblocks include cline c = ngetch(lexstr(1), fd) if (c == BLANK | c == TAB) { lexstr(1) = BLANK while (c == BLANK | c == TAB) # compress many blanks to one c = ngetch(c, fd) if (c == SHARP) while (ngetch(c, fd) ^= NEWLINE) # strip comments ; if (c ^= NEWLINE) call putbak(c) else lexstr(1) = NEWLINE lexstr(2) = EOS gtok = lexstr(1) return } i = 1 gtok = type(c) if (gtok == LETTER) { # alpha for (i = 1; i < toksiz - 2; i = i + 1) { gtok = type(ngetch(lexstr(i+1), fd)) if (gtok ^= LETTER & gtok ^= DIGIT & gtok ^= UNDERLINE & gtok ^= PERIOD) break } call putbak(lexstr(i+1)) gtok = ALPHA } else if (gtok == DIGIT) { # digits b = c - DIG0 # in case alternate base number for (i = 1; i < toksiz - 2; i = i + 1) { if (type(ngetch(lexstr(i+1), fd)) ^= DIGIT) break b = 10*b + lexstr(i+1) - DIG0 } if (lexstr(i+1) == RADIX & b >= 2 & b <= 36) { #n%ddd... for (n = 0;; n = b*n + c - DIG0) { c = ngetch(lexstr(1), fd) if (c >= LETA & c <= LETZ) c = c - LETA + DIG9 + 1 else if (c >= BIGA & c <= BIGZ) c = c - BIGA + DIG9 + 1 if (c < DIG0 | c >= DIG0 + b) break } call putbak(lexstr(1)) i = itoc(n, lexstr, toksiz) } else call putbak(lexstr(i+1)) 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) { # allow $( and $) for { and } # if (ngetch(lexstr(2), fd) == LPAREN) { # lexstr(1) = LBRACE # gtok = LBRACE # } # else if (lexstr(2) == RPAREN) { # lexstr(1) = RBRACE # gtok = RBRACE # } # else # call putbak(lexstr(2)) # } # the above code has been disabled in order to allow $( and $) to # surround strings to be copied directly to the evaluation stack within # macros. This is done by returninig dummy character values when these # digraphs are seen else if (c == DOLLAR) { if (ngetch(lexstr(2), fd) == LPAREN) { lexstr(1) = LSTRIPC gtok = LSTRIPC } else if (lexstr(2) == RPAREN) { lexstr(1) = RSTRIPC gtok = RSTRIPC } else call putbak(lexstr(2)) } else if (c == SQUOTE | c == DQUOTE) { for (i = 2; ngetch(lexstr(i), fd) ^= lexstr(1); i = i + 1) { if (lexstr(i) == UNDERLINE) if (ngetch(c, fd) == NEWLINE) { while (c == NEWLINE | c == BLANK | c == TAB) c = ngetch(c, fd) 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), fd) ^= NEWLINE) ; gtok = NEWLINE } else if (c == GREATER | c == LESS | c == NOT | c == BANG | c == CARET | c == EQUALS | c == AND | c == OR) call relate(lexstr, i, fd) if (i >= toksiz-1) call synerr("token too long.") lexstr(i+1) = EOS if (lexstr(1) == NEWLINE) linect(level) = linect(level) + 1 return end #-h- lex 1680 asc 03-jul-80 08:36:46 # lex - return lexical type of token integer function lex(lexstr) character gnbtok, deftok character lexstr(MAXTOK) integer equal # include commonblocks 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" 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 (equal(lexstr, sif) == YES) lex = LEXIF else if (equal(lexstr, selse) == YES) lex = LEXELSE else if (equal(lexstr, swhile) == YES) lex = LEXWHILE else if (equal(lexstr, sdo) == YES) lex = LEXDO else if (equal(lexstr, sbreak) == YES) lex = LEXBREAK else if (equal(lexstr, snext) == YES) lex = LEXNEXT else if (equal(lexstr, sfor) == YES) lex = LEXFOR else if (equal(lexstr, srept) == YES) lex = LEXREPEAT else if (equal(lexstr, suntil) == YES) lex = LEXUNTIL else if (equal(lexstr, sret) == YES) lex = LEXRETURN else if (equal(lexstr, sstr) == YES) lex = LEXSTRING else if (equal(lexstr, sswtch) == YES) lex = LEXSWITCH else if (equal(lexstr, scase) == YES) lex = LEXCASE else if (equal(lexstr, sdeflt) == YES) lex = LEXDEFAULT else lex = LEXOTHER return end #-h- ngetch 303 asc 03-jul-80 08:36:51 # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd # include commonblocks include cdefio if (bp > 0) { c = buf(bp) bp = bp - 1 } else c = getch(c, fd) ngetch = c return end #-h- pbstr 200 asc 03-jul-80 08:36:53 # 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 #-h- putbak 249 asc 03-jul-80 08:36:56 # putbak - push character back onto input subroutine putbak(c) character c # include commonblocks include cdefio bp = bp + 1 if (bp > BUFSIZE) call baderr("too many characters pushed back.") buf(bp) = c return end #-h- relate 1214 asc 03-jul-80 08:37:00 # relate - convert relational shorthands into long form subroutine relate(token, last, fd) character ngetch character token(ARB) integer length integer fd, last if (ngetch(token(2), fd) ^= 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) { 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 #-h- rat4s 1246 asc 12-oct-80 17:46:35 ## main driving routines for ratfor preprocessor # call initst # call rat4 # call endst # end ## rat4 - driver subroutine for ratfor preprocessor # subroutine rat4 subroutine main integer getarg, open character buf(FILENAMESIZE) integer i # include commonblocks include cline #needed to set input file string defns STDEFNS #set 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) { call getdir(BINDIRECTORY, LOCAL, buf) call concat(buf, defns, buf) infile(1) = open(buf, READ) if (infile(1) == ERR) call remark ("can't open standard definitions file.") else { call parse call close (infile(1)) } } for (i=1; getarg(i, buf, FILENAMESIZE) != EOF; i=i+1) { if (buf(1) == QMARK & buf(2) == EOS) call error ("usage: rat4 [file ...] >outfile.") else if (buf(1) == MINUS & buf(2) == EOS) infile(1) = STDIN else { infile(1) = open(buf, READ) if (infile(1) == ERR) call cant(buf) } call parse if (infile(1) != STDIN) call close(infile(1)) } if (i == 1) #no files given on command line, use STDIN { infile(1) = STDIN call parse } return end #-h- eatup 1113 asc 03-jul-80 08:55:30 # ordinary fortran statements - routines in this group are eatup, labelc, otherc # eatup - process rest of statement; interpret continuations subroutine eatup character gettok character ptoken(MAXTOK), t, token(MAXTOK) integer nlpar nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == SEMICOL | t == NEWLINE) break if (t == RBRACE | t == LBRACE) { call pbstr(token) break } if (t == EOF) { call synerr("unexpected EOF.") call pbstr(token) break } if (t == COMMA | t == PLUS | t == MINUS | t == STAR | t == LPAREN | t == AND | t == BAR | t == BANG | t == EQUALS | t == 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 call outstr(token) } until (nlpar < 0) if (nlpar ^= 0) call synerr("unbalanced parentheses.") return end #-h- labelc 413 asc 03-jul-80 08:55:32 # labelc - output statement number subroutine labelc(lexstr) character lexstr(ARB) integer length # include commonblocks 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) call synerr("warning: possible label conflict.") call outstr(lexstr) call outtab return end #-h- otherc 240 asc 03-jul-80 08:55:33 # otherc - output ordinary Fortran statement subroutine otherc(lexstr) character lexstr(ARB) # include commonblocks include cgoto xfer = NO call outtab call outstr(lexstr) call eatup call outdon return end #-h- outch 482 asc 03-jul-80 08:59:04 # output routines # routines in this group are outch, outcon, outdon, outgo, outnum, outstr, # outtab, allblk # outch - put one character into output buffer subroutine outch(c) character c integer i # include commonblocks include coutln if (outp >= 72) { # continuation card call outdon for (i = 1; i < 6; i = i + 1) outbuf(i) = BLANK outbuf(6) = STAR outp = 6 } outp = outp + 1 outbuf(outp) = c return end #-h- outcon 363 asc 03-jul-80 08:59:05 # outcon - output "n continue" subroutine outcon(n) integer n # include commonblocks include cgoto include coutln string contin "continue" xfer = NO if (n <= 0 & outp == 0) return # don't need unlabeled continues if (n > 0) call outnum(n) call outtab call outstr(contin) call outdon return end #-h- outdon 266 asc 03-jul-80 08:59:07 # outdon - finish off an output line subroutine outdon integer allblk # include commonblocks include coutln outbuf(outp+1) = NEWLINE outbuf(outp+2) = EOS if (allblk(outbuf) == NO) call putlin(outbuf, STDOUT) outp = 0 return end #-h- outgo 250 asc 03-jul-80 08:59:08 # outgo - output "goto n" subroutine outgo(n) integer n # include commonblocks include cgoto string goto "goto " if (xfer == YES) return call outtab call outstr(goto) call outnum(n) call outdon return end #-h- outnum 357 asc 03-jul-80 08:59:09 # outnum - output decimal number subroutine outnum(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 #-h- outstr 632 asc 03-jul-80 08:59:12 # outstr - output string; handles quoted literals subroutine outstr(str) character c, str(ARB) integer i, j for (i = 1; str(i) ^= EOS; i = i + 1) { c = str(i) if (c ^= SQUOTE & c ^= DQUOTE) { if (c >= LETA & c <= LETZ) # remove this if you c = c - LETA + BIGA # don't need upper case fortran 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 #-h- outtab 157 asc 03-jul-80 08:59:14 # outtab - get past column 6 subroutine outtab # include commonblocks include coutln while (outp < 6) call outch(BLANK) return end #-h- allblk 434 asc 03-jul-80 08:59:15 # 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 #-h- initkw 1204 asc 7-oct-80 08:03:09 # parsing - routines in this group are initkw, init, parse, unstak, ulstal ## initkw - initialize table and install keywords 'define' and 'DEFINE' subroutine initkw # character deft(2), mact(2), inct(2), subt(2), ift(2), art(2) character deft(2), inct(2), subt(2), ift(2), art(2), ifdft(2), ifndt(2) # include commonblocks include clabel string defnam "define" # string macnam "macro" 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 tbinit #initialize hash table #install keywords 'define' and 'DEFINE' 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) #initialize label label = 23000 return end #-h- init 555 asc 03-jul-80 09:03:09 # init - initialize for each input file subroutine init integer i # include commonblocks include coutln include cline include cdefio include cfor include clook include cfname include clabel include csbuf include cswtch outp = 0 # output character pointer level = 1 # file control linect(1) = 1 sbp = 1 fnamp = 2 fnames(1) = EOS bp = 0 # pushback buffer pointer fordep = 0 # for stack fcname(1) = EOS # current function name swtop = 0 # switch stack swlast = 1 return end #-h- parse 2728 asc 03-jul-80 09:03:11 # parse - parse Ratfor source program subroutine parse character lexstr(MAXTOK) integer lex integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token, i include cgoto include cfor include cfname include cline include csbuf include clabel include clook include cdefio include coutln call init 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 #-h- unstak 828 asc 03-jul-80 09:03:21 # 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 #-h- ulstal 201 asc 03-jul-80 09:03:37 ## install both lower and upper case versions of name subroutine ulstal(name, defn) character name(ARB), defn(ARB) call instal(name, defn) call upper(name) call instal(name, defn) return end #-h- repcod 322 asc 03-jul-80 09:07:43 # repeat statement - routines in this group are repcod, untils # repcod - generate code for beginning of repeat subroutine repcod(lab) integer labgen integer lab call outcon(0) # in case there was a label lab = labgen(3) call outcon(lab) lab = lab + 1 # label to go on next's return end #-h- untils 388 asc 03-jul-80 09:07:46 # untils - generate code for until or end of repeat subroutine untils(lab, token) character ptoken(MAXTOK) integer lex integer junk, lab, token # include commonblocks include cgoto 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 #-h- retcod 550 asc 03-jul-80 09:09:38 # return statement # retcod - generate code for return subroutine retcod character token(MAXTOK), gnbtok, t # include commonblocks include cfname include cgoto string sret "return" t = gnbtok(token, MAXTOK) if (t ^= NEWLINE & t ^= SEMICOL & t ^= RBRACE) { call pbstr(token) call outtab call outstr(fcname) 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 #-h- strdcl 2531 asc 10-sep-80 11:21:35 # string declaration # strdcl - generate code for string declaration subroutine strdcl character t, token(MAXTOK), gnbtok, 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/" t = gnbtok(token, MAXTOK) if (t ^= ALPHA) call synerr("missing string 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 = elenth(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) n = esc(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 #-h- addchr 343 asc 03-jul-80 09:12:35 # miscellaneous routines # routines in this group are addchr, addstr, alldig, labgen, skpblk # 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 #-h- addstr 256 asc 03-jul-80 09:12:37 # 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 #-h- alldig 303 asc 03-jul-80 09:12:38 # alldig - return YES if str is all digits integer function alldig(str) character type character str(ARB) integer i alldig = NO if (str(1) == EOS) return for (i = 1; str(i) ^= EOS; i = i + 1) if (type(str(i)) ^= DIGIT) return alldig = YES return end #-h- labgen 206 asc 03-jul-80 09:12:39 # labgen - generate n consecutive labels, return first one integer function labgen(n) integer n # include commonblocks include clabel labgen = label label = label + n return end #-h- skpblk 219 asc 03-jul-80 09:12:40 # skpblk - skip blanks and tabs in file fd subroutine skpblk(fd) integer fd character c, ngetch for (c = ngetch(c, fd); c == BLANK | c == TAB; c = ngetch(c, fd)) ; call putbak(c) return end #-h- cascod 1911 asc 03-jul-80 09:16:34 # 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 integer t, l, lb, ub, i, j character tok(MAXTOK) integer caslab, labgen, gnbtok include cswtch include cgoto 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 #-h- caslab 609 asc 03-jul-80 09:16:37 # 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 #-h- swcode 733 asc 03-jul-80 09:16:38 # swcode - generate code for beginning of switch statement subroutine swcode(lab) integer lab character tok(MAXTOK) integer labgen, gnbtok include cswtch include cgoto 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 #-h- swend 2623 asc 03-jul-80 09:16:41 # swend - finish off switch statement; generate dispatch code subroutine swend(lab) integer lab integer 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+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 #-h- swvar 153 asc 03-jul-80 09:16:43 # swvar - output switch variable Innn, where nnn = lab subroutine swvar(lab) integer lab call outch(BIGI) call outnum(lab) return end #-h- whilec 313 asc 03-jul-80 09:18:52 # while statement - routines involved are whilec, whiles # whilec - generate code for beginning of while subroutine whilec(lab) integer labgen integer lab call outcon(0) # unlabeled continue, in case there was a label lab = labgen(2) call outnum(lab) call ifgo(lab+1) return end #-h- whiles 143 asc 03-jul-80 09:18:53 # whiles - generate code for end of while subroutine whiles(lab) integer lab call outgo(lab) call outcon(lab+1) return end #-h- litral 646 asc 03-jul-80 09:21:33 ## litral - process literal ratfor lines subroutine litral integer getlin, index integer i include coutln include cline # Finish off any left-over characters if (outp > 0) call outdon i = getlin (outbuf, infile(level)) # throw away end of current line #loop through input until matching toggle found while ( getlin (outbuf, infile(level)) != EOF ) { i = 1 call skipbl (outbuf, i) if (outbuf(i) == TOGGLE) break call putlin (outbuf, STDOUT) linect(level) = linect(level) + 1 } outp = 0 return end #-h- brknxt 1077 asc 03-jul-80 09:21:34 # break and next statements # 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), gnbtok # include commonblocks include cgoto 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 #-h- deftok 2451 asc 03-jul-80 09:21:37 ## deftok - get token; process macro calls and invocations character function deftok(token, toksiz, fd) character token(MAXTOK) # formal parameters integer toksiz, fd # " " character gtok # external function integer lookup, push, ifparm # " " character t, c, defn(MAXDEF), balp(3), mdefn(MAXDEF) # local variables integer ap, argstk(ARGSIZE), callst(CALLSIZE), # " " nlb, plev(CALLSIZE), ifl include cmacro data balp/LPAREN, RPAREN, EOS/ cp = 0 ap = 1 ep = 1 for (t=gtok(token,toksiz,fd); t != EOF; t=gtok(token,toksiz,fd)) { if (t == ALPHA) if (lookup(token, defn) == NO) if (cp == 0) break else call puttok(token) else if (defn(1) == DEFTYPE) # process defines directly { call getdef(token, toksiz, defn, MAXDEF, fd) call instal(token, defn) } else if (defn(1) == IFDEFTYPE | defn(1) == IFNOTDEFTYPE) { c = defn(1) call getdef(token, toksiz, defn, MAXDEF, fd) ifl = lookup(token, mdefn) 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, fd) 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, fd) 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 #-h- doarth 982 asc 03-jul-80 09:27:20 # process macros with arguments # routines involved are doarth, doif, doincr, dosub, evalr, ifparm, # pbnum, push, putchr, puttok ## doarth - do arithmetic operation subroutine doarth(argstk,i,j) integer ctoi integer argstk(ARGSIZE), i, j, k, l character op include cmacro 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 ## domac - install macro definition in table /*/sor/macror/domac # subroutine domac(argstk, i, j) # integer a2, a3, argstk(ARGSIZE), i, j # include cmacro # # if (j - i > 2) { # a2 = argstk(i+2) # a3 = argstk(i+3) # call instal(evalst(a2), evalst(a3)) # subarrays # } # return # end #-h- doif 457 asc 03-jul-80 09:27:21 ## doif - select one of two (macro) arguments /*/sor/macror/doif subroutine doif(argstk, i, j) integer equal integer a2, a3, a4, a5, argstk(ARGSIZE), i, j include cmacro 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 #-h- doincr 252 asc 03-jul-80 09:27:22 ## doincr - increment macro argument by 1 /*/sor/macror/doincr subroutine doincr(argstk, i, j) integer ctoi integer argstk(ARGSIZE), i, j, k include cmacro k = argstk(i+2) call pbnum(ctoi(evalst, k)+1) return end #-h- dosub 711 asc 03-jul-80 09:27:24 ## dosub - select macro substring /*/sor/macror/dosub subroutine dosub(argstk, i, j) integer ctoi, length integer ap, argstk(ARGSIZE), fc, i, j, k, nc include cmacro 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 #-h- evalr 1452 asc 7-oct-80 08:03:14 ## evalr - expand args i through j: evaluate builtin or push back defn subroutine evalr(argstk, i, j) integer index, length integer argno, argstk(ARGSIZE), i, j, k, m, n, 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(i) td = evalst(t) # if (td == MACTYPE) # call domac(argstk, i, j) # else if (td == INCTYPE) 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 #-h- ifparm 665 asc 03-jul-80 09:27:27 # 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), c integer i, index, type c = strng(1) if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | c == IFDEFTYPE) 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 #-h- pbnum 676 asc 08-oct-80 08:09:56 ## pbnum - convert number to string, push back on input /*/sor/macror/pbnum subroutine pbnum(n) integer mod 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 = abs(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 #-h- push 276 asc 03-jul-80 09:27:29 ## 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 baderr('arg stack overflow.') argstk(ap) = ep push = ap + 1 return end #-h- putchr 255 asc 03-jul-80 09:27:30 ## putchr - put single char into eval stack /*/sor/macror/putchr subroutine putchr(c) character c include cmacro if (ep > EVALSIZE) call baderr('evaluation stack overflow.') evalst(ep) = c ep = ep + 1 return end #-h- puttok 216 asc 03-jul-80 09:27:31 ## puttok-put token 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 #-h- elenth 262 asc 10-sep-80 11:21:45 # 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