%%s 10/10/3481 %%d D 1.2 01-Nov-82 18:58:19 sventek 2 1 %%c Made appropriate modifications to convert all occurrences of the string %%c ''' to the string '@''. The previous form is now a syntax error, due to %%c the extension to ratfor to permit "'" to be used as a quoted string %%c delimiter %%s 0/0/0 %%d D 1.1 07-Apr-82 08:01:51 v1.1 1 0 %%c Version 1.1 is the Spring 1982 Distribution of the LBL/Hughes release %%c of the Software Tools Virtual Operating System software and documentation. %%T %%I 1 #-h- common 2477 asc 28-jan-82 08:34:19 j # 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 ifdef (DO_SELECT) common /cselct/ setop, selast, sestak (MAXSELECT) integer setop # current select entry; init = 0 integer selast # next available position; init = 1 integer sestak # select information enddef common /ckword/ rkwtbl pointer rkwtbl # symbol table containing Ratfor key words ifdef (DO_LONGNAME) 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 enddef common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH) integer csp # last used location in cond stack; init = 0 integer curcnd # current conditional state; (+/-)C_TRUE; init C_TRUE integer cndstk # stack of saved condition values DS_DECL(mem, MEMSIZE) %%D 2 #-h- oldratfor.r 70330 asc 07-apr-82 07:59:31 v1.1 (sw-tools v1.1) %%E 2 %%I 2 #-h- oldratfor.r 70351 asc 01-nov-82 18:06:08 sventek (joseph sventek) %%E 2 #-h- defns 4281 asc 07-apr-82 07:47:44 v1.1 (sw-tools v1.1) # 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,) # #--------------------------------------------------------------- # If you want the preprocessor to perform the long name conversion, # set the following definition # # define (DO_LONGNAME,) # #--------------------------------------------------------------- # If you want the preprocessor to process the select statement, # set the following definition # # define (DO_SELECT,) # #--------------------------------------------------------------- # If you want to generate the fortran bootstrap, # set the following definition # # define (DO_BOOTSTRAP,) # # In addition, it will be necessary to append the fortran of several # of the library routines to the generated fortran file. #--------------------------------------------------------------- # 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) # MAXSELECT (max stack for select statement) # #----------------------------------------------------------------- define (STDEFNS,"oldsyms") # name of file containing standard defns define (UPPERC,) # define if Fortran compiler wants upper case #define (DO_SELECT,) # define if ``select'' statement is desired define (RADIX,'%') # % indicates alternate radix define (TOGGLE,'%') # toggle for literal lines mdefine (ARGFLAG,'$') define (CUTOFF,3) # min nbr of cases to generate branch table # (for select statement) define (DENSITY,2) # reciprocal of density necessary for # branch table define (FILLCHAR,'0') # 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 (LEXSELECT,-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) define (ELSEDEFTYPE,-17) define (ENDDEFTYPE,-18) define (NOTDEFTYPE,-19) # Size-limiting definitions: define (MEMSIZE,5000) # space allotted to symbol tables and macro text define (BUFSIZE,arith(2,*,MAXDEF)) # pushback buffer size define (SBUFSIZE,600) # buffer for string statements define (MAXDEF,250) # max chars in a defn define (MAXFORSTK,300) # max space for for reinit clauses define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) define (MAXSTACK,100) # max stack depth for parser define (MAXSELECT,500) # max stack for select statement define (MAXTOK,120) # max chars in a token define (NFILES,arith(MAXOFILES,-,3)) # maximum number of include file nests define (MAXNBRSTR,20) #max nbr string declarations per module define (CALLSIZE,50) define (ARGSIZE,100) define (EVALSIZE,500) define (COND_STACK_DEPTH,10) # size of conditional stack define (C_TRUE,1) # conditional value is true # Where to find the common blocks: define(COMMON_BLOCKS,"common") #-h- main 924 asc 07-apr-82 07:15:04 v1.1 (sw-tools v1.1) DRIVER(ratfor) include COMMON_BLOCKS integer i, n integer getarg, open character arg (FILENAMESIZE) ifnotdef (DO_BOOTSTRAP) call query ("usage: ratfor [files] >outfile.") enddef call initkw # initialize variables ifnotdef (DO_BOOTSTRAP) call lodsym(arg) # Read standard definitions file n = 1 for (i = 1; getarg (i, arg, FILENAMESIZE) != EOF; i = i + 1) { n = n + 1 if (arg (1) == '-' & 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 enddef infile (1) = STDIN call parse ifnotdef (DO_BOOTSTRAP) } enddef ifdef (DO_LONGNAME) call lndict enddef DRETURN end #-h- addchr 248 asc 07-apr-82 07:15:05 v1.1 (sw-tools v1.1) # 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 07-apr-82 07:15:07 v1.1 (sw-tools v1.1) # 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 306 asc 07-apr-82 07:15:09 v1.1 (sw-tools v1.1) # 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 #-h- baderr 149 asc 07-apr-82 07:15:10 v1.1 (sw-tools v1.1) # baderr --- report fatal error message, then die subroutine baderr (msg) character msg (ARB) call synerr (msg) call endst(ERR) end #-h- balpar 869 asc 07-apr-82 07:15:12 v1.1 (sw-tools v1.1) # balpar - copy balanced paren string subroutine balpar character t, token (MAXTOK) character gettok, gnbtok integer nlpar if (gnbtok (token, MAXTOK) != '(') { call synerr ("missing left paren.") return } call outstr (token) nlpar = 1 repeat { t = gettok (token, MAXTOK) if (t == ';' | t == '{' | t == '}' | t == EOF) { call pbstr (token) break } if (t == '@n') # delete newlines token (1) = EOS else if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 ifdef (DO_LONGNAME) if (t == ALPHA) call squash (token) enddef # else nothing special call outstr (token) } until (nlpar <= 0) if (nlpar != 0) call synerr ("missing parenthesis in condition.") return end #-h- brknxt 1073 asc 07-apr-82 07:15:14 v1.1 (sw-tools v1.1) # 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 != ';') # 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- cascod 1897 asc 07-apr-82 07:15:16 v1.1 (sw-tools v1.1) # cascod - generate code for case or default label ifdef (DO_SELECT) 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 (setop <= 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 == '-') junk = caslab (ub, t) if (lb > ub) { call synerr ("illegal range in case label.") ub = lb } if (selast + 3 > MAXSELECT) call baderr ("select table overflow.") for (i = setop + 3; i < selast; i = i + 3) if (lb <= sestak (i)) break else if (lb <= sestak (i+1)) call synerr ("duplicate case label.") if (i < selast & ub >= sestak (i)) call synerr ("duplicate case label.") for (j = selast; j > i; j = j - 1) # insert new entry sestak (j+2) = sestak (j-1) sestak (i) = lb sestak (i + 1) = ub sestak (i + 2) = l sestak (setop + 1) = sestak (setop + 1) + 1 selast = selast + 3 if (t == ':') break else if (t != ',') call synerr ("illegal case syntax.") } } else { # default : ... t = gnbtok (tok, MAXTOK) if (sestak (setop + 2) != 0) call error ("multiple defaults in select statement.") else sestak (setop + 2) = l } if (t == EOF) call synerr ("unexpected EOF.") else if (t != ':') call error ("missing colon in case or default label.") xfer = NO call outcon (l) return end enddef #-h- caslab 642 asc 07-apr-82 07:15:19 v1.1 (sw-tools v1.1) # caslab - get one case label ifdef (DO_SELECT) integer function caslab (n, t) integer n, t character tok (MAXTOK) integer i, s integer gnbtok, ctoi t = gnbtok (tok, MAXTOK) while (t == '@n') t = gnbtok (tok, MAXTOK) if (t == EOF) return (t) if (t == '-') s = -1 else s = +1 if (t == '-' | t == '+') 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 == '@n') t = gnbtok (tok, MAXTOK) return end enddef #-h- cndget 782 asc 07-apr-82 07:15:20 v1.1 (sw-tools v1.1) # cndget - get conditional token and look it up in table integer function cndget(token, toksiz) character token(MAXTOK) integer toksiz include COMMON_BLOCKS pointer value character ptok(3) integer lookup character gtok if (csp >= COND_STACK_DEPTH) call baderr("Conditionals nested too deeply.") csp = csp + 1 cndstk (csp) = curcnd call skpblk if (gtok(token, toksiz) != '(') call baderr("missing '(' in conditional.") call skpblk if (gtok(token, toksiz) != ALPHA) call baderr("invalid conditional token.") call skpblk if (gtok(ptok, 3) != ')') call baderr("missing ')' in conditional.") if (lookup(token, value, deftbl) == YES) cndget = C_TRUE else cndget = -C_TRUE return end #-h- cndlu 925 asc 07-apr-82 07:15:22 v1.1 (sw-tools v1.1) # cndlu - look up token in list of conditionals character function cndlu (token) character token(MAXTOK) integer index, equal integer i, j character temp (9) string letts "eEiI" string cndtbl "ifdef/ ifnotdef/ elsedef/ enddef/ " data cndtbl(7)/IFDEFTYPE/,cndtbl(17)/IFNOTDEFTYPE/,cndtbl(26)/ELSEDEFTYPE/, cndtbl(34)/ENDDEFTYPE/ cndlu = NOTDEFTYPE if (index (letts, token (1)) > 0) { for (i=1; cndtbl(i) != EOS; i=i+1) { for (j=1; cndtbl(i) != '/'; [i=i+1; j=j+1]) temp(j) = cndtbl(i) temp(j) = EOS i = i + 1 # bump past / j = equal(token, temp) if (j == NO) { call upper(temp) j = equal(token, temp) } if (j == YES) { cndlu = cndtbl(i) break } } } return end #-h- deftok 3767 asc 07-apr-82 07:15:26 v1.1 (sw-tools v1.1) # 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 gctok integer ap, argstk (ARGSIZE), callst (CALLSIZE), nlb, plev (CALLSIZE), ifl integer ludef, push, ifparm string balp "()" cp = 0 ap = 1 ep = 1 for (t = gctok (token, toksiz); t != EOF; t = gctok (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 { 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 = gctok (token, toksiz) if (t == ' ') { # allow blanks before arguments t = gctok (token, toksiz) call pbstr (token) if (t != '(') call putbak (' ') } else call pbstr (token) if (t != '(') call pbstr (balp) else if (ifparm (defn) == NO) call pbstr (balp) plev (cp) = 0 } else if (t == LSTRIPC) { nlb = 1 repeat { t = gctok (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 == '(') { if (plev (cp) > 0) call puttok (token) plev (cp) = plev (cp) + 1 } else if (t == ')') { 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 == ',' & 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 630 asc 07-apr-82 07:15:28 v1.1 (sw-tools v1.1) # 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 == '+') call pbnum (ctoi (evalst, k) + ctoi (evalst, l)) else if (op == '-') call pbnum (ctoi (evalst, k) - ctoi (evalst, l)) else if (op == '*' ) call pbnum (ctoi (evalst, k) * ctoi (evalst, l)) else if (op == '/' ) call pbnum (ctoi (evalst, k) / ctoi (evalst, l)) else call remark ("arith error") return end #-h- docode 518 asc 07-apr-82 07:15:30 v1.1 (sw-tools v1.1) # 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 (' ') lab = labgen (2) if (gnbtok (lexstr, MAXTOK) == DIGIT) # check for fortran DO call outstr (lexstr) else { call pbstr (lexstr) call outnum (lab) } call outch (' ') call eatup call outdon return end #-h- doif 458 asc 07-apr-82 07:15:32 v1.1 (sw-tools v1.1) # 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 #-h- doincr 246 asc 07-apr-82 07:15:33 v1.1 (sw-tools v1.1) # 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 #-h- domac 326 asc 07-apr-82 07:15:35 v1.1 (sw-tools v1.1) # 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 #-h- dostat 156 asc 07-apr-82 07:15:36 v1.1 (sw-tools v1.1) # dostat - generate code for end of do statement subroutine dostat (lab) integer lab call outcon (lab) call outcon (lab + 1) return end #-h- dosub 709 asc 07-apr-82 07:15:38 v1.1 (sw-tools v1.1) # 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 #-h- dother 456 asc 07-apr-82 07:15:40 v1.1 (sw-tools v1.1) # process one other string in for clause character function dother(token) character token(MAXTOK), t character gettok call outtab repeat { t = gettok(token, MAXTOK) if (t == ';' | t == '}') break if (t == EOF) { call synerr("unexpected EOF.") call pbstr(token) break } ifdef (DO_LONGNAME) if (t == ALPHA) call squash(token) enddef if (t != '@n' & t != '_') call outstr(token) } call outdon return(t) end #-h- eatup 1123 asc 07-apr-82 07:15:42 v1.1 (sw-tools v1.1) # 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 == ';' | t == '@n') break if (t == '}' | t == '{') { call pbstr (token) break } if (t == EOF) { call synerr ("unexpected EOF.") call pbstr (token) break } if (t == ',' | t == '+' | t == '-' | t == '*' | t == '(' | t == AND | t == '|' | t == '!' | t == '~' | t == NOT | t == '^' | t == '=' | t == '_') { while (gettok (ptoken, MAXTOK) == '@n') ; call pbstr (ptoken) if (t == '_') token (1) = EOS } if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 ifdef (DO_LONGNAME) if (t == ALPHA) call squash (token) enddef call outstr (token) } until (nlpar < 0) if (nlpar != 0) call synerr ("unbalanced parentheses.") return end #-h- elenth 290 asc 07-apr-82 07:15:44 v1.1 (sw-tools v1.1) # 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 #-h- elseif 155 asc 07-apr-82 07:15:45 v1.1 (sw-tools v1.1) # elseif - generate code for end of if before else subroutine elseif (lab) integer lab call outgo (lab+1) call outcon (lab) return end #-h- entdkw 737 asc 07-apr-82 07:15:47 v1.1 (sw-tools v1.1) # entdkw --- install macro processor keywords subroutine entdkw character deft (2), inct (2), subt (2), ift (2), art (2), mact (2) string defnam "define" string macnam "mdefine" string incnam "incr" string subnam "substr" string ifnam "ifelse" string arnam "arith" 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/ call ulstal (defnam, deft) call ulstal (macnam, mact) call ulstal (incnam, inct) call ulstal (subnam, subt) call ulstal (ifnam, ift) call ulstal (arnam, art) return end #-h- entfkw 1070 asc 07-apr-82 07:15:49 v1.1 (sw-tools v1.1) # entfkw - place Fortran keywords in symbol table ifdef (DO_LONGNAME) subroutine entfkw include COMMON_BLOCKS integer junk integer enter # 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" junk = enter (sconti, 0, fkwtbl) junk = enter (scompl, 0, fkwtbl) junk = enter (slogic, 0, fkwtbl) junk = enter (simpli, 0, fkwtbl) junk = enter (sparam, 0, fkwtbl) junk = enter (sexter, 0, fkwtbl) junk = enter (sdimen, 0, fkwtbl) junk = enter (sinteg, 0, fkwtbl) junk = enter (sequiv, 0, fkwtbl) junk = enter (sfunct, 0, fkwtbl) junk = enter (ssubro, 0, fkwtbl) junk = enter (spreci, 0, fkwtbl) return end enddef #-h- entrkw 1123 asc 07-apr-82 07:15:51 v1.1 (sw-tools v1.1) # entrkw --- install Ratfor keywords in symbol table subroutine entrkw include COMMON_BLOCKS integer junk integer enter 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" ifdef (DO_SELECT) string sselct "select" string scase "case" string sdeflt "default" enddef junk = enter (sif, LEXIF, rkwtbl) junk = enter (selse, LEXELSE, rkwtbl) junk = enter (swhile, LEXWHILE, rkwtbl) junk = enter (sdo, LEXDO, rkwtbl) junk = enter (sbreak, LEXBREAK, rkwtbl) junk = enter (snext, LEXNEXT, rkwtbl) junk = enter (sfor, LEXFOR, rkwtbl) junk = enter (srept, LEXREPEAT, rkwtbl) junk = enter (suntil, LEXUNTIL, rkwtbl) junk = enter (sret, LEXRETURN, rkwtbl) junk = enter (sstr, LEXSTRING, rkwtbl) ifdef (DO_SELECT) junk = enter (sselct, LEXSELECT, rkwtbl) junk = enter (scase, LEXCASE, rkwtbl) junk = enter (sdeflt, LEXDEFAULT, rkwtbl) enddef return end #-h- evalr 1126 asc 07-apr-82 07:15:53 v1.1 (sw-tools v1.1) # 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 #-h- fclaus 518 asc 07-apr-82 07:15:55 v1.1 (sw-tools v1.1) # process for init or re-init clause subroutine fclaus character gnbtok, dother character token(MAXTOK), t integer brace if (gnbtok(token, MAXTOK) == '{') # { mother } brace = YES else { call pbstr(token) # other brace = NO } t = dother(token) if (brace == YES) { while (t != '}' & t != EOF) { t = gnbtok(token, MAXTOK) # get rid of leading blanks call pbstr(token) t = dother(token) } if (gnbtok(token, MAXTOK) != ';') call synerr("invalid for clause.") } return end #-h- finit 452 asc 07-apr-82 07:15:57 v1.1 (sw-tools v1.1) # finit - initialize for each input file subroutine finit include COMMON_BLOCKS outp = 0 # output character pointer level = 1 # file control linect (1) = 1 sbp = 1 fnamp = 2 fnames (1) = EOS bp = 0 # nothing in push back buffer fordep = 0 # for stack fcname (1) = EOS # current function name ifdef (DO_SELECT) setop = 0 # select stack selast = 1 enddef csp = 0 curcnd = C_TRUE return end #-h- forcod 2606 asc 07-apr-82 07:16:00 v1.1 (sw-tools v1.1) # forcod - beginning of for statement subroutine forcod (lab) integer lab include COMMON_BLOCKS character t, token (MAXTOK) character gettok, gnbtok integer i, j, nlpar, len integer length, labgen string ifnot "if (.not." string semi ";" lab = labgen (3) call outcon (0) if (gnbtok (token, MAXTOK) != '(') { call synerr ("missing left paren.") return } if (gnbtok (token, MAXTOK) != ';') { # real init clause call pbstr (token) call fclaus # output init clause } if (gnbtok (token, MAXTOK) == ';') # empty condition call outcon (lab) else { # non-empty condition call pbstr (token) call outnum (lab) call outtab call outstr (ifnot) call outch ('(') nlpar = 0 while (nlpar >= 0) { t = gettok (token, MAXTOK) if (t == ';') break if (t == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == EOF) { call pbstr (token) return } ifdef (DO_LONGNAME) if (t == ALPHA) call squash (token) enddef if (t != '@n' & t != '_') call outstr (token) } call outch (')') call outch (')') call outgo (lab+2) if (nlpar < 0) call synerr ("invalid for clause.") } fordep = fordep + 1 # stack reinit clause len = 0 # total length of re-init 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 == '(') nlpar = nlpar + 1 else if (t == ')') nlpar = nlpar - 1 if (t == EOF) { call pbstr (token) break } if (nlpar >= 0 & t != '@n' & t != '_') { ifdef (DO_LONGNAME) if (t == ALPHA) call squash (token) enddef if (j + length (token) >= MAXFORSTK) call baderr ("for clause too long.") call scopy (token, 1, forstk, j) j = j + length (token) len = len + length (token) } else if (nlpar == -1 & len > 0) # tag clause with semicolon { if (j < MAXFORSTK) call scopy(semi, 1, forstk, j) else call baderr("for clause too long.") } } lab = lab + 1 # label for next's return end #-h- fors 485 asc 07-apr-82 07:16:02 v1.1 (sw-tools v1.1) # 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 pbstr (forstk (j)) # push back re-init clause call fclaus # output clause } call outgo (lab - 1) call outcon (lab + 1) fordep = fordep - 1 return end #-h- gctok 938 asc 07-apr-82 07:16:04 v1.1 (sw-tools v1.1) # gctok - get next token subject to conditionals character function gctok(token, toksiz) character token(MAXTOK) integer toksiz include COMMON_BLOCKS character gtok, cndlu character c integer cndget integer newcnd for (gctok=gtok(token,toksiz); gctok != EOF; gctok=gtok(token,toksiz)) { c = cndlu (token) if (c == NOTDEFTYPE) { if (curcnd == C_TRUE) break } else if (c == ENDDEFTYPE) { if (csp <= 0) call baderr("Illegal enddef encountered.") curcnd = cndstk(csp) csp = csp - 1 } else { if (c == IFDEFTYPE) newcnd = cndget (token, toksiz) else if (c == IFNOTDEFTYPE) newcnd = - cndget (token, toksiz) else newcnd = - curcnd curcnd = min (newcnd, cndstk (csp) ) } } return end #-h- getdef 1610 asc 07-apr-82 07:16:06 v1.1 (sw-tools v1.1) # 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 gctok, ngetch integer i, nlpar call skpblk c = gctok (ptoken, MAXTOK) if (c == '(') t = '(' # define (name, defn) else { t = ' ' # define name defn call pbstr (ptoken) } call skpblk if (gctok (token, toksiz) != ALPHA) call baderr ("non-alphanumeric name.") call skpblk c = gctok (ptoken, MAXTOK) if (t == ' ') { # 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 == '#' | c == '@n' | c == EOF) if (c == '#') call putbak (c) } else if (t == '(') { # define (name, defn) if (c != ',') 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) == '(') nlpar = nlpar + 1 else if (defn (i) == ')') nlpar = nlpar - 1 # else normal character in defn (i) } else call baderr ("getdef is confused.") defn (i - 1) = EOS return end %%D 2 #-h- gettok 2246 asc 07-apr-82 07:16:09 v1.1 (sw-tools v1.1) %%E 2 %%I 2 #-h- gettok 2247 asc 01-nov-82 18:04:46 sventek (joseph sventek) %%E 2 # 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" ifnotdef (DO_BOOTSTRAP) for ( ; level > 0; level = level - 1) { enddef 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 (' ') return } else if (equal (token, incl) == NO) return # process 'include' statements: call skpblk t = deftok (name, MAXNAME) %%D 2 if (t == ''' | t == '"') { %%E 2 %%I 2 if (t == '@'' | t == '"') { %%E 2 len = length (name) - 1 for (i = 1; i < len; i = i + 1) name (i) = name (i + 1) name (i) = EOS } i = length (name) + 1 ifnotdef (DO_BOOTSTRAP) 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) enddef call synerr ("can't open include.") ifnotdef (DO_BOOTSTRAP) else { level = level + 1 if (fnamp + i <= MAXFNAMES) { call scopy (name, 1, fnames, fnamp) fnamp = fnamp + i # push file name stack } } } enddef } ifnotdef (DO_BOOTSTRAP) 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 } } enddef token (1) = EOF # in case called more than once token (2) = EOS gettok = EOF return end #-h- gnbtok 294 asc 07-apr-82 07:16:11 v1.1 (sw-tools v1.1) # gnbtok - get nonblank token character function gnbtok (token, toksiz) character token (MAXTOK) integer toksiz include COMMON_BLOCKS character gettok repeat { call skpblk gnbtok = gettok (token, toksiz) } until (gnbtok != ' ') return end %%D 2 #-h- gtok 3179 asc 07-apr-82 07:16:14 v1.1 (sw-tools v1.1) %%E 2 %%I 2 #-h- gtok 3180 asc 01-nov-82 18:04:48 sventek (joseph sventek) %%E 2 # 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 == ' ' | c == '@t') { lexstr (1) = ' ' while (c == ' ' | c == '@t') # compress many blanks to one c = ngetch (c) if (c == '#') while (ngetch (c) != '@n') # strip comments ; if (c != '@n') call putbak (c) else lexstr (1) = '@n' 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 != '_') break } call putbak (c) gtok = ALPHA } else if (IS_DIGIT(c)) { # digits b = c - '0' # 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 - '0' } 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 == '[') { # allow [ for { lexstr (1) = '{' gtok = '{' } else if (c == ']') { # allow ] for } lexstr (1) = '}' gtok = '}' } else if (c == '$') { # $( and $) now used by macro processor if (ngetch (lexstr (2)) == '(') { i = 2 gtok = LSTRIPC } else if (lexstr (2) == ')') { i = 2 gtok = RSTRIPC } else { call putbak (lexstr (2)) gtok = '$' } } %%D 2 else if (c == ''' | c == '"') { %%E 2 %%I 2 else if (c == '@'' | c == '"') { %%E 2 gtok = c for (i = 2; ngetch (lexstr (i)) != lexstr (1); i = i + 1) { if (lexstr (i) == '_') if (ngetch (c) == '@n') { while (c == '@n' | c == ' ' | c == '@t') c = ngetch (c) lexstr (i) = c } else call putbak (c) if (lexstr (i) == '@n' | i >= toksiz - 1) { call synerr ("missing quote.") lexstr (i) = lexstr (1) call putbak ('@n') break } } } else if (c == '#') { # strip comments while (ngetch (lexstr (1)) != '@n') ; gtok = '@n' } else if (c == '>' | c == '<' | c == NOT | c == '!' | c == '~' | c == '^' | c == '=' | 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 #-h- ifcode 198 asc 07-apr-82 07:16:16 v1.1 (sw-tools v1.1) # 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 #-h- ifgo 344 asc 07-apr-82 07:16:18 v1.1 (sw-tools v1.1) # 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 (')') # " ) " call outgo (lab) # " goto lab " return end #-h- ifparm 689 asc 07-apr-82 07:16:19 v1.1 (sw-tools v1.1) # 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 #-h- initkw 725 asc 07-apr-82 07:16:21 v1.1 (sw-tools v1.1) # initkw - initialize tables and important global variables # this routine assumes that there is no error return from mktabl # entfkw and entrkw assume successful entry of elements in those tables, also 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 ifdef (DO_LONGNAME) 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 enddef label = 23000 return end #-h- labelc 402 asc 07-apr-82 07:16:23 v1.1 (sw-tools v1.1) # 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) == '2' & lexstr (2) == '3') call synerr ("warning: possible label conflict.") call outstr (lexstr) call outtab return end #-h- labgen 189 asc 07-apr-82 07:16:24 v1.1 (sw-tools v1.1) # labgen - generate n consecutive labels, return first one integer function labgen (n) integer n include COMMON_BLOCKS labgen = label label = label + n return end #-h- lex 530 asc 07-apr-82 07:16:26 v1.1 (sw-tools v1.1) # 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 == '@n'; lex = gnbtok (lexstr, MAXTOK)) ; if (lex == EOF | lex == ';' | lex == '{' | lex == '}') return if (lex == DIGIT) lex = LEXDIGITS else if (lex == TOGGLE) lex = LEXLITERAL else if (lookup (lexstr, lex, rkwtbl) == YES) ; else lex = LEXOTHER return end #-h- litral 313 asc 07-apr-82 07:16:28 v1.1 (sw-tools v1.1) # 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)) != '@n'; outp = outp + 1) ; outp = outp - 1 call outdon return end #-h- lndict 725 asc 07-apr-82 07:16:30 v1.1 (sw-tools v1.1) # lndict - output long-name dictionary as a debugging aid ifdef (DO_LONGNAME) subroutine lndict include COMMON_BLOCKS character sym (MAXTOK) character cupper integer i integer sctabl pointer posn, locn posn = 0 while (sctabl (namtbl, sym, locn, posn) != EOF) { ifdef (UPPERC) call outch('C') elsedef call outch('c') enddef call outtab for (i = cvt_to_cptr(locn); cmem (i) != EOS; i = i + 1) { ifdef (UPPERC) call outch(cupper(cmem(i))) elsedef call outch(cmem(i)) enddef } call outch (' ') call outch (' ') call outstr (sym) call outdon } return end enddef #-h- lodsym 745 asc 07-apr-82 07:16:31 v1.1 (sw-tools v1.1) # lodsym - load standard definitions file ifnotdef (DO_BOOTSTRAP) subroutine lodsym(fbuf) include COMMON_BLOCKS integer open, loccom character fbuf(FILENAMESIZE), path(arith(FILENAMESIZE,*,3)) string defns STDEFNS # name of standard definitions file string suffix NO_SUFFIX if (defns(1) != EOS) { call impath(path) # get standard search path :~home:~usr:~bin if (loccom(defns, path, suffix, fbuf) == ASCII) { infile(1) = open(fbuf, READ) if (infile(1) == ERR) call remark("cannot open standard definitions file.") else { call parse call close(infile(1)) } } else call remark("cannot locate standard definitions file.") } return end enddef #-h- ngetch 361 asc 07-apr-82 07:16:33 v1.1 (sw-tools v1.1) # ngetch - get a (possibly pushed back) character character function ngetch (c) character c include COMMON_BLOCKS character getch if (bp > 0) { c = buf(bp) bp = bp - 1 } else { c = getch(c, infile (level) ) if (c == '@n') linect (level) = linect (level) + 1 } return (c) end #-h- otherc 317 asc 07-apr-82 07:16:35 v1.1 (sw-tools v1.1) # otherc - output ordinary Fortran statement subroutine otherc (lexstr) character lexstr (ARB) include COMMON_BLOCKS xfer = NO call outtab ifdef (DO_LONGNAME) if (IS_LETTER(lexstr (1))) call squash (lexstr) enddef call outstr (lexstr) call eatup call outdon return end #-h- outch 354 asc 07-apr-82 07:16:36 v1.1 (sw-tools v1.1) # 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) = ' ' outbuf (6) = '*' outp = 6 } outp = outp + 1 outbuf (outp) = c return end #-h- outcon 332 asc 07-apr-82 07:16:38 v1.1 (sw-tools v1.1) # 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 #-h- outdon 202 asc 07-apr-82 07:16:39 v1.1 (sw-tools v1.1) # outdon - finish off an output line subroutine outdon include COMMON_BLOCKS outbuf (outp + 1) = '@n' outbuf (outp + 2) = EOS call putlin (outbuf, STDOUT) outp = 0 return end #-h- outgo 239 asc 07-apr-82 07:16:41 v1.1 (sw-tools v1.1) # 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 #-h- outnum 378 asc 07-apr-82 07:16:42 v1.1 (sw-tools v1.1) # 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) + '0' m = m / 10 } until (m == 0 | i >= MAXCHARS) if (n < 0) call outch ('-') for ( ; i > 0; i = i - 1) call outch (chars (i)) return end %%D 2 #-h- outstr 702 asc 07-apr-82 07:16:44 v1.1 (sw-tools v1.1) %%E 2 %%I 2 #-h- outstr 703 asc 01-nov-82 18:04:52 sventek (joseph sventek) %%E 2 # 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) %%D 2 if (c != ''' & c != '"') { %%E 2 %%I 2 if (c != '@'' & c != '"') { %%E 2 # produce upper case fortran, if desired ifdef (UPPERC) call outch (cupper (c)) elsedef call outch(c) enddef } else { i = i + 1 for (j = i; str (j) != c; j = j + 1) # find end ; call outnum (j - i) call outch ('H') for ( ; i < j; i = i + 1) call outch (str (i)) } } return end #-h- outtab 138 asc 07-apr-82 07:16:46 v1.1 (sw-tools v1.1) # outtab - get past column 6 subroutine outtab include COMMON_BLOCKS while (outp < 6) call outch (' ') return end #-h- parse 2835 asc 07-apr-82 07:16:49 v1.1 (sw-tools v1.1) # 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) ifdef (DO_SELECT) else if (token == LEXSELECT) call selcod (lab) else if (token == LEXCASE | token == LEXDEFAULT) { for (i = sp; i > 0; i = i - 1) # find for most recent select if (lextyp (i) == LEXSELECT) break if (i == 0) call synerr ("illegal case or default.") else call cascod (labval (i), token) } enddef 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 ifdef (DO_SELECT) | token == LEXSELECT enddef | token == LEXDO | token == LEXDIGITS | token == '{') { 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 == '}') { if (lextyp (sp) == '{') sp = sp - 1 ifdef (DO_SELECT) else if (lextyp (sp) == LEXSELECT) { call selend (labval (sp)) sp = sp - 1 } enddef 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.") if (csp > 0) call synerr("conditional processing still active at EOF.") return end #-h- pbnum 351 asc 07-apr-82 07:16:51 v1.1 (sw-tools v1.1) # pbnum - convert number to string, push back on input subroutine pbnum (n) integer n integer m, num integer mod, abs string digits "0123456789" num = abs(n) repeat { m = mod (num, 10) call putbak (digits (m + 1)) num = num / 10 } until (num == 0) if (n < 0) call putbak('-') return end #-h- pbstr 207 asc 07-apr-82 07:16:52 v1.1 (sw-tools v1.1) # 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 #-h- push 249 asc 07-apr-82 07:16:54 v1.1 (sw-tools v1.1) # 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 #-h- putbak 260 asc 07-apr-82 07:16:55 v1.1 (sw-tools v1.1) # putbak - push character back onto input subroutine putbak (c) character c include COMMON_BLOCKS if (bp >= BUFSIZE) call baderr ("too many characters pushed back.") else { bp = bp + 1 buf (bp) = c } return end #-h- putchr 233 asc 07-apr-82 07:16:57 v1.1 (sw-tools v1.1) # 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 #-h- puttok 198 asc 07-apr-82 07:16:59 v1.1 (sw-tools v1.1) # 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 #-h- relate 1228 asc 07-apr-82 07:17:00 v1.1 (sw-tools v1.1) # relate - convert relational shorthands into long form subroutine relate (token, last) character token (ARB) integer last character ngetch integer length if (ngetch (token (2)) != '=') { call putbak (token (2)) token (3) = 't' } else token (3) = 'e' token (4) = '.' token (5) = EOS token (6) = EOS # for .not. and .and. if (token (1) == '>') token (2) = 'g' else if (token (1) == '<') token (2) = 'l' else if (token (1) == NOT | token (1) == '!' | token (1) == '^' | token (1) == '~') { if (token (2) != '=') { token (3) = 'o' token (4) = 't' token (5) = '.' } token (2) = 'n' } else if (token (1) == '=') { if (token (2) != '=') { token (2) = EOS last = 1 return } token (2) = 'e' token (3) = 'q' } else if (token (1) == AND) { token (2) = 'a' token (3) = 'n' token (4) = 'd' token (5) = '.' } else if (token (1) == OR) { token (2) = 'o' token (3) = 'r' } else # can't happen token (2) = EOS token (1) = '.' last = length (token) return end #-h- repcod 262 asc 07-apr-82 07:17:02 v1.1 (sw-tools v1.1) # 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 #-h- retcod 603 asc 07-apr-82 07:17:04 v1.1 (sw-tools v1.1) # 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 != '@n' & t != ';' & t != '}') { call pbstr (token) call outtab call scopy (fcname, 1, token, 1) ifdef (DO_LONGNAME) call squash (token) enddef call outstr (token) call outch ('=') call eatup call outdon } else if (t == '}') call pbstr (token) call outtab call outstr (sret) call outdon xfer = YES return end #-h- selcod 767 asc 07-apr-82 07:17:06 v1.1 (sw-tools v1.1) # selcod - generate code for beginning of select statement ifdef (DO_SELECT) subroutine selcod (lab) integer lab include COMMON_BLOCKS character tok (MAXTOK) integer labgen, gnbtok lab = labgen (2) if (selast + 3 > MAXSELECT) call baderr ("select table overflow.") sestak (selast) = setop sestak (selast + 1) = 0 sestak (selast + 2) = 0 setop = selast selast = selast + 3 xfer = NO call outtab # Innn=(e) call selvar (lab) call outch ('=') call balpar call outdon call outgo (lab) # goto L xfer = YES while (gnbtok (tok, MAXTOK) == '@n') ; if (tok (1) != '{') { call synerr ("missing left brace in select statement.") call pbstr (tok) } return end enddef #-h- selend 2733 asc 07-apr-82 07:17:09 v1.1 (sw-tools v1.1) # selend - finish off select statement; generate dispatch code ifdef (DO_SELECT) subroutine selend (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 = sestak (setop + 3) ub = sestak (selast - 2) n = sestak (setop + 1) call outgo (lab + 1) # terminate last case if (sestak (setop + 2) == 0) sestak (setop + 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 selvar (lab) call outch ('=') call selvar (lab) if (lb < 1) call outch ('+') call outnum (-lb + 1) call outdon } call outtab # if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default call outstr (sif) call selvar (lab) call outstr (slt) call selvar (lab) call outstr (sgt) call outnum (ub - lb + 1) call outch (')') call outgo (sestak (setop + 2)) call outtab # goto (....),Innn call outstr (sgoto) j = lb for (i = setop + 3; i < selast; i = i + 3) { for ( ; j < sestak (i); j = j + 1) { # fill in vacancies call outnum (sestak (setop + 2)) call outch (',') } for (j = sestak (i + 1) - sestak (i); j >= 0; j = j - 1) call outnum (sestak (i + 2)) # fill in range j = sestak (i + 1) + 1 if (i < selast - 3) call outch (',') } call outch (')') call outch (',') call selvar (lab) call outdon } else if (n > 0) { # output linear search form for (i = setop + 3; i < selast; i = i + 3) { call outtab # if (Innn call outstr (sif) call selvar (lab) if (sestak (i) == sestak (i+1)) { call outstr (seq) # .eq.... call outnum (sestak (i)) } else { call outstr (sge) # .ge.lb.and.Innn.le.ub call outnum (sestak (i)) call outstr (sand) call selvar (lab) call outstr (sle) call outnum (sestak (i + 1)) } call outch (')') # ) goto ... call outgo (sestak (i + 2)) } if (lab + 1 != sestak (setop + 2)) call outgo (sestak (setop + 2)) } call outcon (lab + 1) # L+1 continue selast = setop # pop select stack setop = sestak (setop) return end enddef #-h- selvar 187 asc 07-apr-82 07:17:11 v1.1 (sw-tools v1.1) # selvar - output select variable Innn, where nnn = lab ifdef (DO_SELECT) subroutine selvar (lab) integer lab call outch ('I') call outnum (lab) return end enddef #-h- skpblk 246 asc 07-apr-82 07:17:12 v1.1 (sw-tools v1.1) # skpblk - skip blanks and tabs in current input file subroutine skpblk include COMMON_BLOCKS character c character ngetch for (c = ngetch (c); c == ' ' | c == '@t'; c = ngetch (c)) ; call putbak (c) return end #-h- squash 1546 asc 07-apr-82 07:17:14 v1.1 (sw-tools v1.1) # squash - convert a long or special identifier into a Fortran variable ifdef (DO_LONGNAME) 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 enddef %%D 2 #-h- strdcl 2584 asc 07-apr-82 07:17:17 v1.1 (sw-tools v1.1) %%E 2 %%I 2 #-h- strdcl 2586 asc 01-nov-82 18:04:57 sventek (joseph sventek) %%E 2 # strdcl - generate code for string declaration subroutine strdcl include COMMON_BLOCKS character t, token (MAXTOK), dchar (MAXTOK) character gnbtok, esc integer i, j, k, n, len integer length, ctoi, lex, elenth string char "character/" string dat "data " string eoss "EOS/" t = gnbtok (token, MAXTOK) if (t != ALPHA) call synerr ("missing string token.") ifdef (DO_LONGNAME) call squash (token) enddef call outtab call pbstr (char) # use defined meaning of "character" repeat { t = gnbtok (dchar, MAXTOK) if (t == '/') break call outstr (dchar) } call outch (' ') # 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) != '(') { # make size same as initial value len = elenth (token) + 1 %%D 2 if (token (1) == ''' | token (1) == '"') %%E 2 %%I 2 if (token (1) == '@'' | token (1) == '"') %%E 2 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) != ')') call synerr ("missing right paren.") else t = gnbtok (token, MAXTOK) } call outch ('(') call outnum (len) call outch (')') call outdon %%D 2 if (token (1) == ''' | token (1) == '"') { %%E 2 %%I 2 if (token (1) == '@'' | token (1) == '"') { %%E 2 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 (',') call outstr (sbuf (i)) call outch ('(') call outnum (k) call outch (')') call outch ('/') if (sbuf (j) == EOS) break n = esc (sbuf, j) call outnum (n) call outch ('/') k = k + 1 } call pbstr (eoss) # use defined meaning of EOS repeat { t = gnbtok (token, MAXTOK) call outstr (token) } until (t == '/') call outdon } sbp = 1 } return end #-h- synerr 699 asc 07-apr-82 07:17:20 v1.1 (sw-tools v1.1) # 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 (':', ERROUT) call putch (' ', ERROUT) call remark (msg) return end #-h- ulstal 268 asc 07-apr-82 07:17:22 v1.1 (sw-tools v1.1) # 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 #-h- uniqid 1935 asc 07-apr-82 07:17:24 v1.1 (sw-tools v1.1) # uniqid - convert an identifier to one never before seen ifdef (DO_LONGNAME) subroutine uniqid (id) character id (MAXTOK) include COMMON_BLOCKS integer i, j, junk, idchl, carry integer lookup, index, length, enter 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 = arith(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. if (enter (id, 0, gentbl) == ERR) call synerr("No room for generated variable name.") return end enddef #-h- unstak 912 asc 07-apr-82 07:17:26 v1.1 (sw-tools v1.1) # 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) == '{') break ifdef (DO_SELECT) if (lextyp (sp) == LEXSELECT) break enddef 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- untils 397 asc 07-apr-82 07:17:28 v1.1 (sw-tools v1.1) # 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 #-h- whilec 262 asc 07-apr-82 07:17:29 v1.1 (sw-tools v1.1) # 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 #-h- whiles 148 asc 07-apr-82 07:17:31 v1.1 (sw-tools v1.1) # whiles - generate code for end of while subroutine whiles (lab) integer lab call outgo (lab) call outcon (lab + 1) return end #-h- oldratfor.fmt 16477 asc 28-jan-82 08:35:16 j .so ~bin/manhdr .hd RATFOR (1) 12-Jun-80 RatFor preprocessor .sy ratfor [files...] >outfile .ds Ratfor translates the ratfor programs in the named files into Fortran. If no input files are given, or the filename '-' appears, the standard input will be read. A file containing general purpose software tools definitions (e.g. EOF, NEWLINE, EOS, etc.) will be automatically opened and processed before any of the files specified are read. .sp 2 Syntax: Ratfor has the following syntax: .nf prog: stmt prog stmt stmt: if (expr) stmt if (expr) stmt else stmt while (expr) stmt repeat (expr) stmt repeat stmt until (expr) for (init clause; test expr; incr clause) stmt do expr stmt do n expr stmt break break n next next n return (expr) select (expr) { case expr: stmt ... default: stmt } digits stmt { prog } or [ prog ] other other: anything unrecognizable (i.e. fortran) clause: other {mother} or [mother] mother: other other; mother .fi where 'stmt' is any Fortran or Ratfor statement. A statement is terminated by an end-of-line or a semicolon. .sp .ne 13 Character Translation: .sp The following character translations are performed: .in +5 .nf < .lt. <= .le. == .eq. != .ne. ^= .ne. ~= .ne. >= .ge. > .gt. | .or. & .and. ! .not. ^ .not. ~ .not. .in -5 .fi .sp 2 Included files: .fi The statement .in +15 .nf include file or include "file" .in -15 .fi will insert the contents of the specified file into the ratfor input in place of the 'include' statement. Quotes must surround the file name if it contains characters other than alphanumerics or underscores. .sp 2 Macro Definitions: The statement .ti +15 define(name,replacement text) defines 'name' as a macro which will be replaced with the indicated text when encountered in the source files. Any occurrences of the strings '$n' in the replacement text, where 1 <= n <= 9, will be replaced with the nth argument when the macro is actually invoked. For example: .ti +15 define(bump, $1 = $1 + 1) will cause the source line .ti +15 bump(i) to be expanded into .ti +15 i = i + 1 The names of macros may contain letters, digits and underline characters, but must start with a letter. Upper case is not equivalent to lower case in macro names. The replacement text is copied directly into the lookup table with no intepretation of the arguments, which differs from the procedure used in the macro utility. This "deferred evaluation" has the effect of eliminating the need for bracketing strings to get them through the macro processor unchanged. A side effect of the deferred evaluation is that defined names cannot be forced through the processor - i.e. the string "define" will never be output from the preprocessor. The inequivalence of upper and lower case in macro names may be used in this case to force the name of a user defined macro onto the output - i.e. if the user has defined a macro named mymac, the replacement text may contain the string MYMAC, which is not defined, and will pass through the processor. (For compatibility, an "mdefine" macro call has been included which interprets definitions before stacking them, as does the macro tool. When using this version, use "$(" and "$)" to indicate deferred evaluation, rather than the "[" and "]" used by the macro tool.) In addition to define, four other built-in macros are provided: .in +17 .ti -16 arith(x,op,y) performs the "integer" arithmetic specified by op (+,-,*,/) on the two numeric operands and returns the result as its replacement. .ti -16 incr(x) converts the string x to a number, adds one to it, and returns the value as its replacement (as a character string). .ti -16 ifelse(a,b,c,d) compares a and b as character strings; if they are the same, c is pushed back onto the input, else d is pushed back. .ti -16 substr(s,m,n) produces the substring of s which starts at position m (with origin one), of length n. If n is omitted or too big, the rest of the string is used, while if m is out of range the result is a null string. .in -17 Note: the statement .ti +15 define name text may also be used, but will not always perform correctly for macros with parameters or multi-line replacement text. The functional form is preferred. .ne 9 Conditional Preprocessing: The statements .in +10 .nf ifdef(macro) ifnotdef(macro) .in +6 .cc * . . . . . . *ti -6 elsedef elsedef . . . . . . *cc . .in -6 enddef enddef .in -10 .fi conditionalize the preprocessing upon whether the macro has been previously defined or not. The `elsedef' portions of the conditionals may be omitted, if desired. The conditional bodies may be nested, up to 10 levels deep. .br String Data Types: The statements .in +10 string name "character string" or .br string name(size) "character string" .in -10 declare 'name' to be a character array long enough to accomodate the ascii codes for the given character string, one per array element. The array is then filled by data statements. The last word of 'name' is initialized to the symbolic parameter EOS, and indicates the end of a string. EOS must be defined either in the standard definitions file or by the user. If a size is given, name is declared to be a character array of 'size' elements. If several string declarations appear consecutively, the generated declarations for the arrays will precede the data statements that initialize them. .sp 2 String Literals: Conversion of in-line quoted strings to hollerith constants is performed in the following manner: .in +5 .nf "str" nHstr 'str' nHstr (where 'n' is the number of characters in str) .in -5 .br .fi String literals can be continued across line boundaries by ending the line to be continued with an underline. The underline is not included as part of the literal. Leading blanks and tabs on the next line are ignored. .sp 2 Integer Constants: Integer constants in bases other than decimal may be specified as n%dddd... where 'n' is a decimal number indicating the base and 'dddd...' are digits in that base. For bases > 10, letters are used for digits above 9. Examples include: 8%77 (=63), 16%2ff (=767), 2%0010011 (=19). The number is converted to the equivalent decimal value using multiplication; this may cause sign problems if the number has too many digits. .sp 2 Lines and Continuation: .fi Input is free-format; that is, statements may appear anywhere on a line, and the end of the line is generally considered the end of the statement. However, lines ending in special characters such as comma, +, -, and * are assumed to be continued on the next line. An exception to this rule is within a condition; the line is assumed to be continued if the condition does not fit on one line. Explicit continuation is indicated by ending a line with an underline character (_). The underline character is not copied to the output file. .sp 2 Comments: Comments are preceded by '#' signs and may appear anywhere in the code. .sp 2 Literal (unprocessed) Lines: Lines can be passed through ratfor without being processed by putting a percent "%" as the first character on the line. The percent will be removed and the line shifted one position to the left, but otherwise will be output without change. Macro invocations, long names, etc., appearing in the line will not be processed. .sp 4 .ne 4 .ti -4 CHANGES .br This ratfor preprocessor differs from the original (as released by Kernighan and Plauger) in the following ways: The code has been rewritten and reorganized. Hash tables have been added for increased efficiency in searching for macro definitions and Ratfor keywords. The 'string' declaration has been included. The define processor has been augmented to support macros with arguments. Conditional preprocessing upon the definition (or lack therof) of a symbol has been included. Many extraneous gotos have been avoided. Blanks have been included in the output for increased readability. Multi-level 'break' and 'next' statements have been included. The Fortran 'DO' is allowed, as well as the ratfor one. The capability of specifying integer constants in bases other than decimal has been added. Underscores have been allowed in names. The 'define' syntax has been expanded to include the form: define name value The 'return(value)' feature has been added. Quoted file names following 'include' statements have been added to allow for special characters in file names. A method for allowing lines to pass through un-processed has been added. Continuation lines have been implemented. Brackets have been allowed to replace braces (but NOT $( and $) ) .fl A generalized definition file (e.g. 'symbols') is automatically opened and read. .sa .nf Kernighan and Plauger's "Software Tools" Kernighan's "RATFOR - A Preprocessor for a Rational Fortran" The Unix command rc in the Unix Manual The tools 'incl' and 'macro' .fi .di (The errors marked with asterisk '*' are fatal; all others are simply warning messages.) .sp 1 .in +5 .ti -5 * arg stack overflow .br The argument stack for the macro processor has been exceeded. The size of the stack is determined by the symbol ARGSIZE in the source definitions file. .br .ti -5 * buffer overflow .br One of the preprocessor's internal buffers overflowed, possibly, but not necessarily, because the string buffers were exceeded. The definition SBUFSIZE in the preprocessor symbols file determines the size of the string buffers. .br .ti -5 * call stack overflow .br The call stack (used to store call frames) in the macro processor has been exceeded. The definition CALLSIZE in the source definition file determines the size of this stack. .br .ti -5 can't open standard definitions file .br The special file containing general purpose ratfor definitions could not be opened, possibly because it did not exist or the user did not have access to the directory on which it resides. .br .ti -5 can't open include .br File to be included could not be located, the user did not have privilege to access it, or the file could not be opened due to some problem in the local primitives. .br .ti -5 * definition too long .br The number of characters in the name to be defined exceeded Ratfor's internal array size. The size is defined by the MAXTOK definition in the preprocessor symbols file. .br .ti -5 * EOF in string .br The macro processor detected an EOF in the current input file while evaluating a macro. .ti -5 * evaluation stack overflow .br The evaluation stack for the macro processor has been exceeded. This stack's size is determined by the symbol EVALSIZE in the source definition file. .br .ti -5 * for clause too long .br The internal buffer used to hold the clauses for the 'for' statement was exceeded. Size of this buffer is determined by the MAXFORSTK definition in the preprocessor symbols file. .br .ti -5 * getdef is confused .br There were horrendous problems when attempting to access the definition table .br .ti -5 illegal break .br Break did not occur inside a valid "while", "for", or "repeat" loop .br .ti -5 illegal else .br Else clause probably did not follow an "if" clause .br .ti -5 illegal next .br "Next" did not occur inside a valid "for", "while", or "repeat" loop .br .ti -5 illegal right brace .br A right brace was found without a matching left brace .br .ti -5 * in dsget: out of dynamic storage space .br There is insufficient memory for macro definitions, etc. Increase the MEMSIZE definition in the preprocessor. .br .ti -5 includes nested too deeply .br There is a limit to the level of nesting of included files. It is dependent upon the maximum number of opened files allowed at a time, and is set by the NFILES definition in the preprocessor symbols file. .br .ti -5 invalid for clause .br The "for" clause did not contain a valid init, condition, and/or increment section .ti -5 invalid string size .br The string format 'string name(size) "..."' was used, but the size was given improperly. .br .ti -5 * missing comma in define .br Definitions of the form 'define(name,defn)' must include the comma as a separator. .br .br .ti -5 missing function name .br There was an error in declaring a function .br .ti -5 missing left paren .br A parenthesis was expected, probably in an "if" statement, but not found .br .ti -5 missing parenthesis in condition .br A right parenthesis was expected, probably in an "if" statement, but not found .br .ti -5 missing quote .br A quoted string was not terminated by a quote .br .ti -5 missing right paren .br A right parenthesis was expected in a Fortran (as opposed to Ratfor) statement but not found .br .ti -5 missing string token .br No array name was given when declaring a string variable .br .ti -5 * non-alphanumeric name .br Definitions may contain only alphanumeric characters and underscores. .br .ti -5 * stack overflow in parser .br Statements were nested at too deep a level. The stack depth is set by the MAXSTACK definition in the preprocessor symbols file. .br .ti -5 token too long .br A token (word) in the source code was too long to fit into one of Ratfor's internal arrays. The maximum size is set by the MAXTOK definition in the preprocessor symbols file. .br .ti -5 * too many characters pushed back .br The source code has illegally specified a Ratfor command, or has used a Ratfor keyword in an illegal manner, and the parser has attempted but failed to make sense out of it. The size of the push-back buffer is set by BUFSIZE in the preprocessor symbols file. .br .ti -5 unbalanced parentheses .br Unbalanced parentheses detected in a Fortran (as opposed to Ratfor) statement .br .ti -5 unexpected brace or EOF .br A brace occurred after a Fortran (but not Ratfor) statement or an end-of-file was reached before the end of a statement .br .ti -5 unexpected EOF .br An end-of-file was reached before all braces had been accounted for. This is usually caused by unmatched braces somewhere deep in the source code. .br .ti -5 warning: possible label conflict .br This message is printed when the user has labeled a statement with a label in the 23000-23999 range. Ratfor statements are assigned in this range and a user-defined one may conflict with a Ratfor-generated one. .br .ne 3 .ti -5 "file": cannot open .br Ratfor could not open an input file specified by the user on the command line. .br .in -5 .au Original by B. Kernighan and P. J. Plauger, with rewrites and enhancements by David Hanson and friends (U. of Arizona), Joe Sventek and Debbie Scherrer (Lawrence Berkeley Laboratory), and Allen Akin (Georgia Institute of Technology). .bu Missing parentheses or braces may cause erratic behavior. Eventually Ratfor should be taught to terminate parenthesis/brace checking at the end of each subroutine. .sp Although one bug was fixed which caused line numbers in error messages to be incorrect, they still aren't quite right. (newlines in macro text are difficult to handle properly). Use them only as a general area in which to look for errors. .sp Extraneous 'continue' statements are generated within Fortran 'do' statements. The 'next' statement does not work properly when used within Fortran 'do' statements. .sp There is no way to explicitly cause a statement to begin in column 6 (i.e. a Fortran continued statement), although implicit continuation is performed. .sp Ratfor is very slow, principally in the lexical analysis, character input, and macro processing routines (in that order). Attempts to speed it up should concentrate on the routines 'gtok', 'ngetch', and 'deftok'. An even better approach would be to re-work the lexical analyzer and parser completely. %%E 1