diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
| commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
| tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /unix/boot/spp/rpp/rpprat | |
| download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz | |
Initial commit
Diffstat (limited to 'unix/boot/spp/rpp/rpprat')
93 files changed, 3698 insertions, 0 deletions
diff --git a/unix/boot/spp/rpp/rpprat/Makefile b/unix/boot/spp/rpp/rpprat/Makefile new file mode 100644 index 00000000..b09289f7 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/Makefile @@ -0,0 +1,44 @@ +# Ratfor source for the SPP preprocessor. A TOOLS compatible ratfor compiler +# is required to compile this. The original UNIX ratfor compiler may not do +# the job. + +.r.f: + /usr/local/bin/ratfor $*.r > $*.f + +SRCS= addchr.r allblk.r alldig.r baderr.r balpar.r beginc.r brknxt.r\ + cascod.r caslab.r declco.r deftok.r doarth.r docode.r doif.r\ + doincr.r domac.r dostat.r dosub.r eatup.r elseif.r endcod.r\ + entdef.r entdkw.r entfkw.r entrkw.r entxkw.r errchk.r errgo.r\ + errorc.r evalr.r finit.r forcod.r fors.r getdef.r gettok.r\ + gnbtok.r gocode.r gtok.r ifcode.r iferrc.r ifgo.r ifparm.r\ + indent.r initkw.r labelc.r labgen.r lex.r litral.r lndict.r\ + ludef.r mapid.r ngetch.r ogotos.r otherc.r outch.r outcon.r\ + outdon.r outdwe.r outgo.r outnum.r outstr.r outtab.r parse.r\ + pbnum.r pbstr.r poicod.r push.r putbak.r putchr.r puttok.r\ + ratfor.r relate.r repcod.r retcod.r sdupl.r skpblk.r squash.r\ + strdcl.r swcode.r swend.r swvar.r synerr.r thenco.r ulstal.r\ + uniqid.r unstak.r untils.r whilec.r whiles.r + +FORT= addchr.f allblk.f alldig.f baderr.f balpar.f beginc.f brknxt.f\ + cascod.f caslab.f declco.f deftok.f doarth.f docode.f doif.f\ + doincr.f domac.f dostat.f dosub.f eatup.f elseif.f endcod.f\ + entdef.f entdkw.f entfkw.f entrkw.f entxkw.f errchk.f errgo.f\ + errorc.f evalr.f finit.f forcod.f fors.f getdef.f gettok.f\ + gnbtok.f gocode.f gtok.f ifcode.f iferrc.f ifgo.f ifparm.f\ + indent.f initkw.f labelc.f labgen.f lex.f litral.f lndict.f\ + ludef.f mapid.f ngetch.f ogotos.f otherc.f outch.f outcon.f\ + outdon.f outdwe.f outgo.f outnum.f outstr.f outtab.f parse.f\ + pbnum.f pbstr.f poicod.f push.f putbak.f putchr.f puttok.f\ + ratfor.f relate.f repcod.f retcod.f sdupl.f skpblk.f squash.f\ + strdcl.f swcode.f swend.f swvar.f synerr.f thenco.f ulstal.f\ + uniqid.f unstak.f untils.f whilec.f whiles.f + +# NOTE -- After regenerating the fortran CASLAB.F, comment out the unreachable +# goto on line 32, generated due to a bug in the ratfor. + +fort: $(SRCS) common defs + make fsrc; mv *.f ../rppfor; touch fort + (cd ../rppfor; sed -e 's/ goto 23012/c goto 23012/'\ + < caslab.f > temp; mv temp caslab.f) + +fsrc: $(FORT) diff --git a/unix/boot/spp/rpp/rpprat/addchr.r b/unix/boot/spp/rpp/rpprat/addchr.r new file mode 100644 index 00000000..74695f93 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/addchr.r @@ -0,0 +1,15 @@ +#-h- addchr 254 local 12/01/80 15:53:44 +# addchr - put c in buf (bp) if it fits, increment bp + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/allblk.r b/unix/boot/spp/rpp/rpprat/allblk.r new file mode 100644 index 00000000..34b83451 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/allblk.r @@ -0,0 +1,22 @@ +#-h- allblk 486 local 12/01/80 15:53:44 +# allblk - determine if line consists of all blanks + include defs + +# 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 diff --git a/unix/boot/spp/rpp/rpprat/alldig.r b/unix/boot/spp/rpp/rpprat/alldig.r new file mode 100644 index 00000000..bac06161 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/alldig.r @@ -0,0 +1,17 @@ +#-h- alldig 306 local 12/01/80 15:53:45 +# alldig - return YES if str is all digits + include defs + + integer function alldig (str) + character str (ARB) + 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 diff --git a/unix/boot/spp/rpp/rpprat/baderr.r b/unix/boot/spp/rpp/rpprat/baderr.r new file mode 100644 index 00000000..51164a8d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/baderr.r @@ -0,0 +1,12 @@ +#-h- baderr 144 local 12/01/80 15:53:45 +# baderr --- report fatal error message, then die + include defs + + subroutine baderr (msg) + + character msg (ARB) +# character*(*) msg + + call synerr (msg) + call endst + end diff --git a/unix/boot/spp/rpp/rpprat/balpar.r b/unix/boot/spp/rpp/rpprat/balpar.r new file mode 100644 index 00000000..8e0388b8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/balpar.r @@ -0,0 +1,40 @@ +#-h- balpar 854 local 12/01/80 15:53:46 +# balpar - copy balanced paren string + include defs + + subroutine balpar + + character t, token (MAXTOK) + character gettok, gnbtok + + integer nlpar + + if (gnbtok (token, MAXTOK) != LPAREN) { + call synerr ("missing left paren.") + return + } + call outstr (token) + nlpar = 1 + repeat { + t = gettok (token, MAXTOK) + if (t == SEMICOL | t == LBRACE | t == RBRACE | t == EOF) { + call pbstr (token) + break + } + if (t == NEWLINE) # delete newlines + token (1) = EOS + else if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == ALPHA) + call squash (token) + # else nothing special + call outstr (token) + } until (nlpar <= 0) + + if (nlpar != 0) + call synerr ("missing parenthesis in condition.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/beginc.r b/unix/boot/spp/rpp/rpprat/beginc.r new file mode 100644 index 00000000..ceb39e4b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/beginc.r @@ -0,0 +1,20 @@ + +include defs + +# BEGINC -- Code that gets executed when the "begin" statement is encountered, +# at the beginning of the executable section of a procedure. + + +subroutine beginc + +integer labgen +include COMMON_BLOCKS + + body = YES # in body of procedure + ername = NO # errchk name not encountered + esp = 0 # error stack pointer + label = FIRST_LABEL # start over with labels + retlab = labgen (1) # label for return stmt + logical_column = 6 + INDENT + col = logical_column +end diff --git a/unix/boot/spp/rpp/rpprat/brknxt.r b/unix/boot/spp/rpp/rpprat/brknxt.r new file mode 100644 index 00000000..154dc31e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/brknxt.r @@ -0,0 +1,45 @@ +#-h- brknxt 1077 local 12/01/80 15:53:46 +# brknxt - generate code for break n and next n; n = 1 is default + include defs + + subroutine brknxt (sp, lextyp, labval, token) + integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token + + integer i, n + integer alldig, ctoi + + character t, ptoken (MAXTOK) + character gnbtok + + include COMMON_BLOCKS + + n = 0 + t = gnbtok (ptoken, MAXTOK) + if (alldig (ptoken) == YES) { # have break n or next n + i = 1 + n = ctoi (ptoken, i) - 1 + } + else if (t != SEMICOL) # default case + call pbstr (ptoken) + for (i = sp; i > 0; i = i - 1) + if (lextyp (i) == LEXWHILE | lextyp (i) == LEXDO + | lextyp (i) == LEXFOR | lextyp (i) == LEXREPEAT) { + if (n > 0) { + n = n - 1 + next # seek proper level + } + else if (token == LEXBREAK) + call outgo (labval (i) + 1) + else + call outgo (labval (i)) + xfer = YES + return + } + + if (token == LEXBREAK) + call synerr ("illegal break.") + else + call synerr ("illegal next.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/cascod.r b/unix/boot/spp/rpp/rpprat/cascod.r new file mode 100644 index 00000000..073dc9a4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/cascod.r @@ -0,0 +1,71 @@ +#-h- cascod 1876 local 12/01/80 15:53:46 +# cascod - generate code for case or default label + include defs + + subroutine cascod (lab, token) + integer lab, token + + include COMMON_BLOCKS + + integer t, l, lb, ub, i, j, junk + integer caslab, labgen, gnbtok + + character tok (MAXTOK) + + if (swtop <= 0) { + call synerr ("illegal case or default.") + return + } + call indent (-1) + 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) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/caslab.r b/unix/boot/spp/rpp/rpprat/caslab.r new file mode 100644 index 00000000..12d3c0da --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/caslab.r @@ -0,0 +1,48 @@ +include defs + +# caslab - get one case label + +integer function caslab (n, t) + +integer n, t +character tok(MAXTOK) +integer i, s, lev +integer gnbtok, ctoi + + t = gnbtok (tok, MAXTOK) + while (t == NEWLINE) + t = gnbtok (tok, MAXTOK) + + if (t == EOF) + return (t) + + for (lev=0; t == LPAREN; t = gnbtok (tok, MAXTOK)) + lev = lev + 1 + + if (t == MINUS) + s = -1 + else + s = +1 + if (t == MINUS | t == PLUS) + t = gnbtok (tok, MAXTOK) + + if (t != DIGIT) + goto 99 + else { + i = 1 + n = s * ctoi (tok, i) + } + + for (t=gnbtok(tok,MAXTOK); t == RPAREN; t=gnbtok(tok,MAXTOK)) + lev = lev - 1 + if (lev != 0) + goto 99 + + while (t == NEWLINE) + t = gnbtok (tok, MAXTOK) + + return + + 99 call synerr ("Invalid case label.") + n = 0 +end diff --git a/unix/boot/spp/rpp/rpprat/common b/unix/boot/spp/rpp/rpprat/common new file mode 100644 index 00000000..9685729a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/common @@ -0,0 +1,79 @@ +#-h- common 2163 local 12/01/80 15:50:08 +# Common blocks used by the Ratfor preprocessor +# Place on a file called 'common' + + + common /cdefio/ bp, buf (BUFSIZE) + integer bp # next available character; init = 0 + character buf # pushed-back characters + + common /cfname/ fcname (MAXNAME) + character fcname # text of current function name + + common /cfor/ fordep, forstk (MAXFORSTK) + integer fordep # current depth of for statements + character forstk # stack of reinit strings + + common /cgoto/ xfer + integer xfer # YES if just made transfer, NO otherwise + + common /clabel/ label, retlab, memflg, col, logical_column + integer label # next label returned by labgen + integer retlab # label for return code at end of procedure + integer memflg # set to YES after Mem common has been declared + integer col # column where output statement starts + integer logical_column # col = min (maxindent, logical_column) + + common /cline/ dbgout, dbglev, level, linect (NFILES), infile (NFILES), + fnamp, fnames (MAXFNAMES) + integer dbgout # YES if debug (-g) output is desired + integer dbglev # current file level for debug output + 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), smem(SZ_SMEM) + integer sbp # next available character position; init = 1 + character sbuf # saved for data statements + character smem # mem declaration + + common /cswtch/ swtop, swlast, swstak(MAXSWITCH), swvnum, swvlev, + swvstk(MAXSWNEST), swinrg + integer swtop # current switch entry; init = 0 + integer swlast # next available position; init = 1 + integer swstak # switch information + integer swvnum # counter for switch variable names; init = 0 + integer swvlev # level pointer for nesting of switches; init = 0 + integer swvstk # stack for the switch variable names + integer swinrg # assert swinrange - disable range checking in next sw. + + common /ckword/ rkwtbl + pointer rkwtbl # symbol table containing Ratfor key words + + common /clname/ fkwtbl, namtbl, gentbl, errtbl, xpptbl + 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 + pointer errtbl # symbol table of names to be error checked + pointer xpptbl # table of xpp directives + +common /erchek/ ername, body, esp, errstk(MAXERRSTK) + integer ername # YES if err checked name encountered + integer body # YES when between BEGIN .. END block + integer esp # error stack pointer + integer errstk # error stack (for statement labels) + + DS_DECL(mem, MEMSIZE) +#-t- common 2163 local 12/01/80 15:50:08 diff --git a/unix/boot/spp/rpp/rpprat/declco.r b/unix/boot/spp/rpp/rpprat/declco.r new file mode 100644 index 00000000..7c669e8c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/declco.r @@ -0,0 +1,72 @@ +include defs + +# DECLCO -- Process a declaration (xpp directive). Look up directive in +# the symbol table. If found, output the corresponding Fortran declaration, +# otherwise output the original string. + +subroutine declco (id) + +character id(MAXTOK) +character newid(MAXTOK), tok, tokbl +integer junk, ludef, equal, gettok +include COMMON_BLOCKS +string xptyp XPOINTER +string xpntr "x$pntr" +string xfunc "x$func" +string xsubr "x$subr" +ifdef (IMPNONE, +string impnone "implicit none") + + if (ludef (id, newid, xpptbl) == YES) { + if (equal (id, xpntr) == YES) { + # Pointer declaration. + tokbl = gettok (newid, MAXTOK) + if (tokbl == BLANK) + tok = gettok (newid, MAXTOK) + else + tok = tokbl + + if (tok == XPP_DIRECTIVE & equal (newid, xfunc) == YES) { + # Pointer function. + call outtab + call outstr (xptyp) + junk = ludef (newid, newid, xpptbl) + call outstr (newid) + call eatup + call outdon + + ifdef (IMPNONE, + call outtab + call outstr (impnone) + call outdon) + + call poicod (NO) + + } else { + # Pointer variable. + call pbstr (newid) + call poicod (YES) + } + + } else if (equal (id, xsubr) == YES) { + # Subroutine declaration. + call outtab + call outstr (newid) + call eatup + call outdon + + ifdef (IMPNONE, + call outtab + call outstr (impnone) + call outdon) + + } else { + # Some other declaration. + call outtab + call outstr (newid) + call outch (BLANK) + } + + } else + call synerr ("Invalid x$type type declaration.") +end diff --git a/unix/boot/spp/rpp/rpprat/defs b/unix/boot/spp/rpp/rpprat/defs new file mode 100644 index 00000000..bf040c55 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/defs @@ -0,0 +1,138 @@ +# common definitions for all routines comprising the ratfor preprocessor +#--------------------------------------------------------------- +# The definition STDEFNS defines the file which contains the +# standard definitions to be used when preprocessing a file. +# It is opened and read automatically by the ratfor preprocessor. +# Set STDEFNS to the name of the file in which the standard +# definitions reside. If you don't want the preprocessor to +# automatically open this file, set STDENFS to "". +# +#--------------------------------------------------------------- +# If you want the preprocessor to output upper case only, +# set the following definition: +# +# define (UPPERC,) +# +#--------------------------------------------------------------- +# Some of the buffer sizes and other symbols might have to be +# changed. Especially check the following: +# +# MAXDEF (number of characters in a definition) +# SBUFSIZE (nbr string declarations allowed per module) +# MAXSTRTBL (size of table to buffer string declarations) +# MAXSWITCH (max stack for switch statement) +# +#----------------------------------------------------------------- + + +define (STDEFNS, string defns "") # standard defns file +#define (UPPERC,) # define if Fortran compiler wants upper case +#define (IMPNONE,) # output IMPLICIT NONE in procedures +define (NULL,0) +define (INDENT,3) # number of spaces of indentation +define (MAX_INDENT,30) # maximum column for indentation +define (FIRST_LABEL,100) # first statement label +define (SZ_SPOOLBUF,8) # for breaking continuation cards + +define (RADIX,PERCENT) # % indicates alternate radix +define (TOGGLE,PERCENT) # toggle for literal lines +define (ARGFLAG,DOLLAR) +define (CUTOFF,3) # min nbr of cases to generate branch table + # (for switch statement) +define (DENSITY,2) # reciprocal of density necessary for + # branch table +define (FILLCHAR,DIG0) # used in long-name uniquing +define (MAXIDLENGTH,6) # for Fortran 66 and 77 +define (SZ_SMEM,240) # memory common declarations string + + +# Lexical items (codes are negative to avoid conflict with character values) + +define (LEXBEGIN,-83) +define (LEXBREAK,-79) +define (LEXCASE,-91) +define (LEXDEFAULT,-90) +define (LEXDIGITS,-89) +define (LEXDO,-96) +define (LEXELSE,-87) +define (LEXEND,-82) +define (LEXERRCHK,-84) +define (LEXERROR,-73) +define (LEXFOR,-94) +define (LEXIF,-99) +define (LEXIFELSE,-72) +define (LEXIFERR,-98) +define (LEXIFNOERR,-97) +define (LEXLITERAL,-85) +define (LEXNEXT,-78) +define (LEXOTHER,-80) +define (LEXPOINTER,-88) +define (LEXRBRACE,-74) +define (LEXREPEAT,-93) +define (LEXRETURN,-77) +define (LEXGOTO,-76) +define (LEXSTOP,-71) +define (LEXSTRING,-75) +define (LEXSWITCH,-92) +define (LEXTHEN,-86) +define (LEXUNTIL,-70) +define (LEXWHILE,-95) +define (LSTRIPC,-69) +define (RSTRIPC,-68) +define (LEXDECL,-67) + +define (XPP_DIRECTIVE, -166) + +# 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 (PRAGMATYPE,-17) + + +# Size-limiting definitions: + +define (MEMSIZE,60000) # space allotted to symbol tables and macro text +define (BUFSIZE,4096) # pushback buffer for ngetch and putbak +define (PBPOINT,3192) # point in buffer where pushback begins +define (SBUFSIZE,2048) # buffer for string statements +define (MAXDEF,2048) # max chars in a defn +define (MAXFORSTK,200) # max space for for reinit clauses +define (MAXERRSTK,30) # max nesting of iferr statements +define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE)) +define (MAXSTACK,100) # max stack depth for parser +define (MAXSWITCH,1000) # max stack for switch statement +define (MAXSWNEST,10) # max nesting of switches in a procedure +define (MAXTOK,100) # max chars in a token +define (NFILES,5) # max number of include file nesting +define (MAXNBRSTR,20) #max nbr string declarations per module +define (CALLSIZE,50) +define (ARGSIZE,100) +define (EVALSIZE,500) + + +# Where to find the common blocks: + +define(COMMON_BLOCKS,"common") + +# Data types, Dynamic Memory common: + +define (XPOINTER,"integer ") + + +# The following external names are redefined to avoid name collisions with +# standard library procedures on some systems. + +define open rfopen +define close rfclos +define flush rfflus +define note rfnote +define seek rfseek +define remove rfrmov +define exit rexit diff --git a/unix/boot/spp/rpp/rpprat/deftok.r b/unix/boot/spp/rpp/rpprat/deftok.r new file mode 100644 index 00000000..af20c35c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/deftok.r @@ -0,0 +1,162 @@ +#-h- deftok 4116 local 12/01/80 15:53:47 +# deftok - get token; process macro calls and invocations + include defs + +# this routine has been disabled to allow defines with parameters to be added + +# character function deftok (token, toksiz) +# character gtok +# integer toksiz +# character defn (MAXDEF), t, token (MAXTOK) +# integer ludef +# include COMMON_BLOCKS +# +# for (t = gtok (token, toksiz); t!=EOF; t = gtok (token, toksiz)) { +# if (t != ALPHA) # non-alpha +# break +# if (ludef (token, defn, deftbl) == NO) # undefined +# break +# if (defn (1) == DEFTYPE) { # get definition +# call getdef (token, toksiz, defn, MAXDEF) +# call entdef (token, defn, deftbl) +# } +# else +# call pbstr (defn) # push replacement onto input +# } +# deftok = t +# if (deftok == ALPHA) # convert to single case +# call fold (token) +# return +# end +# deftok - get token; process macro calls and invocations + + character function deftok (token, toksiz) + character token (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character t, c, defn (MAXDEF), mdefn (MAXDEF) + character gtok + integer equal + + integer ap, argstk (ARGSIZE), callst (CALLSIZE), + nlb, plev (CALLSIZE), ifl + integer ludef, push, ifparm + + string balp "()" + string pswrg "switch_no_range_check" + + cp = 0 + ap = 1 + ep = 1 + for (t = gtok (token, toksiz); t != EOF; t = gtok (token, toksiz)) { + if (t == ALPHA) + if (ludef (token, defn, deftbl) == NO) { + if (cp == 0) + break + else + call puttok (token) + } else if (defn (1) == DEFTYPE) { # process defines directly + call getdef (token, toksiz, defn, MAXDEF) + call entdef (token, defn, deftbl) + } else if (defn (1) == IFDEFTYPE | defn (1) == IFNOTDEFTYPE) { + c = defn (1) + call getdef (token, toksiz, defn, MAXDEF) + ifl = ludef (token, mdefn, deftbl) + if ((ifl == YES & c == IFDEFTYPE) | + (ifl == NO & c == IFNOTDEFTYPE)) + call pbstr (defn) + + } else if (defn(1) == PRAGMATYPE & cp == 0) { # pragma + if (gtok (defn, MAXDEF) == BLANK) { + if (gtok (defn, MAXDEF) == ALPHA) { + if (equal (defn, pswrg) == YES) + swinrg = YES + else + goto 10 + } else { +10 call pbstr (defn) + call putbak (BLANK) + break + } + } else { + call pbstr (defn) + break + } + + } else { + cp = cp + 1 + if (cp > CALLSIZE) + call baderr ("call stack overflow.") + callst (cp) = ap + ap = push (ep, argstk, ap) + call puttok (defn) + call putchr (EOS) + ap = push (ep, argstk, ap) + call puttok (token) + call putchr (EOS) + ap = push (ep, argstk, ap) + t = gtok (token, toksiz) + if (t == BLANK) { # allow blanks before arguments + t = gtok (token, toksiz) + call pbstr (token) + if (t != LPAREN) + call putbak (BLANK) + } + else + call pbstr (token) + if (t != LPAREN) + call pbstr (balp) + else if (ifparm (defn) == NO) + call pbstr (balp) + plev (cp) = 0 + } else if (t == LSTRIPC) { + nlb = 1 + repeat { + t = gtok (token, toksiz) + if (t == LSTRIPC) + nlb = nlb + 1 + else if (t == RSTRIPC) { + nlb = nlb - 1 + if (nlb == 0) + break + } + else if (t == EOF) + call baderr ("EOF in string.") + call puttok (token) + } + } + else if (cp == 0) + break + else if (t == LPAREN) { + if (plev (cp) > 0) + call puttok (token) + plev (cp) = plev (cp) + 1 + } + else if (t == RPAREN) { + plev (cp) = plev (cp) - 1 + if (plev (cp) > 0) + call puttok (token) + else { + call putchr (EOS) + call evalr (argstk, callst (cp), ap - 1) + ap = callst (cp) + ep = argstk (ap) + cp = cp - 1 + } + } + else if (t == COMMA & plev (cp) == 1) { + call putchr (EOS) + ap = push (ep, argstk, ap) + } + else + call puttok (token) + } + + deftok = t + if (t == ALPHA) + call fold (token) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/doarth.r b/unix/boot/spp/rpp/rpprat/doarth.r new file mode 100644 index 00000000..2fe633d5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doarth.r @@ -0,0 +1,30 @@ +#-h- doarth 636 local 12/01/80 15:53:48 +# doarth - do arithmetic operation + include defs + + subroutine doarth (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer k, l + integer ctoi + + character op + + k = argstk (i + 2) + l = argstk (i + 4) + op = evalst (argstk (i + 3)) + if (op == PLUS) + call pbnum (ctoi (evalst, k) + ctoi (evalst, l)) + else if (op == MINUS) + call pbnum (ctoi (evalst, k) - ctoi (evalst, l)) + else if (op == STAR ) + call pbnum (ctoi (evalst, k) * ctoi (evalst, l)) + else if (op == SLASH ) + call pbnum (ctoi (evalst, k) / ctoi (evalst, l)) + else + call remark ('arith error') + + return + end diff --git a/unix/boot/spp/rpp/rpprat/docode.r b/unix/boot/spp/rpp/rpprat/docode.r new file mode 100644 index 00000000..e505f8ee --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/docode.r @@ -0,0 +1,33 @@ +#-h- docode 522 local 12/01/80 15:53:49 +# docode - generate code for beginning of do + include defs + + subroutine docode (lab) + integer lab + + integer labgen + + include COMMON_BLOCKS + + character gnbtok + character lexstr (MAXTOK) + + string sdo "do" + + xfer = NO + call outtab + call outstr (sdo) + call outch (BLANK) + lab = labgen (2) + if (gnbtok (lexstr, MAXTOK) == DIGIT) # check for fortran DO + call outstr (lexstr) + else { + call pbstr (lexstr) + call outnum (lab) + } + call outch (BLANK) + call eatup + call outdwe + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/doif.r b/unix/boot/spp/rpp/rpprat/doif.r new file mode 100644 index 00000000..51495bd2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doif.r @@ -0,0 +1,25 @@ +#-h- doif 458 local 12/01/80 15:53:49 +# doif - select one of two (macro) arguments + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/doincr.r b/unix/boot/spp/rpp/rpprat/doincr.r new file mode 100644 index 00000000..9a8604bf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/doincr.r @@ -0,0 +1,17 @@ +#-h- doincr 246 local 12/01/80 15:53:49 +# doincr - increment macro argument by 1 + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/domac.r b/unix/boot/spp/rpp/rpprat/domac.r new file mode 100644 index 00000000..fe4c1c62 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/domac.r @@ -0,0 +1,18 @@ +#-h- domac 326 local 12/01/80 15:53:49 +# domac - install macro definition in table + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/dostat.r b/unix/boot/spp/rpp/rpprat/dostat.r new file mode 100644 index 00000000..4a934bad --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/dostat.r @@ -0,0 +1,13 @@ +#-h- dostat 156 local 12/01/80 15:53:50 +# dostat - generate code for end of do statement + include defs + + subroutine dostat (lab) + + integer lab + + call indent (-1) + call outcon (lab) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/dosub.r b/unix/boot/spp/rpp/rpprat/dosub.r new file mode 100644 index 00000000..611bdbaf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/dosub.r @@ -0,0 +1,31 @@ +#-h- dosub 709 local 12/01/80 15:53:50 +# dosub - select macro substring + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/eatup.r b/unix/boot/spp/rpp/rpprat/eatup.r new file mode 100644 index 00000000..df001caf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/eatup.r @@ -0,0 +1,69 @@ +#-h- eatup 1137 local 12/01/80 15:53:50 +# eatup - process rest of statement; interpret continuations + include defs + + subroutine eatup + + character ptoken (MAXTOK), t, token (MAXTOK) + character gettok + integer nlpar, equal + include COMMON_BLOCKS + string serror "error" + + nlpar = 0 + token(1) = EOS + + repeat { + call outstr (token) + t = gettok (token, MAXTOK) + } until (t != BLANK & t != TAB) + + if (t == ALPHA) { # is it a "call error" stmt? + if (equal (token, serror) == YES) { + # call errorc (token) + # return + + # ERROR statement is now simply error checked like any other + # external procedure, so that it may be used the same way. + ername = YES + } + } + goto 10 + + repeat { + t = gettok (token, MAXTOK) +10 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 == SLASH & body == YES) | + t == LPAREN | t == AND | t == BAR | t == BANG | t == TILDE | + t == NOT | t == CARET | t == EQUALS | t == UNDERLINE) { + while (gettok (ptoken, MAXTOK) == NEWLINE) + ; + call pbstr (ptoken) + if (t == UNDERLINE) + token (1) = EOS + } + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == ALPHA) + call squash (token) + call outstr (token) + } until (nlpar < 0) + + if (nlpar != 0) + call synerr ("unbalanced parentheses.") + + return + end diff --git a/unix/boot/spp/rpp/rpprat/elseif.r b/unix/boot/spp/rpp/rpprat/elseif.r new file mode 100644 index 00000000..88b1355d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/elseif.r @@ -0,0 +1,13 @@ +#-h- elseif 155 local 12/01/80 15:53:51 +# elseif - generate code for end of if before else + include defs + + subroutine elseif (lab) + integer lab + + call outgo (lab+1) + call indent (-1) + call outcon (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/endcod.r b/unix/boot/spp/rpp/rpprat/endcod.r new file mode 100644 index 00000000..f94636f8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/endcod.r @@ -0,0 +1,36 @@ +include defs + +# ENDCOD -- Code thats gets executed when the END statement is encountered, +# terminating a procedure. + +subroutine endcod (endstr) + +character endstr(1) +include COMMON_BLOCKS +string sepro "call zzepro" +string sret "return" + + if (esp != 0) + call synerr ("Unmatched 'iferr' or 'then' keyword.") + esp = 0 # error stack pointer + body = NO + ername = NO + if (errtbl != NULL) + call rmtabl (errtbl) + errtbl = NULL + memflg = NO # reinit mem decl flag + + if (retlab != NULL) + call outnum (retlab) + call outtab + call outstr (sepro) + call outdon + call outtab + call outstr (sret) + call outdon + + col = 6 + call outtab + call outstr (endstr) + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/entdef.r b/unix/boot/spp/rpp/rpprat/entdef.r new file mode 100644 index 00000000..e9c447ff --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entdef.r @@ -0,0 +1,19 @@ +#-h- entdef 387 local 12/01/80 15:53:51 +# entdef - enter a new symbol definition, discarding any old one + include defs + + subroutine entdef (name, defn, table) + character name (MAXTOK), defn (ARB) + pointer table + + integer lookup + + pointer text + pointer sdupl + + if (lookup (name, text, table) == YES) + call dsfree (text) # this is how to do UNDEFINE, by the way + call enter (name, sdupl (defn), table) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/entdkw.r b/unix/boot/spp/rpp/rpprat/entdkw.r new file mode 100644 index 00000000..6b061075 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entdkw.r @@ -0,0 +1,41 @@ +#-h- entdkw 975 local 12/01/80 15:54:05 +# entdkw --- install macro processor keywords + include defs + + subroutine entdkw + + character deft(2), prag(2) #, inct(2), subt(2), ift(2), art(2), + # ifdft(2), ifndt(2), mact(2) + + string defnam "define" + string prgnam "pragma" +# string macnam "mdefine" +# string incnam "incr" +# string subnam "substr" +# string ifnam "ifelse" +# string arnam "arith" +# string ifdfnm "ifdef" +# string ifndnm "ifnotdef" + + data deft (1), deft (2) /DEFTYPE, EOS/ + data prag (1), prag (2) /PRAGMATYPE, EOS/ +# data mact (1), mact (2) /MACTYPE, EOS/ +# data inct (1), inct (2) /INCTYPE, EOS/ +# data subt (1), subt (2) /SUBTYPE, EOS/ +# data ift (1), ift (2) /IFTYPE, EOS/ +# data art (1), art (2) /ARITHTYPE, EOS/ +# data ifdft (1), ifdft (2) /IFDEFTYPE, EOS/ +# data ifndt (1), ifndt (2) /IFNOTDEFTYPE, EOS/ + + call ulstal (defnam, deft) + call ulstal (prgnam, prag) +# call ulstal (macnam, mact) +# call ulstal (incnam, inct) +# call ulstal (subnam, subt) +# call ulstal (ifnam, ift) +# call ulstal (arnam, art) +# call ulstal (ifdfnm, ifdft) +# call ulstal (ifndnm, ifndt) + +return +end diff --git a/unix/boot/spp/rpp/rpprat/entfkw.r b/unix/boot/spp/rpp/rpprat/entfkw.r new file mode 100644 index 00000000..43174502 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entfkw.r @@ -0,0 +1,14 @@ +include defs + +# entfkw - place Fortran keywords in symbol table. +# Place in the following table any long (> 6 characters) +# keyword that is used by your Fortran compiler: + + +subroutine entfkw + +include COMMON_BLOCKS +string sequiv "equivalence" + + call enter (sequiv, 0, fkwtbl) +end diff --git a/unix/boot/spp/rpp/rpprat/entrkw.r b/unix/boot/spp/rpp/rpprat/entrkw.r new file mode 100644 index 00000000..ec86b9e0 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entrkw.r @@ -0,0 +1,56 @@ +#-h- entrkw 1003 local 12/01/80 15:54:06 +# entrkw --- install Ratfor keywords in symbol table + include defs + + subroutine entrkw + + include COMMON_BLOCKS + + string sif "if" + string selse "else" + string swhile "while" + string sdo "do" + string sbreak "break" + string snext "next" + string sfor "for" + string srept "repeat" + string suntil "until" + string sret "return" + string sstr "string" + string sswtch "switch" + string scase "case" + string sdeflt "default" + string send "end" + string serrchk "errchk" + string siferr "iferr" + string sifnoerr "ifnoerr" + string sthen "then" + string sbegin "begin" + string spoint "pointer" + string sgoto "goto" + + call enter (sif, LEXIF, rkwtbl) + call enter (selse, LEXELSE, rkwtbl) + call enter (swhile, LEXWHILE, rkwtbl) + call enter (sdo, LEXDO, rkwtbl) + call enter (sbreak, LEXBREAK, rkwtbl) + call enter (snext, LEXNEXT, rkwtbl) + call enter (sfor, LEXFOR, rkwtbl) + call enter (srept, LEXREPEAT, rkwtbl) + call enter (suntil, LEXUNTIL, rkwtbl) + call enter (sret, LEXRETURN, rkwtbl) + call enter (sstr, LEXSTRING, rkwtbl) + call enter (sswtch, LEXSWITCH, rkwtbl) + call enter (scase, LEXCASE, rkwtbl) + call enter (sdeflt, LEXDEFAULT, rkwtbl) + call enter (send, LEXEND, rkwtbl) + call enter (serrchk, LEXERRCHK, rkwtbl) + call enter (siferr, LEXIFERR, rkwtbl) + call enter (sifnoerr, LEXIFNOERR, rkwtbl) + call enter (sthen, LEXTHEN, rkwtbl) + call enter (sbegin, LEXBEGIN, rkwtbl) + call enter (spoint, LEXPOINTER, rkwtbl) + call enter (sgoto, LEXGOTO, rkwtbl) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/entxkw.r b/unix/boot/spp/rpp/rpprat/entxkw.r new file mode 100644 index 00000000..d2ec81b2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/entxkw.r @@ -0,0 +1,51 @@ + +include defs + +# ENTXKW -- Enter all XPP directives in the symbol table. + +subroutine entxkw + +include COMMON_BLOCKS + +string sbool "x$bool" +string schar "x$char" +string sshort "x$short" +string sint "x$int" +string slong "x$long" +string sreal "x$real" +string sdble "x$dble" +string scplx "x$cplx" +string spntr "x$pntr" +string sfchr "x$fchr" +string sfunc "x$func" +string ssubr "x$subr" +string sextn "x$extn" + +string dbool "logical" +string dchar "integer*2" +string dshort "integer*2" +string dint "integer" +string dlong "integer" +string dpntr "integer" +string dreal "real" +string ddble "double precision" +string dcplx "complex" +string dfchr "character" +string dfunc "function" +string dsubr "subroutine" +string dextn "external" + + call entdef (sbool, dbool, xpptbl) + call entdef (schar, dchar, xpptbl) + call entdef (sshort, dshort, xpptbl) + call entdef (sint, dint, xpptbl) + call entdef (slong, dlong, xpptbl) + call entdef (spntr, dpntr, xpptbl) + call entdef (sreal, dreal, xpptbl) + call entdef (sdble, ddble, xpptbl) + call entdef (scplx, dcplx, xpptbl) + call entdef (sfchr, dfchr, xpptbl) + call entdef (sfunc, dfunc, xpptbl) + call entdef (ssubr, dsubr, xpptbl) + call entdef (sextn, dextn, xpptbl) +end diff --git a/unix/boot/spp/rpp/rpprat/errchk.r b/unix/boot/spp/rpp/rpprat/errchk.r new file mode 100644 index 00000000..4b948936 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errchk.r @@ -0,0 +1,42 @@ +include defs + +# ERRCHK -- Code called to process an ERRCHK declaration. + +subroutine errchk + +character tok, last_tok, gnbtok, token(MAXTOK) +integer ntok +pointer mktabl +include COMMON_BLOCKS +string serrcom1 "logical xerflg, xerpad(84)" +string serrcom2 "common /xercom/ xerflg, xerpad" + + ntok = 0 + tok = 0 + + repeat { + last_tok = tok + tok = gnbtok (token, MAXTOK) + + switch (tok) { + case ALPHA: + if (errtbl == NULL) { + errtbl = mktabl(0) # make empty table + call outtab # declare err flag + call outstr (serrcom1) + call outdon + call outtab # declare err common + call outstr (serrcom2) + call outdon + } + call enter (token, 0, errtbl) # enter keyw in table + case COMMA: + # no action, but required by syntax + case NEWLINE: + if (last_tok != COMMA) + break + default: + call synerr ("Syntax error in ERRCHK declaration.") + } + } +end diff --git a/unix/boot/spp/rpp/rpprat/errgo.r b/unix/boot/spp/rpp/rpprat/errgo.r new file mode 100644 index 00000000..81aa582c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errgo.r @@ -0,0 +1,29 @@ +include defs + +# ERRGO -- Ouput error checking code. + +subroutine errgo + +include COMMON_BLOCKS +string serrchk "if (xerflg) " + + # In the processing of the last line, was an indentifier encountered + # for which error checking is required (named in errchk declaration)? + + if (ername == YES) { + call outtab + if (esp > 0) { # in iferr ... stmt? + # Omit goto if goto statement label number is zero. This + # happens in "iferr (...)" statements. + if (errstk(esp) > 0) { + call outstr (serrchk) + call ogotos (errstk(esp)+2, NO) # "goto lab" + } + } else { + call outstr (serrchk) + call ogotos (retlab, NO) + call outdon + } + ername = NO + } +end diff --git a/unix/boot/spp/rpp/rpprat/errorc.r b/unix/boot/spp/rpp/rpprat/errorc.r new file mode 100644 index 00000000..f0fa6a2f --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/errorc.r @@ -0,0 +1,20 @@ + +include defs + +# ERRORC -- Process an error statement. "call error" already processed. + + +subroutine errorc (str) + +character str(1) +include COMMON_BLOCKS + + xfer = YES + call outstr (str) + call balpar # output "(errcod, errmsg)" + ername = NO # just to be safe + call outdon + call outtab + call ogotos (retlab, NO) # always return after error statement + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/evalr.r b/unix/boot/spp/rpp/rpprat/evalr.r new file mode 100644 index 00000000..3752bcd4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/evalr.r @@ -0,0 +1,56 @@ +#-h- evalr 1126 local 12/01/80 15:54:06 +# evalr - expand args i through j: evaluate builtin or push back defn + include defs + + subroutine evalr (argstk, i, j) + integer argstk (ARGSIZE), i, j + + include COMMON_BLOCKS + + integer argno, k, m, n, t, td, in_string, delim + external index + 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 { + in_string = NO + for (k = t + length (evalst (t)) - 1; k > t; k = k - 1) + if (evalst(k) == SQUOTE | evalst(k) == DQUOTE) { + if (in_string == NO) { + delim = evalst(k) + in_string = YES + } + else + in_string = NO + call putbak (evalst(k)) + } + # Don't expand $arg if in a string. + else if (evalst(k-1) != ARGFLAG | in_string == YES) + 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 diff --git a/unix/boot/spp/rpp/rpprat/finit.r b/unix/boot/spp/rpp/rpprat/finit.r new file mode 100644 index 00000000..8ca1ecf5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/finit.r @@ -0,0 +1,24 @@ +#-h- finit 432 local 12/01/80 15:54:07 +# finit - initialize for each input file + include defs + + subroutine finit + + include COMMON_BLOCKS + + outp = 0 # output character pointer + level = 1 # file control + linect (1) = 0 + sbp = 1 + fnamp = 2 + fnames (1) = EOS + bp = PBPOINT + buf (bp) = EOS # to force a read on next call to 'ngetch' + fordep = 0 # for stack + fcname (1) = EOS # current function name + swtop = 0 # switch stack + swlast = 1 + swvnum = 0 + swvlev = 0 + return + end diff --git a/unix/boot/spp/rpp/rpprat/forcod.r b/unix/boot/spp/rpp/rpprat/forcod.r new file mode 100644 index 00000000..9d389f5e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/forcod.r @@ -0,0 +1,101 @@ +#-h- forcod 2259 local 12/01/80 15:54:07 +# forcod - beginning of for statement + include defs + + subroutine forcod (lab) + integer lab + + include COMMON_BLOCKS + + character t, token (MAXTOK) + character gettok, gnbtok + + integer i, j, nlpar + integer length, labgen + + string ifnot "if (.not." + string serrchk ".and.(.not.xerflg))) " + + 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 outdwe + } + if (gnbtok (token, MAXTOK) == SEMICOL) # empty condition + call outcon (lab) + else { # non-empty condition + call pbstr (token) + call outnum (lab) + call outtab + call outstr (ifnot) + call outch (LPAREN) + nlpar = 0 + while (nlpar >= 0) { + t = gettok (token, MAXTOK) + if (t == SEMICOL) + break + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == EOF) { + call pbstr (token) + return + } + if (t == ALPHA) + call squash (token) + if (t != NEWLINE & t != UNDERLINE) + call outstr (token) + } + + # name encountered for which error checking is required? + if (ername == YES) + call outstr (serrchk) + else { + call outch (RPAREN) + call outch (RPAREN) + call outch (BLANK) + } + call outgo (lab+2) # error checking below (errgo) + if (nlpar < 0) + call synerr ("invalid for clause.") + } + fordep = fordep + 1 # stack reinit clause + j = 1 + for (i = 1; i < fordep; i = i + 1) # find end + j = j + length (forstk (j)) + 1 + forstk (j) = EOS # null, in case no reinit + nlpar = 0 + t = gnbtok (token, MAXTOK) + call pbstr (token) + while (nlpar >= 0) { + t = gettok (token, MAXTOK) + if (t == LPAREN) + nlpar = nlpar + 1 + else if (t == RPAREN) + nlpar = nlpar - 1 + if (t == EOF) { + call pbstr (token) + break + } + if (nlpar >= 0 & t != NEWLINE & t != UNDERLINE) { + if (t == ALPHA) + call squash (token) + if (j + length (token) >= MAXFORSTK) + call baderr ("for clause too long.") + call scopy (token, 1, forstk, j) + j = j + length (token) + } + } + lab = lab + 1 # label for next's + call indent (1) + call errgo + return + end diff --git a/unix/boot/spp/rpp/rpprat/fors.r b/unix/boot/spp/rpp/rpprat/fors.r new file mode 100644 index 00000000..5d3692ea --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/fors.r @@ -0,0 +1,29 @@ +#-h- fors 458 local 12/01/80 15:54:08 +# fors - process end of for statement + include defs + + subroutine fors (lab) + integer lab + + include COMMON_BLOCKS + + integer i, j + integer length + + xfer = NO + call outnum (lab) + j = 1 + for (i = 1; i < fordep; i = i + 1) + j = j + length (forstk (j)) + 1 + if (length (forstk (j)) > 0) { + call outtab + call outstr (forstk (j)) + call outdon + } + call outgo (lab - 1) + call indent (-1) + call outcon (lab + 1) + fordep = fordep - 1 + ername = NO + return + end diff --git a/unix/boot/spp/rpp/rpprat/fort b/unix/boot/spp/rpp/rpprat/fort new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/fort diff --git a/unix/boot/spp/rpp/rpprat/getdef.r b/unix/boot/spp/rpp/rpprat/getdef.r new file mode 100644 index 00000000..be97b439 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/getdef.r @@ -0,0 +1,62 @@ +#-h- getdef 1634 local 12/01/80 15:54:08 +# getdef (for no arguments) - get name and definition + include defs + + subroutine getdef (token, toksiz, defn, defsiz) + character token (MAXTOK), defn (MAXDEF) + integer toksiz, defsiz + + include COMMON_BLOCKS + + character c, t, ptoken (MAXTOK) + character gtok, ngetch + + integer i, nlpar + + call skpblk + c = gtok (ptoken, MAXTOK) + if (c == LPAREN) + t = LPAREN # define (name, defn) + else { + t = BLANK # define name defn + call pbstr (ptoken) + } + call skpblk + if (gtok (token, toksiz) != ALPHA) + call baderr ("non-alphanumeric name.") + call skpblk + c = gtok (ptoken, MAXTOK) + if (t == BLANK) { # define name defn + call pbstr (ptoken) + i = 1 + repeat { + c = ngetch (c) + if (i > defsiz) + call baderr ("definition too long.") + defn (i) = c + i = i + 1 + } until (c == SHARP | c == NEWLINE | c == EOF) + if (c == SHARP) + call putbak (c) + } + else if (t == LPAREN) { # define (name, defn) + if (c != COMMA) + call baderr ("missing comma in define.") + # else got (name, + nlpar = 0 + for (i = 1; nlpar >= 0; i = i + 1) + if (i > defsiz) + call baderr ("definition too long.") + else if (ngetch (defn (i)) == EOF) + call baderr ("missing right paren.") + else if (defn (i) == LPAREN) + nlpar = nlpar + 1 + else if (defn (i) == RPAREN) + nlpar = nlpar - 1 + # else normal character in defn (i) + } + else + call baderr ("getdef is confused.") + defn (i - 1) = EOS + return + end diff --git a/unix/boot/spp/rpp/rpprat/gettok.r b/unix/boot/spp/rpp/rpprat/gettok.r new file mode 100644 index 00000000..8ae855db --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gettok.r @@ -0,0 +1,90 @@ +#-h- gettok 2076 local 12/01/80 15:54:09 +# gettok - get token. handles file inclusion and line numbers + include defs + +character function gettok (token, toksiz) + +character token (MAXTOK) +integer toksiz +include COMMON_BLOCKS +integer equal +character t, deftok +#character name(MAXNAME), t +#integer i, len, open, length + +string ssubr "x$subr" +string sfunc "x$func" +#string incl "include" + +# for (; level > 0; level = level - 1) { + + gettok = deftok (token, toksiz) + if (gettok != EOF) { + if (gettok == XPP_DIRECTIVE) { + if (equal (token, sfunc) == YES) { + call skpblk + t = deftok (fcname, MAXNAME) + call pbstr (fcname) + if (t != ALPHA) + call synerr ("Missing function name.") + call putbak (BLANK) + swvnum = 0 + swvlev = 0 + return + } else if (equal (token, ssubr) == YES) { + swvnum = 0 + swvlev = 0 + return + } else + return + } + return + } + + token (1) = EOF + token (2) = EOS + gettok = EOF + return +end + + +# -- Includes are now processed elsewhere + +# else if (equal (token, incl) == NO) +# return +# +# # process 'include' statements: +# call skpblk +# t = deftok (name, MAXNAME) +# if (t == SQUOTE | t == DQUOTE) { +# len = length (name) - 1 +# for (i = 1; i < len; i = i + 1) +# name (i) = name (i + 1) +# name (i) = EOS +# } +# i = length (name) + 1 +# if (level >= NFILES) +# call synerr ("includes nested too deeply.") +# else { +# infile (level + 1) = open (name, READ) +# linect (level + 1) = 0 +# if (infile (level + 1) == ERR) +# call synerr ("can't open include.") +# else { +# level = level + 1 +# if (fnamp + i <= MAXFNAMES) { +# call scopy (name, 1, fnames, fnamp) +# fnamp = fnamp + i # push file name stack +# } +# } +# } +# } +# if (level > 1) { # close include file pop file name stack +# call close (infile (level)) +# for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1) +# if (fnames (fnamp - 1) == EOS) +# break +# } + +# } + diff --git a/unix/boot/spp/rpp/rpprat/gnbtok.r b/unix/boot/spp/rpp/rpprat/gnbtok.r new file mode 100644 index 00000000..448a1aad --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gnbtok.r @@ -0,0 +1,19 @@ +#-h- gnbtok 237 local 12/01/80 15:54:09 +# gnbtok - get nonblank token + include defs + + character function gnbtok (token, toksiz) + character token (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character gettok + + call skpblk + repeat { + gnbtok = gettok (token, toksiz) + } until (gnbtok != BLANK) + + return + end diff --git a/unix/boot/spp/rpp/rpprat/gocode.r b/unix/boot/spp/rpp/rpprat/gocode.r new file mode 100644 index 00000000..26e201c4 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gocode.r @@ -0,0 +1,25 @@ +include defs + +# GOCODE - generate code for goto statement + +subroutine gocode + +character token (MAXTOK), t +character gnbtok +integer ctoi, i +include COMMON_BLOCKS + + t = gnbtok (token, MAXTOK) + if (t != DIGIT) + call synerr ("Invalid label for goto.") + else { + call outtab + i = 1 + call ogotos (ctoi(token,i), NO) + } + xfer = YES + + for (t=gnbtok(token,MAXTOK); t == NEWLINE; t=gnbtok(token,MAXTOK)) + ; + call pbstr (token) +end diff --git a/unix/boot/spp/rpp/rpprat/gtok.r b/unix/boot/spp/rpp/rpprat/gtok.r new file mode 100644 index 00000000..4cdb3d72 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/gtok.r @@ -0,0 +1,161 @@ +include defs + +# gtok - get token for Ratfor + + character function gtok (lexstr, toksiz) + character lexstr (MAXTOK) + integer toksiz + + include COMMON_BLOCKS + + character c + character ngetch + + integer i +# external index +# integer index + +# string digits "0123456789abcdefghijklmnopqrstuvwxyz" + + c = ngetch (lexstr (1)) + + if (c == BLANK | c == TAB) { + lexstr (1) = BLANK + while (c == BLANK | c == TAB) # compress many blanks to one + c = ngetch (c) + if (c == SHARP) + while (ngetch (c) != NEWLINE) # strip comments + ; + if (c != NEWLINE) + call putbak (c) + else + lexstr (1) = NEWLINE + lexstr (2) = EOS + gtok = lexstr (1) + return + } + + i = 1 + if (IS_LETTER(c)) { # alpha + gtok = ALPHA + if (c == LETX) { # "x$cccc" directive? + c = ngetch (lexstr(2)) + if (c == DOLLAR) { + gtok = XPP_DIRECTIVE + i = 2 + } + else + call putbak (c) + } + + for (; i < toksiz - 2; i=i+1) { + c = ngetch (lexstr(i+1)) + if (!IS_LETTER(c) & !IS_DIGIT(c) & c != UNDERLINE) + break + } + call putbak (c) + + } else if (IS_DIGIT(c)) { # digits + for (i=1; i < toksiz - 2; i=i+1) { + c = ngetch (lexstr (i + 1)) + if (!IS_DIGIT(c)) + break + } + call putbak (c) + gtok = DIGIT + } + +# The following is not needed since XPP does base conversion, and this caused +# fixed point overflow on a Data General machine. +# +# b = c - DIG0 # in case alternate base number +# for (i = 1; i < toksiz - 2; i = i + 1) { +# c = ngetch (lexstr (i + 1)) +# if (!IS_DIGIT(c)) +# break +# b = 10 * b + (c - DIG0) +# } +# if (c == RADIX & b >= 2 & b <= 36) { #n%ddd... +# n = 0 +# repeat { +# d = index (digits, clower (ngetch (c))) - 1 +# if (d < 0) +# break +# n = b * n + d +# } +# call putbak (c) +# i = itoc (n, lexstr, toksiz) +# } +# else +# call putbak (c) +# gtok = DIGIT +# } + + else if (c == LBRACK) { # allow [ for { + lexstr (1) = LBRACE + gtok = LBRACE + } + + else if (c == RBRACK) { # allow ] for } + lexstr (1) = RBRACE + gtok = RBRACE + } + + else if (c == DOLLAR) { # $( and $) now used by macro processor + if (ngetch (lexstr (2)) == LPAREN) { + i = 2 + gtok = LSTRIPC + } + else if (lexstr (2) == RPAREN) { + i = 2 + gtok = RSTRIPC + } + else { + call putbak (lexstr (2)) + gtok = DOLLAR + } + } + + else if (c == SQUOTE | c == DQUOTE) { + gtok = c + for (i = 2; ngetch (lexstr (i)) != lexstr (1); i = i + 1) { + if (lexstr (i) == UNDERLINE) + if (ngetch (c) == NEWLINE) { + while (c == NEWLINE | c == BLANK | c == TAB) + c = ngetch (c) + lexstr (i) = c + } + else + call putbak (c) + if (lexstr (i) == NEWLINE | i >= toksiz - 1) { + call synerr ("missing quote.") + lexstr (i) = lexstr (1) + call putbak (NEWLINE) + break + } + } + } + + else if (c == SHARP) { # strip comments + while (ngetch (lexstr (1)) != NEWLINE) + ; + gtok = NEWLINE + } + + else if (c == GREATER | c == LESS | c == NOT | c == BANG | + c == TILDE | c == CARET | c == EQUALS | c == AND | c == OR) { + call relate (lexstr, i) + gtok = c + } + + else + gtok = c + + if (i >= toksiz - 1) + call synerr ("token too long.") + lexstr (i + 1) = EOS + + # Note: line number accounting is now done in 'ngetch' + + return + end diff --git a/unix/boot/spp/rpp/rpprat/ifcode.r b/unix/boot/spp/rpp/rpprat/ifcode.r new file mode 100644 index 00000000..81855321 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifcode.r @@ -0,0 +1,17 @@ +#-h- ifcode 198 local 12/01/80 15:54:10 +# ifcode - generate initial code for if + include defs + + subroutine ifcode (lab) + integer lab + + include COMMON_BLOCKS + + integer labgen + + xfer = NO + lab = labgen (2) + call ifgo (lab) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/iferrc.r b/unix/boot/spp/rpp/rpprat/iferrc.r new file mode 100644 index 00000000..4fd77154 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/iferrc.r @@ -0,0 +1,85 @@ +include defs + +# IFERRC - Generate initial code for an IFERR statement. Used to provide +# error recovery for a statement or compound statement. + +subroutine iferrc (lab, sense) + +integer lab, sense +integer labgen, nlpar +character t, gettok, gnbtok, token(MAXTOK) +include COMMON_BLOCKS +string errpsh "call xerpsh" +string siferr "if (.not.xerpop()) " +string sifnoerr "if (xerpop()) " + + xfer = NO + lab = labgen (3) + + call outtab # "call errpsh" + call outstr (errpsh) + call outdon + + switch (gnbtok (token, MAXTOK)) { # "iferr (" or "iferr {" + case LPAREN: + call outtab + case LBRACE: + call pbstr (token) + esp = esp + 1 + if (esp >= MAXERRSTK) # not likely + call baderr ("Iferr statements nested too deeply.") + errstk(esp) = lab + return + default: + call synerr ("Missing left paren.") + return + } + + nlpar = 1 # process "iferr (.." + token(1) = EOS + + # Push handler on error stack temporarily so that "iferr (call error.." + # can be handled properly. + esp = esp + 1 + if (esp >= MAXERRSTK) # not likely + call baderr ("Iferr statements nested too deeply.") + errstk(esp) = 0 + + repeat { # output the statement + call outstr (token) + 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 if (t == SEMICOL) { + call outdon + call outtab + } else if (t == ALPHA) + call squash (token) + # else nothing special + } until (nlpar <= 0) + + esp = esp - 1 + ername = NO # ignore errchk + if (nlpar != 0) + call synerr ("Missing parenthesis in condition.") + else + call outdon + + call outtab # "if (errpop())" + if (sense == 1) + call outstr (siferr) + else + call outstr (sifnoerr) + call outgo (lab) # "... goto lab" + + call indent (1) + return +end diff --git a/unix/boot/spp/rpp/rpprat/ifgo.r b/unix/boot/spp/rpp/rpprat/ifgo.r new file mode 100644 index 00000000..da0e6647 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifgo.r @@ -0,0 +1,23 @@ +include defs + +# IFGO - generate "if (.not.(...)) goto lab" + +subroutine ifgo (lab) + +integer lab +include COMMON_BLOCKS +string ifnot "if (.not." +string serrchk ".and.(.not.xerflg)) " + + call outtab # get to column 7 + call outstr (ifnot) # " if (.not. " + call balpar # collect and output condition + if (ername == YES) # add error checking? + call outstr (serrchk) + else { + call outch (RPAREN) # " ) " + call outch (BLANK) + } + call outgo (lab) # " goto lab " + call errgo +end diff --git a/unix/boot/spp/rpp/rpprat/ifparm.r b/unix/boot/spp/rpp/rpprat/ifparm.r new file mode 100644 index 00000000..b2b5f706 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ifparm.r @@ -0,0 +1,31 @@ +#-h- ifparm 689 local 12/01/80 15:54:11 +# ifparm - determines if the defined symbol has arguments in its + include defs +# definition. This effects how the macro is expanded. + + integer function ifparm (strng) + character strng (ARB) + + character c + + external index + 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 diff --git a/unix/boot/spp/rpp/rpprat/indent.r b/unix/boot/spp/rpp/rpprat/indent.r new file mode 100644 index 00000000..e119c773 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/indent.r @@ -0,0 +1,12 @@ +include defs + +# INDENT -- Indent the output listing. + +subroutine indent (nlevels) + +integer nlevels +include COMMON_BLOCKS + + logical_column = logical_column + (nlevels * INDENT) + col = max(6, min(MAX_INDENT, logical_column)) +end diff --git a/unix/boot/spp/rpp/rpprat/initkw.r b/unix/boot/spp/rpp/rpprat/initkw.r new file mode 100644 index 00000000..c03bf2f2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/initkw.r @@ -0,0 +1,34 @@ +#-h- initkw 549 local 12/01/80 15:54:11 +# initkw - initialize tables and important global variables + include defs + + subroutine initkw + + include COMMON_BLOCKS + + pointer mktabl + + call dsinit (MEMSIZE) + deftbl = mktabl (1) # symbol table for definitions + call entdkw + rkwtbl = mktabl (1) # symbol table for Ratfor key words + call entrkw + fkwtbl = mktabl (0) # symbol table for Fortran key words + call entfkw + namtbl = mktabl (1) # symbol table for long identifiers + xpptbl = mktabl (1) # symbol table for xpp directives + call entxkw + gentbl = mktabl (0) # symbol table for generated identifiers + errtbl = NULL # table of names to be error checked + + label = FIRST_LABEL # starting statement label + smem(1) = EOS # haven't read in "mem.com" file yet + body = NO # not in procedure body to start + dbgout = NO # disable debug output by default + dbglev = 0 # file level if debug enabled + memflg = NO # haven't declared mem common yet + swinrg = NO # default range checking for switches + col = 6 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/labelc.r b/unix/boot/spp/rpp/rpprat/labelc.r new file mode 100644 index 00000000..86421d9b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/labelc.r @@ -0,0 +1,19 @@ +#-h- labelc 404 local 12/01/80 15:54:12 +# labelc - output statement number + include defs + + subroutine labelc (lexstr) + character lexstr (ARB) + + include COMMON_BLOCKS + + integer length, l + + xfer = NO # can't suppress goto's now + l = length (lexstr) + if (l >= 3 & l < 4) # possible conflict with pp-generated labels + call synerr ("Warning: statement labels 100 and above are reserved.") + call outstr (lexstr) + call outtab + return + end diff --git a/unix/boot/spp/rpp/rpprat/labgen.r b/unix/boot/spp/rpp/rpprat/labgen.r new file mode 100644 index 00000000..f110e963 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/labgen.r @@ -0,0 +1,13 @@ +#-h- labgen 189 local 12/01/80 15:54:12 +# labgen - generate n consecutive labels, return first one + include defs + + integer function labgen (n) + integer n + + include COMMON_BLOCKS + + labgen = label + label = label + (n / 10 + 1) * 10 + return + end diff --git a/unix/boot/spp/rpp/rpprat/lex.r b/unix/boot/spp/rpp/rpprat/lex.r new file mode 100644 index 00000000..bc8f7a27 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/lex.r @@ -0,0 +1,49 @@ +#-h- lex 543 local 12/01/80 15:54:12 +# lex - return lexical type of token + include defs + + integer function lex (lexstr) + character lexstr (MAXTOK) + + include COMMON_BLOCKS + + character gnbtok, t, c + + integer lookup, n + string sdefault "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 (lex == XPP_DIRECTIVE) + lex = LEXDECL + else if (lookup (lexstr, lex, rkwtbl) == YES) { + if (lex == LEXDEFAULT) { # "default:" + n = -1 + repeat { + c = ngetch (c) + n = n + 1 + } until (c != BLANK & c != TAB) + call putbak (c) + + t = gnbtok (lexstr, MAXTOK) + call pbstr (lexstr) + if (n > 0) + call putbak (BLANK) + call scopy (sdefault, 1, lexstr, 1) + if (t != COLON) + lex = LEXOTHER + } + } + else + lex = LEXOTHER + + return + end diff --git a/unix/boot/spp/rpp/rpprat/litral.r b/unix/boot/spp/rpp/rpprat/litral.r new file mode 100644 index 00000000..e9106559 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/litral.r @@ -0,0 +1,20 @@ +#-h- litral 316 local 12/01/80 15:54:13 +# litral - process literal Fortran line + include defs + + subroutine litral + + include COMMON_BLOCKS + + character ngetch + + # Finish off any left-over characters + if (outp > 0) + call outdwe + + for (outp = 1; ngetch (outbuf (outp)) != NEWLINE; outp = outp + 1) + ; + outp = outp - 1 + call outdwe + return + end diff --git a/unix/boot/spp/rpp/rpprat/lndict.r b/unix/boot/spp/rpp/rpprat/lndict.r new file mode 100644 index 00000000..42cf8d6a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/lndict.r @@ -0,0 +1,30 @@ +#-h- lndict 678 local 12/01/80 15:54:13 +# lndict - output long-name dictionary as a debugging aid + include defs + +subroutine lndict + +character sym (MAXTOK), c +ifdef (UPPERC, character cupper) +integer sctabl, length +pointer posn, locn +include COMMON_BLOCKS + + posn = 0 + while (sctabl (namtbl, sym, locn, posn) != EOF) + if (length(sym) > MAXIDLENGTH) { + ifdef (UPPERC, call outch (BIGC)) + ifnotdef (UPPERC, call outch (LETC)) + call outtab + for (; mem (locn) != EOS; locn = locn + 1) { + c = mem (locn) # kluge for people with LOGICAL*1 characters + ifdef (UPPERC, c = cupper (c)) + call outch (c) + } + call outch (BLANK) + call outch (BLANK) + call outstr (sym) + call outdon + } + return +end diff --git a/unix/boot/spp/rpp/rpprat/ludef.r b/unix/boot/spp/rpp/rpprat/ludef.r new file mode 100644 index 00000000..45876968 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ludef.r @@ -0,0 +1,29 @@ +#-h- ludef 495 local 12/01/80 15:54:29 +# ludef --- look up a defined identifier, return its definition + include defs + + integer function ludef (id, defn, table) + character id (ARB), defn (ARB) + pointer table + + include COMMON_BLOCKS + + integer i + integer lookup + + pointer locn + + ludef = lookup (id, locn, table) + if (ludef == YES) { + i = 1 + for (; mem (locn) != EOS; locn = locn + 1) { + defn (i) = mem (locn) + i = i + 1 + } + defn (i) = EOS + } + else + defn (1) = EOS + + return + end diff --git a/unix/boot/spp/rpp/rpprat/mapid.r b/unix/boot/spp/rpp/rpprat/mapid.r new file mode 100644 index 00000000..106a9335 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/mapid.r @@ -0,0 +1,19 @@ + +include defs + +# MAPID -- Map a long identifier. The new identifier is formed by +# concatenating the first MAXIDLENGTH-1 characters and the last character. + + +subroutine mapid (name) + +character name(MAXTOK) +integer i + + for (i=1; name(i) != EOS; i=i+1) + ; + if (i-1 > MAXIDLENGTH) { + name(MAXIDLENGTH) = name(i-1) + name(MAXIDLENGTH+1) = EOS + } +end diff --git a/unix/boot/spp/rpp/rpprat/ngetch.r b/unix/boot/spp/rpp/rpprat/ngetch.r new file mode 100644 index 00000000..26dce4de --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ngetch.r @@ -0,0 +1,34 @@ +#-h- ngetch 442 local 12/01/80 15:54:30 +# ngetch - get a (possibly pushed back) character + include defs + + character function ngetch (c) + character c + + include COMMON_BLOCKS + + integer getlin, n, i + + if (buf (bp) == EOS) + if (getlin (buf (PBPOINT), infile (level)) == EOF) + c = EOF + else { + c = buf (PBPOINT) + bp = PBPOINT + 1 + if (c == SHARP) { #check for "#!# nn" directive + if (buf(bp) == BANG & buf(bp+1) == SHARP) { + n = 0 + for (i=bp+3; buf(i) >= DIG0 & buf(i) <= DIG9; i=i+1) + n = n * 10 + buf(i) - DIG0 + linect (level) = n - 1 + } + } + linect (level) = linect (level) + 1 + } + else { + c = buf (bp) + bp = bp + 1 + } + + return (c) + end diff --git a/unix/boot/spp/rpp/rpprat/ogotos.r b/unix/boot/spp/rpp/rpprat/ogotos.r new file mode 100644 index 00000000..e20e7df0 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ogotos.r @@ -0,0 +1,20 @@ + +include defs + +# OGOTOS - Output "goto n", unconditionally. + + +subroutine ogotos (n, error_check) + +integer n, error_check +include COMMON_BLOCKS +string sgoto "goto " + + call outtab + call outstr (sgoto) + call outnum (n) + if (error_check == YES) + call outdwe + else + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/otherc.r b/unix/boot/spp/rpp/rpprat/otherc.r new file mode 100644 index 00000000..9a8451b8 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/otherc.r @@ -0,0 +1,18 @@ +#-h- otherc 284 local 12/01/80 15:54:30 +# otherc - output ordinary Fortran statement + include defs + + subroutine otherc (lexstr) + character lexstr(ARB) + + include COMMON_BLOCKS + + xfer = NO + call outtab + if (IS_LETTER(lexstr (1))) + call squash (lexstr) + call outstr (lexstr) + call eatup + call outdwe + return + end diff --git a/unix/boot/spp/rpp/rpprat/outch.r b/unix/boot/spp/rpp/rpprat/outch.r new file mode 100644 index 00000000..f7dfa99e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outch.r @@ -0,0 +1,51 @@ +include defs + +# outch - put one character into output buffer + +subroutine outch (c) + +character c, splbuf(SZ_SPOOLBUF+1) +integer i, ip, op, index +include COMMON_BLOCKS +external index +string break_chars " ),.+-*/(" + + # Process a continuation card. Try to break the card at a whitespace + # division, operator, or punctuation mark. + + if (outp >= 72) { + if (index (break_chars, c) > 0) # find break point + ip = outp + else { + for (ip=outp; ip >= 1; ip=ip-1) { + if (index (break_chars, outbuf(ip)) > 0) + break + } + } + + if (ip != outp & (outp-ip) < SZ_SPOOLBUF) { + op = 1 + for (i=ip+1; i <= outp; i=i+1) { # save chars + splbuf(op) = outbuf(i) + op = op + 1 + } + splbuf(op) = EOS + outp = ip + } else + splbuf(1) = EOS + + call outdon + + for (op=1; op < col; op=op+1) + outbuf(op) = BLANK + outbuf(6) = STAR + outp = col + for (ip=1; splbuf(ip) != EOS; ip=ip+1) { + outp = outp + 1 + outbuf(outp) = splbuf(ip) + } + } + + outp = outp + 1 # output character + outbuf(outp) = c +end diff --git a/unix/boot/spp/rpp/rpprat/outcon.r b/unix/boot/spp/rpp/rpprat/outcon.r new file mode 100644 index 00000000..90d5e636 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outcon.r @@ -0,0 +1,21 @@ +#-h- outcon 332 local 12/01/80 15:54:31 +# outcon - output "n continue" + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/outdon.r b/unix/boot/spp/rpp/rpprat/outdon.r new file mode 100644 index 00000000..5ea969bb --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outdon.r @@ -0,0 +1,58 @@ +#-h- outdon 257 local 12/01/80 15:54:31 +# outdon - finish off an output line + include defs + + subroutine outdon + + include COMMON_BLOCKS + + integer allblk + integer itoc, ip, op, i + character obuf(80) + string s_line "#line " + + # If dbgout is enabled output the "#line" statement. + if (dbgout == YES) { + if (body == YES | dbglev != level) { + op = 1 + for (ip=1; s_line(ip) != EOS; ip=ip+1) { + obuf(op) = s_line(ip) + op = op + 1 + } + + op = op + itoc (linect, obuf(op), 80-op+1) + obuf(op) = BLANK + op = op + 1 + obuf(op) = DQUOTE + op = op + 1 + + for (i=fnamp-1; i >= 1; i=i-1) + if (fnames(i-1) == EOS | i == 1) { # print file name + for (ip=i; fnames(ip) != EOS; ip=ip+1) { + obuf(op) = fnames(ip) + op = op + 1 + } + break + } + + obuf(op) = DQUOTE + op = op + 1 + obuf(op) = NEWLINE + op = op + 1 + obuf(op) = EOS + op = op + 1 + + call putlin (obuf, STDOUT) + dbglev = level + } + } + + # Output the program statement. + outbuf (outp + 1) = NEWLINE + outbuf (outp + 2) = EOS + if (allblk (outbuf) == NO) + call putlin (outbuf, STDOUT) + outp = 0 + + return + end diff --git a/unix/boot/spp/rpp/rpprat/outdwe.r b/unix/boot/spp/rpp/rpprat/outdwe.r new file mode 100644 index 00000000..d6ef22ce --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outdwe.r @@ -0,0 +1,13 @@ + +include defs + +# OUTDWE -- (outdon with error checking). +# Called by code generation routines to output a line of code, +# possibly followed by an error checking instruction. + + +subroutine outdwe + + call outdon + call errgo +end diff --git a/unix/boot/spp/rpp/rpprat/outgo.r b/unix/boot/spp/rpp/rpprat/outgo.r new file mode 100644 index 00000000..d4f54faa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outgo.r @@ -0,0 +1,13 @@ +#-h- outgo 239 local 12/01/80 15:54:31 +# outgo - output "goto n" + include defs + +subroutine outgo (n) + +integer n +include COMMON_BLOCKS + + if (xfer == YES) + return + call ogotos (n, NO) +end diff --git a/unix/boot/spp/rpp/rpprat/outnum.r b/unix/boot/spp/rpp/rpprat/outnum.r new file mode 100644 index 00000000..5286971e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outnum.r @@ -0,0 +1,24 @@ +#-h- outnum 381 local 12/01/80 15:54:32 +# outnum - output decimal number + include defs + + subroutine outnum (n) + integer n + + character chars (MAXCHARS) + + integer i, m + + m = iabs (n) + i = 0 + repeat { + i = i + 1 + chars (i) = mod (m, 10) + DIG0 + m = m / 10 + } until (m == 0 | i >= MAXCHARS) + if (n < 0) + call outch (MINUS) + for ( ; i > 0; i = i - 1) + call outch (chars (i)) + return + end diff --git a/unix/boot/spp/rpp/rpprat/outstr.r b/unix/boot/spp/rpp/rpprat/outstr.r new file mode 100644 index 00000000..248bb39c --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outstr.r @@ -0,0 +1,33 @@ +#-h- outstr 687 local 12/01/80 15:54:32 +# outstr - output string; handles quoted literals + include defs + + subroutine outstr (str) + character str (ARB) + + character c + ifdef (UPPERC, character cupper) + + integer i, j + + for (i = 1; str (i) != EOS; i = i + 1) { + c = str (i) + if (c != SQUOTE & c != DQUOTE) { + # produce upper case fortran, if desired + ifdef (UPPERC, + c = cupper (c) + ) + call outch (c) + } + else { + i = i + 1 + for (j = i; str (j) != c; j = j + 1) # find end + ; + call outnum (j - i) + call outch (BIGH) + for ( ; i < j; i = i + 1) + call outch (str (i)) + } + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/outtab.r b/unix/boot/spp/rpp/rpprat/outtab.r new file mode 100644 index 00000000..94f38c69 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/outtab.r @@ -0,0 +1,12 @@ +#-h- outtab 140 local 12/01/80 15:54:32 +# outtab - get past column 6 + include defs + + subroutine outtab + + include COMMON_BLOCKS + + while (outp < col) + call outch (BLANK) + return + end diff --git a/unix/boot/spp/rpp/rpprat/parse.r b/unix/boot/spp/rpp/rpprat/parse.r new file mode 100644 index 00000000..676ee759 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/parse.r @@ -0,0 +1,144 @@ +include defs + +# PARSE - parse Ratfor source program + +subroutine parse + +include COMMON_BLOCKS +character lexstr(MAXTOK) +integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token, i, t +integer lex +logical push_stack + + sp = 1 + lextyp(1) = EOF + + for (token = lex(lexstr); token != EOF; token = lex(lexstr)) { + push_stack = .false. + + switch (token) { + case LEXIF: + call ifcode (lab) + push_stack = .true. + case LEXIFERR: + call iferrc (lab, 1) + push_stack = .true. + case LEXIFNOERR: + call iferrc (lab, 0) + push_stack = .true. + case LEXDO: + call docode (lab) + push_stack = .true. + case LEXWHILE: + call whilec (lab) + push_stack = .true. + case LEXFOR: + call forcod (lab) + push_stack = .true. + case LEXREPEAT: + call repcod (lab) + push_stack = .true. + case LEXSWITCH: + call swcode (lab) + push_stack = .true. + case LEXCASE, 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) + case LEXDIGITS: + call labelc (lexstr) + push_stack = .true. + case LEXELSE: + t = lextyp(sp) + if (t == LEXIF | t == LEXIFERR | t == LEXIFNOERR) + call elseif (labval(sp)) + else + call synerr ("Illegal else.") + + t = lex (lexstr) # check for "else if" + call pbstr (lexstr) + if (t == LEXIF | t == LEXIFERR | t == LEXIFNOERR) { + call indent (-1) # cancel out indent +1 + token = LEXIFELSE # prevent -indent at end + } + push_stack = .true. + case LEXTHEN: + if (lextyp(sp) == LEXIFERR | lextyp(sp) == LEXIFNOERR) { + call thenco (lextyp(sp), labval(sp)) + lab = labval(sp) + token = lextyp(sp) + sp = sp - 1 # cancel out subsequent push + } else + call synerr ("Illegal 'then' clause in iferr statement.") + push_stack = .true. + case LEXLITERAL: + call litral + case LEXERRCHK: + call errchk + case LEXBEGIN: + call beginc + case LEXEND: + call endcod (lexstr) + if (sp != 1) { + call synerr ("Missing right brace or 'begin'.") + sp = 1 + } + default: + if (token == LBRACE) + push_stack = .true. + else if (token == LEXDECL) + call declco (lexstr) + } + + if (push_stack) { + if (body == NO) { + call synerr ("Missing 'begin' keyword.") + call beginc + } + 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) + token = LEXRBRACE + + switch (token) { + case LEXOTHER: + call otherc (lexstr) + case LEXBREAK, LEXNEXT: + call brknxt (sp, lextyp, labval, token) + case LEXRETURN: + call retcod + case LEXGOTO: + call gocode + case LEXSTRING: + if (body == NO) + call strdcl + else + call otherc (lexstr) + case LEXRBRACE: + 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.") + } + + token = lex (lexstr) # peek at next token + call pbstr (lexstr) + call unstak (sp, lextyp, labval, token) + } + } + + if (sp != 1) + call synerr ("unexpected EOF.") +end diff --git a/unix/boot/spp/rpp/rpprat/pbnum.r b/unix/boot/spp/rpp/rpprat/pbnum.r new file mode 100644 index 00000000..e77b5db6 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/pbnum.r @@ -0,0 +1,20 @@ +#-h- pbnum 304 local 12/01/80 15:54:33 +# pbnum - convert number to string, push back on input + include defs + + subroutine pbnum (n) + integer n + + integer m, num + integer mod + + string digits '0123456789' + + num = n + repeat { + m = mod (num, 10) + call putbak (digits (m + 1)) + num = num / 10 + } until (num == 0) + return + end diff --git a/unix/boot/spp/rpp/rpprat/pbstr.r b/unix/boot/spp/rpp/rpprat/pbstr.r new file mode 100644 index 00000000..9c2234de --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/pbstr.r @@ -0,0 +1,69 @@ +include defs + +# PBSTR -- Push string back onto input. + +subroutine pbstr (s) + +character s(ARB) # string to be pushed back. +integer lenstr, i +integer length + +#begin + lenstr = length (s) + + # We are called to push back tokens returned by GTOK, which converts + # the ratfor relational operators >, >=, &, etc. into their Fortran + # equivalents .gt., .ge., .and., and so on. This conversion must be + # reversed in the push back to prevent macro expansion from operating + # on the strings "gt", "ge, "and", etc. This is a stupid way to + # handle this but this ratfor code (which was free) is a hopeless mess + # already anyhow. + + if (s(1) == PERIOD & s(lenstr) == PERIOD) + if (lenstr == 4) { + if (s(2) == LETG) { + if (s(3) == LETT) { # .gt. + call putbak (GREATER) + return + } else if (s(3) == LETE) { # .ge. + # Note chars are pushed back in + # reverse order. + call putbak (EQUALS) + call putbak (GREATER) + return + } + } else if (s(2) == LETL) { + if (s(3) == LETT) { # .lt. + call putbak (LESS) + return + } else if (s(3) == LETE) { # .le. + call putbak (EQUALS) + call putbak (LESS) + return + } + } else if (s(2) == LETE & s(3) == LETQ) { + call putbak (EQUALS) # .eq. + call putbak (EQUALS) + return + } else if (s(2) == LETN & s(3) == LETE) { + call putbak (EQUALS) # .ne. + call putbak (BANG) + return + } else if (s(2) == LETO & s(3) == LETR) { + call putbak (OR) # .or. + return + } + } else if (lenstr == 5) { + if (s(2) == LETN & s(3) == LETO & s(4) == LETT) { + call putbak (BANG) # .not. + return + } else if (s(2) == LETA & s(3) == LETN & s(4) == LETD) { + call putbak (AND) # .and. + return + } + } + + # Push back an arbitrary string. + for (i=lenstr; i > 0; i=i-1) + call putbak (s(i)) +end diff --git a/unix/boot/spp/rpp/rpprat/poicod.r b/unix/boot/spp/rpp/rpprat/poicod.r new file mode 100644 index 00000000..7b31bf80 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/poicod.r @@ -0,0 +1,56 @@ +include defs + +# POICOD -- Called to process a declaration of type "pointer". + +subroutine poicod (declare_variable) + +integer declare_variable +include COMMON_BLOCKS +string spointer XPOINTER + +# Fortran declarations for the MEM common. +string p1 "logical Memb(1)" +string p2 "integer*2 Memc(1)" +string p3 "integer*2 Mems(1)" +string p4 "integer Memi(1)" +string p5 "integer Meml(1)" +string p6 "real Memr(1)" +string p7 "double precision Memd(1)" +string p8 "complex Memx(1)" +string p9 "equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx)" +string pa "common /Mem/ Memd" + + # Output declarations only once per procedure declarations section. + # The flag memflg is cleared when processing of a procedure begins. + + if (memflg == NO) { + call poidec (p1) + call poidec (p2) + call poidec (p3) + call poidec (p4) + call poidec (p5) + call poidec (p6) + call poidec (p7) + call poidec (p8) + call poidec (p9) + call poidec (pa) + memflg = YES + } + + if (declare_variable == YES) { + call outtab + call outstr (spointer) + } +end + + +# POIDEC -- Output a poicod declaration statement. + +subroutine poidec (str) + +character str + + call outtab + call outstr (str) + call outdon +end diff --git a/unix/boot/spp/rpp/rpprat/push.r b/unix/boot/spp/rpp/rpprat/push.r new file mode 100644 index 00000000..7d0c3374 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/push.r @@ -0,0 +1,13 @@ +#-h- push 249 local 12/01/80 15:54:34 +# push - push ep onto argstk, return new pointer ap + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/putbak.r b/unix/boot/spp/rpp/rpprat/putbak.r new file mode 100644 index 00000000..b88a3f11 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/putbak.r @@ -0,0 +1,18 @@ +#-h- putbak 254 local 12/01/80 15:54:34 +# putbak - push character back onto input + include defs + + subroutine putbak (c) + character c + + include COMMON_BLOCKS + + if (bp <= 1) + call baderr ("too many characters pushed back.") + else { + bp = bp - 1 + buf (bp) = c + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/putchr.r b/unix/boot/spp/rpp/rpprat/putchr.r new file mode 100644 index 00000000..b39eeadf --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/putchr.r @@ -0,0 +1,15 @@ +#-h- putchr 233 local 12/01/80 15:54:34 +# putchr - put single char into eval stack + include defs + + subroutine putchr (c) + character c + + include COMMON_BLOCKS + + if (ep > EVALSIZE) + call baderr ('evaluation stack overflow.') + evalst (ep) = c + ep = ep + 1 + return + end diff --git a/unix/boot/spp/rpp/rpprat/puttok.r b/unix/boot/spp/rpp/rpprat/puttok.r new file mode 100644 index 00000000..2cdcf6d2 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/puttok.r @@ -0,0 +1,13 @@ +#-h- puttok 198 local 12/01/80 15:54:34 +# puttok-put token into eval stack + include defs + + subroutine puttok (str) + character str (MAXTOK) + + integer i + + for (i = 1; str (i) != EOS; i = i + 1) + call putchr (str (i)) + return + end diff --git a/unix/boot/spp/rpp/rpprat/ratfor.r b/unix/boot/spp/rpp/rpprat/ratfor.r new file mode 100644 index 00000000..f2f847fd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ratfor.r @@ -0,0 +1,70 @@ +#-h- ratfor 4496 local 12/01/80 15:53:43 +# Ratfor preprocessor + include defs + + subroutine ratfor + +# DRIVER(ratfor) Not used; RPP has a C main. + + include COMMON_BLOCKS + + integer i, n + integer getarg, open + + character arg (FILENAMESIZE) + + STDEFNS # define standard definitions file + + call initkw # initialize variables + + # Read file containing standard definitions + # If this isn't desired, define (STDEFNS,"") + + if (defns (1) != EOS) { + infile (1) = open (defns, READ) + if (infile (1) == ERR) + call remark ("can't open standard definitions file.") + else { + call finit + call parse + call close (infile (1)) + } + } + + n = 1 + for (i=1; getarg(i,arg,FILENAMESIZE) != EOF; i=i+1) { + n = n + 1 + call query ("usage: ratfor [-g] [files] >outfile.") + if (arg(1) == MINUS & arg(2) == LETG & arg(3) == EOS) { + dbgout = YES + next + } else if (arg(1) == MINUS & arg(2) == EOS) { + infile(1) = STDIN + call finit + } else { + infile(1) = open (arg, READ) + if (infile(1) == ERR) { + call cant (arg) + } else { #save file name for error messages + call finit + call scopy (arg, 1, fnames, 1) + for (fnamp=1; fnames(fnamp) != EOS; fnamp=fnamp+1) + if (fnames(fnamp) == PERIOD & fnames(fnamp+1) == LETR) + fnames(fnamp+1) = LETX + } + } + call parse + if (infile (1) != STDIN) + call close (infile (1)) + } + + if (n == 1) { # no files given on command line, use STDIN + infile (1) = STDIN + call finit + call parse + } + + call lndict + +# DRETURN + end diff --git a/unix/boot/spp/rpp/rpprat/relate.r b/unix/boot/spp/rpp/rpprat/relate.r new file mode 100644 index 00000000..50a04025 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/relate.r @@ -0,0 +1,59 @@ +#-h- relate 1276 local 12/01/80 15:54:35 +# relate - convert relational shorthands into long form + include defs + + subroutine relate (token, last) + character token (ARB) + integer last + + character ngetch + + integer length + + if (ngetch (token (2)) != EQUALS) { + call putbak (token (2)) + token (3) = LETT + } + else + token (3) = LETE + token (4) = PERIOD + token (5) = EOS + token (6) = EOS # for .not. and .and. + if (token (1) == GREATER) + token (2) = LETG + else if (token (1) == LESS) + token (2) = LETL + else if (token (1) == NOT | token (1) == BANG | + token (1) == CARET | token (1) == TILDE) { + if (token (2) != EQUALS) { + token (3) = LETO + token (4) = LETT + token (5) = PERIOD + } + token (2) = LETN + } + else if (token (1) == EQUALS) { + if (token (2) != EQUALS) { + token (2) = EOS + last = 1 + return + } + token (2) = LETE + token (3) = LETQ + } + else if (token (1) == AND) { + token (2) = LETA + token (3) = LETN + token (4) = LETD + token (5) = PERIOD + } + else if (token (1) == OR) { + token (2) = LETO + token (3) = LETR + } + else # can't happen + token (2) = EOS + token (1) = PERIOD + last = length (token) + return + end diff --git a/unix/boot/spp/rpp/rpprat/repcod.r b/unix/boot/spp/rpp/rpprat/repcod.r new file mode 100644 index 00000000..e2fd40aa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/repcod.r @@ -0,0 +1,16 @@ +#-h- repcod 262 local 12/01/80 15:54:35 +# repcod - generate code for beginning of repeat + include defs + + 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 + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/retcod.r b/unix/boot/spp/rpp/rpprat/retcod.r new file mode 100644 index 00000000..3490016d --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/retcod.r @@ -0,0 +1,30 @@ +#-h- retcod 580 local 12/01/80 15:54:35 +# retcod - generate code for return + include defs + + subroutine retcod + + character token (MAXTOK), t + character gnbtok + include COMMON_BLOCKS + + t = gnbtok (token, MAXTOK) + if (t != NEWLINE & t != SEMICOL & t != RBRACE) { + call pbstr (token) + call outtab + call scopy (fcname, 1, token, 1) + call squash (token) + call outstr (token) + call outch (BLANK) + call outch (EQUALS) + call outch (BLANK) + call eatup + call outdon + } + else if (t == RBRACE) + call pbstr (token) + call outtab + call ogotos (retlab, NO) + xfer = YES + return + end diff --git a/unix/boot/spp/rpp/rpprat/sdupl.r b/unix/boot/spp/rpp/rpprat/sdupl.r new file mode 100644 index 00000000..968bfebd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/sdupl.r @@ -0,0 +1,25 @@ +#-h- sdupl 374 local 12/01/80 15:55:03 +# sdupl --- duplicate a string in dynamic storage space + include defs + + pointer function sdupl (str) + character str (ARB) + + DS_DECL(mem, MEMSIZE) + + integer i + integer length + + pointer j + pointer dsget + + j = dsget (length (str) + 1) + sdupl = j + for (i = 1; str (i) != EOS; i = i + 1) { + mem (j) = str (i) + j = j + 1 + } + mem (j) = EOS + + return + end diff --git a/unix/boot/spp/rpp/rpprat/skpblk.r b/unix/boot/spp/rpp/rpprat/skpblk.r new file mode 100644 index 00000000..3badc3e9 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/skpblk.r @@ -0,0 +1,17 @@ +#-h- skpblk 247 local 12/01/80 15:55:04 +# skpblk - skip blanks and tabs in current input file + include defs + + subroutine skpblk + + include COMMON_BLOCKS + + character c + character ngetch + + for (c = ngetch (c); c == BLANK | c == TAB; c = ngetch (c)) + ; + + call putbak (c) + return + end diff --git a/unix/boot/spp/rpp/rpprat/squash.r b/unix/boot/spp/rpp/rpprat/squash.r new file mode 100644 index 00000000..9990fe1a --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/squash.r @@ -0,0 +1,53 @@ +include defs + +# SQUASH - convert a long or special identifier into a Fortran variable + +subroutine squash (id) + +character id(MAXTOK) +integer junk, i, j +integer lookup, ludef +character newid(MAXTOK), recdid(MAXTOK) +include COMMON_BLOCKS + + # identify names for which error checking is to be performed + if (body == YES & errtbl != NULL & ername == NO) + if (lookup (id, junk, errtbl) == YES) + ername = YES + + j = 1 + for (i=1; id(i) != EOS; i=i+1) # copy, delete '_' + if (IS_LETTER(id(i)) | IS_DIGIT(id(i))) { + newid(j) = id(i) + j = j + 1 + } + newid(j) = EOS + + # done if ordinary (short) Fortran variable + if (i-1 < MAXIDLENGTH & i == j) + return + +# Otherwise, the identifier (1) is longer than Fortran allows, +# (2) contains special characters (_ or .), or (3) is the maximum +# length permitted by the Fortran compiler. The first two cases +# obviously call for name conversion; the last case may require 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 mapid (newid) # try standard mapping + if (lookup (newid, junk, gentbl) == YES) { + call synerr ("Warning: identifier mapping not unique.") + call uniqid (newid) + } + call entdef (newid, id, gentbl) + + call entdef (id, newid, namtbl) # record it for posterity + call scopy (newid, 1, id, 1) # substitute it for the old one +end diff --git a/unix/boot/spp/rpp/rpprat/strdcl.r b/unix/boot/spp/rpp/rpprat/strdcl.r new file mode 100644 index 00000000..03b04afc --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/strdcl.r @@ -0,0 +1,96 @@ +#-h- strdcl 2575 local 12/01/80 15:55:05 +# strdcl - generate code for string declaration + include defs + + subroutine strdcl + + include COMMON_BLOCKS + + character t, token (MAXTOK), dchar (MAXTOK) + character gnbtok + + integer i, j, k, n, len + integer length, ctoi, lex + + string char "integer*2/" + string dat "data " + string eoss "0/" + + t = gnbtok (token, MAXTOK) + if (t != ALPHA) + call synerr ("missing string token.") + call squash (token) + call outtab + call pbstr (char) # use defined meaning of "character" + repeat { + t = gnbtok (dchar, MAXTOK) + if (t == SLASH) + break + call outstr (dchar) + } + call outch (BLANK) # separator in declaration + call outstr (token) + call addstr (token, sbuf, sbp, SBUFSIZE) # save for later + call addchr (EOS, sbuf, sbp, SBUFSIZE) + if (gnbtok (token, MAXTOK) != LPAREN) { # make size same as initial value + len = length (token) + 1 + if (token (1) == SQUOTE | token (1) == DQUOTE) + len = len - 2 + } + else { # form is string name (size) init + t = gnbtok (token, MAXTOK) + i = 1 + len = ctoi (token, i) + if (token (i) != EOS) + call synerr ("invalid string size.") + if (gnbtok (token, MAXTOK) != RPAREN) + call synerr ("missing right paren.") + else + t = gnbtok (token, MAXTOK) + } + call outch (LPAREN) + call outnum (len) + call outch (RPAREN) + call outdon + if (token (1) == SQUOTE | token (1) == DQUOTE) { + len = length (token) + token (len) = EOS + call addstr (token (2), sbuf, sbp, SBUFSIZE) + } + else + call addstr (token, sbuf, sbp, SBUFSIZE) + call addchr (EOS, sbuf, sbp, SBUFSIZE) + t = lex (token) # peek at next token + call pbstr (token) + if (t != LEXSTRING) { # dump accumulated data statements + for (i = 1; i < sbp; i = j + 1) { + call outtab + call outstr (dat) + k = 1 + for (j = i + length (sbuf (i)) + 1; ; j = j + 1) { + if (k > 1) + call outch (COMMA) + call outstr (sbuf (i)) + call outch (LPAREN) + call outnum (k) + call outch (RPAREN) + call outch (SLASH) + if (sbuf (j) == EOS) + break + n = sbuf (j) + call outnum (n) + call outch (SLASH) + k = k + 1 + } + call pbstr (eoss) # use defined meaning of EOS + repeat { + t = gnbtok (token, MAXTOK) + call outstr (token) + } until (t == SLASH) + call outdon + } + sbp = 1 + } + + return + end diff --git a/unix/boot/spp/rpp/rpprat/swcode.r b/unix/boot/spp/rpp/rpprat/swcode.r new file mode 100644 index 00000000..348f8de3 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swcode.r @@ -0,0 +1,44 @@ +#-h- swcode 746 local 12/01/80 15:55:06 +# swcode - generate code for beginning of switch statement + include defs + + subroutine swcode (lab) + integer lab + + include COMMON_BLOCKS + + character tok (MAXTOK) + + integer labgen, gnbtok + + lab = labgen (2) + swvnum = swvnum + 1 + swvlev = swvlev + 1 + if (swvlev > MAXSWNEST) + call baderr ("switches nested too deeply.") + swvstk(swvlev) = swvnum + + 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 (swvnum) + call outch (EQUALS) + call balpar + call outdwe + call outgo (lab) # goto L + call indent (1) + xfer = YES + while (gnbtok (tok, MAXTOK) == NEWLINE) + ; + if (tok (1) != LBRACE) { + call synerr ("missing left brace in switch statement.") + call pbstr (tok) + } + return + end diff --git a/unix/boot/spp/rpp/rpprat/swend.r b/unix/boot/spp/rpp/rpprat/swend.r new file mode 100644 index 00000000..86088ddd --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swend.r @@ -0,0 +1,106 @@ +#-h- swend 2714 local 12/01/80 15:55:07 +# swend - finish off switch statement; generate dispatch code + include defs + + subroutine swend (lab) + integer lab + + include COMMON_BLOCKS + + integer lb, ub, n, i, j, swn + + 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." + + swn = swvstk(swvlev) #get switch variable number, SWnnnn + swvlev = max(0, swvlev - 1) + + 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 indent (-1) + call outcon (lab) # L continue + call indent (1) + if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table + if (lb != 1) { # L Innn=Innn-lb+1 + call outtab + call swvar (swn) + call outch (EQUALS) + call swvar (swn) + if (lb < 1) + call outch (PLUS) + call outnum (-lb + 1) + call outdon + } + if (swinrg == NO) { + call outtab # if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default + call outstr (sif) + call swvar (swn) + call outstr (slt) + call swvar (swn) + call outstr (sgt) + call outnum (ub - lb + 1) + call outch (RPAREN) + call outch (BLANK) + 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 (swn) + 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 (swn) + 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 (swn) + call outstr (sle) + call outnum (swstak (i + 1)) + } + call outch (RPAREN) # ) goto ... + call outch (BLANK) + call outgo (swstak (i + 2)) + } + if (lab + 1 != swstak (swtop + 2)) + call outgo (swstak (swtop + 2)) + } + call indent (-1) + call outcon (lab + 1) # L+1 continue + swlast = swtop # pop switch stack + swtop = swstak (swtop) + swinrg = NO + return + end diff --git a/unix/boot/spp/rpp/rpprat/swvar.r b/unix/boot/spp/rpp/rpprat/swvar.r new file mode 100644 index 00000000..df8da344 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/swvar.r @@ -0,0 +1,22 @@ +#-h- swvar 157 local 12/01/80 15:55:08 +# swvar - output switch variable SWnnnn, where nnnn = lab +# (modified aug82 dct to permit declaration of switch variable) + + include defs + + subroutine swvar (lab) + integer lab, i, labnum, ndigits + + ifnotdef (UPPERC, call outch (LETS)) + ifdef (UPPERC, call outch (BIGS)) + ifnotdef (UPPERC, call outch (LETW)) + ifdef (UPPERC, call outch (BIGW)) + + labnum = lab + for (ndigits=0; labnum > 0; labnum=labnum/10) + ndigits = ndigits + 1 + for (i=3; i <= 6 - ndigits; i=i+1) + call outch (DIG0) + call outnum (lab) + return + end diff --git a/unix/boot/spp/rpp/rpprat/synerr.r b/unix/boot/spp/rpp/rpprat/synerr.r new file mode 100644 index 00000000..80bee91b --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/synerr.r @@ -0,0 +1,37 @@ +#-h- synerr 703 local 12/01/80 15:55:08 +# synerr --- report non-fatal error + include defs + + subroutine synerr (msg) + + character msg +# character*(*) msg + + include COMMON_BLOCKS + character lc (MAXCHARS) + + integer i, junk + integer itoc + + string of " of " + string errmsg "Error on 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 | i == 1) { # print file name + call putlin (of, ERROUT) + call putlin (fnames (i), ERROUT) + break + } + + call putch (COLON, ERROUT) + call putch (BLANK, ERROUT) + call remark (msg) + return + end diff --git a/unix/boot/spp/rpp/rpprat/thenco.r b/unix/boot/spp/rpp/rpprat/thenco.r new file mode 100644 index 00000000..1b4a812e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/thenco.r @@ -0,0 +1,25 @@ + +include defs + +# THENCO -- Generate code for the "then" part of a compound IFERR statement. + + +subroutine thenco (tok, lab) + +integer lab, tok +include COMMON_BLOCKS +string siferr "if (.not.xerpop()) " +string sifnoerr "if (xerpop()) " + + xfer = NO + call outnum (lab+2) + call outtab + if (tok == LEXIFERR) + call outstr (siferr) + else + call outstr (sifnoerr) + call outgo (lab) + esp = esp - 1 # pop error stack + call indent (1) + return +end diff --git a/unix/boot/spp/rpp/rpprat/ulstal.r b/unix/boot/spp/rpp/rpprat/ulstal.r new file mode 100644 index 00000000..bff4e19e --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/ulstal.r @@ -0,0 +1,15 @@ +#-h- ulstal 268 local 12/01/80 15:55:09 +# ulstal - install lower and upper case versions of symbol + include defs + + 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 diff --git a/unix/boot/spp/rpp/rpprat/uniqid.r b/unix/boot/spp/rpp/rpprat/uniqid.r new file mode 100644 index 00000000..6187fa86 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/uniqid.r @@ -0,0 +1,49 @@ +#-h- uniqid 1825 local 12/01/80 15:55:09 +# uniqid - convert an identifier to one never before seen + include defs + +subroutine uniqid (id) + +character id (MAXTOK) +integer i, j, junk, idchl +external index +integer lookup, index, length +character start (MAXIDLENGTH) +include COMMON_BLOCKS +string idch "0123456789abcdefghijklmnopqrstuvwxyz" # legal id characters + + # Pad the identifer out to length 6 with FILLCHARs: + for (i = 1; id (i) != EOS; i = i + 1) + ; + for (; i <= MAXIDLENGTH; i = i + 1) + id (i) = FILLCHAR + i = MAXIDLENGTH + 1 + id (i) = EOS + id (i - 1) = FILLCHAR + + # Look it up in the table of generated names. If it's not there, + # it's unique. If it is there, it has been generated previously; + # modify it and try again. Assume this procedure always succeeds, + # since to fail implies there are very, very many identifiers in + # the symbol table. + # Note that we must preserve the first and last characters of the + # id, so as not to disturb implicit typing and to provide a flag + # to catch potentially conflicting user-defined identifiers without + # a lookup. + + if (lookup (id, junk, gentbl) == YES) { # (not very likely) + idchl = length (idch) + for (i = 2; i < MAXIDLENGTH; i = i + 1) + start (i) = id (i) + repeat { # until we get a unique id + for (i = MAXIDLENGTH - 1; i > 1; i = i - 1) { + j = mod (index (idch, id (i)), idchl) + 1 + id (i) = idch (j) + if (id (i) != start (i)) + break + } + if (i == 1) + call baderr ("cannot make identifier unique.") + } until (lookup (id, junk, gentbl) == NO) + } +end diff --git a/unix/boot/spp/rpp/rpprat/unstak.r b/unix/boot/spp/rpp/rpprat/unstak.r new file mode 100644 index 00000000..ec8a6eef --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/unstak.r @@ -0,0 +1,42 @@ +include defs + +# unstak - unstack at end of statement + +define IFSTMT 999 + + +subroutine unstak (sp, lextyp, labval, token) + +integer labval(MAXSTACK), lextyp(MAXSTACK) +integer sp, token, type + + for (; sp > 1; sp=sp-1) { + type = lextyp(sp) + if ((type == LEXIFERR | type == LEXIFNOERR) & token == LEXTHEN) + break + if (type == LEXIF | type == LEXIFERR | type == LEXIFNOERR) + type = IFSTMT + if (type == LBRACE | type == LEXSWITCH) + break + if (type == IFSTMT & token == LEXELSE) + break + + if (type == IFSTMT) { + call indent (-1) + call outcon (labval(sp)) + } else if (type == LEXELSE | type == LEXIFELSE) { + if (sp > 2) + sp = sp - 1 + if (type != LEXIFELSE) + call indent (-1) + call outcon (labval(sp) + 1) + } else if (type == LEXDO) + call dostat (labval(sp)) + else if (type == LEXWHILE) + call whiles (labval(sp)) + else if (type == LEXFOR) + call fors (labval(sp)) + else if (type == LEXREPEAT) + call untils (labval(sp), token) + } +end diff --git a/unix/boot/spp/rpp/rpprat/untils.r b/unix/boot/spp/rpp/rpprat/untils.r new file mode 100644 index 00000000..b784fab5 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/untils.r @@ -0,0 +1,26 @@ +#-h- untils 397 local 12/01/80 15:55:11 +# untils - generate code for until or end of repeat + include defs + + 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 indent (-1) + call outcon (lab + 1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/whilec.r b/unix/boot/spp/rpp/rpprat/whilec.r new file mode 100644 index 00000000..5dc0fd01 --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/whilec.r @@ -0,0 +1,17 @@ +#-h- whilec 262 local 12/01/80 15:55:11 +# whilec - generate code for beginning of while + include defs + + subroutine whilec (lab) + + integer lab + integer labgen + include COMMON_BLOCKS + + call outcon (0) # unlabeled continue, in case there was a label + lab = labgen (2) + call outnum (lab) + call ifgo (lab + 1) + call indent (1) + return + end diff --git a/unix/boot/spp/rpp/rpprat/whiles.r b/unix/boot/spp/rpp/rpprat/whiles.r new file mode 100644 index 00000000..af5679fa --- /dev/null +++ b/unix/boot/spp/rpp/rpprat/whiles.r @@ -0,0 +1,14 @@ +#-h- whiles 148 local 12/01/80 15:55:12 +# whiles - generate code for end of while + include defs + + subroutine whiles (lab) + + integer lab + include COMMON_BLOCKS + + call outgo (lab) + call indent (-1) + call outcon (lab + 1) + return + end |