#-h- cdefio           297  asc  28-apr-81 00:20:25  [002,100]
  ## Preprocessor common block to hold input characters
  # Put on a file called 'cdefio'
  # Used by ratfor preprocessor, macro, roff, form, and shell tools
  
 common /cdefio/ bp, buf(BUFSIZE)
    integer bp      # next available character; init = 0
    character buf   # pushed-back characters
#-h- cfname           219  asc  28-apr-81 00:20:26  [002,100]
 ## Preprocessor common block used to hold current function name
 #  Put on a file named 'cfname'
 #  Used by ratfor preprocessor
 
 common /cfname/ fcname(MAXNAME)
   character fcname   # text of current function name
#-h- cfor             273  asc  28-apr-81 00:20:27  [002,100]
 ## Preprocessor common block to hold info about 'for' statement
 #  Put on a file named 'cfor'
 #  Used by ratfor preprocessor
 
 common /cfor/ fordep, forstk(MAXFORSTK)
   integer fordep   # current depth of for statements
   character forstk   # stack of reinit strings
#-h- cgoto            205  asc  28-apr-81 00:20:28  [002,100]
 ## Preprocessor common block used to hold 'goto' flag
 #  Put on a file named 'cgoto'
 #  Used by ratfor preprocessor
 
 common /cgoto/ xfer
   integer xfer      # YES if just made transfer, NO otherwise
#-h- clabel           202  asc  28-apr-81 00:20:29  [002,100]
 ## Preprocessor common block used to hold statement label
 #  Put on a file called 'clabel'
 #  Used by ratfor preprocessor
 
 common /clabel/ label
   integer label    # next label returned by labgen
#-h- cline            544  asc  28-apr-81 00:20:30  [002,100]
 ## Preprocessor common block used to hold info about lines
 #  and included files
 #  Put on a file named 'cline'
 # Used only by ratfor preprocessor
 
 common /cline/ level, linect(NFILES), infile(NFILES),
   fnamp, fnames(MAXFNAMES)
   integer level   # level of file inclusion; init = 1
   integer linect   # line count on input file(level); init = 1
   integer infile   # file number(level); init infile(1) = STDIN
   integer fnamp    # next free slot in fnames; init = 2
   character fnames # stack of include names; init fnames(1) = EOS
#-h- clook            894  asc  28-apr-81 00:20:31  [002,100]
 ## Common block used to hold hash table and definitions
 #  Put on a file named 'clook'
 #  Used by ratfor preprocessor, macro, roff, and form tools
 
 common /clook/ lastp, lastt, hshptr(NHASHPTR), tabptr(2,MAXPTR),
                table(MAXTBL)
 
   integer lastp        # last used tabptr entry; init = 0
   integer lastt        # last used table entry; init = 0
   integer hshptr       # listheads for linked list of pointers; init=0
   integer tabptr       # linked list of pointers to table
                        # tabptr(1,n) points to next element of linked
                        #      list
                        # tabptr(2,n) points to (name,defn) combo in 
                        #      table
                        # init all entries to 0; end of linked list has
                        #      tabprt(1,n) = 0
   character table      # actual text of names and definitions
#-h- cmacro           286  asc  28-apr-81 00:20:32  [002,100]
 
 # -cmacro- common block
 # put on a file called 'cmacro'
 # Used only by the macro tool
 
 common /cmacro/ cp, ep, evalst(EVALSIZE)
    integer cp         # current call stack pointer
    integer ep         # next free position in evalst
    character evalst      # evaluation stack
#-h- coutln           283  asc  28-apr-81 00:20:33  [002,100]
 ## Preprocessor common block used to hold output characters
 #  Put on a file named 'coutln'
 #  Used only by ratfor preprocessor
 
 common /coutln/ outp, outbuf(74)
   integer outp      # last position filled in outbuf; init = 0
   character outbuf   # output lines collected here
#-h- csbuf            286  asc  28-apr-81 00:20:34  [002,100]
 ## preprocessor common block for holding string statement info
 #  Put on a file called 'csbuf'
 #  Used only by ratfor preprocessor
 
 common /csbuf/ sbp, sbuf(SBUFSIZE)
   integer sbp      # next available character position; init = 1
   character sbuf   # saved for data statements
#-h- cswtch           320  asc  28-apr-81 00:20:35  [002,100]
 ## Preprocessor common block used to hold switch info
 #  Put on a file named 'cswtch'
 #  Used only by ratfor preprocessor
 
 common /cswtch/ swtop, swlast, swstak(MAXSWITCH)
   integer swtop	# current switch entry; init = 0
   integer swlast	# next available position; init = 1
   integer swstak	# switch information
#-h- macsym           370  asc  28-apr-81 00:20:36  [002,100]
  ## /macsym/ - definitions for macro processor
  # put on a file named 'macsym'
 # used by the macro and rat4 tools
 
 
 define(CALLSIZE,50)
 define(ARGSIZE,100)
 
 define(ARGFLAG,DOLLAR)
 
 define(MACTYPE,-10)
 define(IFTYPE,-11)
 define(INCTYPE,-12)
 define(SUBTYPE,-13)
 define(ARITHTYPE,-14)
 define(IFDEFTYPE,-15)
 define(IFNOTDEFTYPE,-16)
 
 define(EVALSIZE,500)
#-h- rat4sym         4630  asc  28-apr-81 00:20:37  [002,100]
  # Definitions used by the ratfor preprocessor
  # Should be put on a file called 'rat4sym'
  # Used by ratfor preprocessor, macro, and form tools

 #---------------------------------------------------------------
 #
 # The definition STDEFNS defines the file which contains the
 # standard definitions to be used when preprocessing a file.
 # It is opened and read automatically by the ratfor preprocessor.
 # Set STDEFNS to the name of the file in which the standard
 # definitions reside.  If you don't want the preprocessor to
 # automatically open this file, set STDENFS to "".
 #
 #---------------------------------------------------------------
 #  Some of the buffer sizes and other symbols might have to be
 #  changed.  Especially check the following:
 #
 #        NFILES         (max depth of file inclusion)
 #        MAXDEF         (number of characters in a definition)
 #        MAXFNAMES      (number of characters in file name stack)
 #        MAXTBL         (size of definition table)
 #        MAXPTR         (nbr of defines in lookup)
 #        SBUFSIZE       (nbr string declarations allowed per module)
 #        MAXSTRTBL      (size of table to buffer string declarations)
 #        MAXSWITCH      (max stack for switch statement)
 #
 #-----------------------------------------------------------------
 #
 # Also, all the LEX-- definitions might have to be altered for
 # systems where 'character' is not defined as 'integer'.
 #
 #-----------------------------------------------------------------
 #
 #
#  define(STDEFNS,"ratdef")  #name of file containing standard defns
  define(STDEFNS,"symbols")
  define(RADIX,PERCENT)     # % indicates alternate radix
  define(TOGGLE,PERCENT)    # toggle for literal lines
  define(BUFSIZE,300)       # pushback buffer for ngetch and putbak
  define(SBUFSIZE,500)      # buffer for string statements
  define(DEFTYPE,10010)     # or define(DEFTYPE,-4)
  define(MAXCHARS,10)       # characters for outnum
  define(MAXDEF,200)        # max chars in a defn
  define(MAXFORSTK,200)     # max space for for reinit clauses
  define(MAXPTR,625)        # nbr of defines in lookup
  define(MAXSTACK,100)      # max stack depth for parser
  define(MAXSWITCH,1000)    # max stack for switch statement
  define(MAXTBL,6250)       # max chars in all definitions
  define(MAXTOK,100)        # max chars in a token
  define(NFILES,arith(MAXOFILES,-,3))          # max depth of file inclusion
  define(MAXFNAMES,arith(NFILES,*,FILENAMESIZE))     # max chars in file name 
                            # stack = NFILES * FILENAMESIZE
  define(NHASHPTR,37)       #number of pointer listheads for hash table
  define(MAXNBRSTR,20)      #max nbr string declarations per module
  define(CUTOFF,3)          # min nbr of cases to generate branch table
                            # (for switch statement)
  define(DENSITY,2)         # reciprocal of density necessary for 
                            # branch table
  define(LEXBREAK,10264)    #or define(LEXBREAK,-8)
  define(LEXCASE,10276)     #or define(LEXCASE,-25)
  define(LEXDEFAULT,10277)  #or define(LEXDEFAULT,-26)
  define(LEXDIGITS,10260)   #or define(LEXDIGITS,-9)
  define(LEXDO,0266)        #or define(LEXDO,-10)
  define(LEXELSE,10262)     #or define(LEXELSE,-11)
  define(LEXEND,10272)      #or define(LEXEND,-21)
  define(LEXFOR,10268)      #or define(LEXFOR,-16)
  define(LEXIF,10261)       #or define(LEXIF,-19)
  define(LEXLITERAL,10278)  #or define(LEXLITERAL,-27)
  define(LEXNEXT,10265)     #or define(LEXNEXT,-13)
  define(LEXOTHER,10267)    #or define(LEXOTHER,-14)
  define(LEXREPEAT,10269)   #or define(LEXREPEAT,-17)
  define(LEXRETURN,10271)   #or define(LEXRETURN,-20)
  define(LEXSTOP,10273)     #or define(LEXSTOP,-22)
  define(LEXSTRING,10274)   #or define(LEXSTRING,-23)
  define(LEXSWITCH,10275)   #or define(LEXSWITCH,-24)
  define(LEXUNTIL,10270)    #or define(LEXUNTIL,-18)
  define(LEXWHILE,10263)    #or define(LEXWHILE,-15)
 #--------------------------------------------------------------
 #  Special definitions for VAX/VMS implementation
 #  Remove for portable version
 define(DEFTYPE,-4)
 define(LEXBREAK,-8)
 define(LEXCASE,-25)
 define(LEXDEFAULT,-26)
 define(LEXDIGITS,-9)
 define(LEXDO,-10)
 define(LEXELSE,-11)
 define(LEXEND,-21)
 define(LEXFOR,-16)
 define(LEXIF,-19)
 define(LEXLITERAL,-27)
 define(LEXNEXT,-13)
 define(LEXOTHER,-14)
 define(LEXREPEAT,-17)
 define(LEXRETURN,-20)
 define(LEXSTOP,-22)
 define(LEXSTRING,-23)
 define(LEXSWITCH,-24)
 define(LEXUNTIL,-18)
 define(LEXWHILE,-15)
 define(MAXNAME,FILENAMESIZE)
 define(initst,initr4)
 define(LSTRIPC,-10)
 define(RSTRIPC,-11)
#-h- rat4.r         57806  asc  28-apr-81 00:20:51  [002,100]
#-h- defns             88  asc  27-apr-81 10:26:00  [002,100]
 ## include all required definitions
 # include ratdef
 include rat4sym
 include macsym
#-h- getdef          1703  asc  27-apr-81 10:26:01  [002,100]
# define statement and symbol table
# routines in this group are getdef, instal, lookup, hshfcn, tbinit

# getdef (for no arguments) - get name and definition
   subroutine getdef(token, toksiz, defn, defsiz, fd)
   character gtok, ngetch
   integer defsiz, fd, i, nlpar, toksiz
   character c, defn(MAXDEF), token(MAXTOK), t, ptoken(MAXTOK)
 
   call skpblk(fd)
   c = gtok(ptoken, MAXTOK, fd)
   if (c == LPAREN)
      t = LPAREN             # define (name, defn)
   else {
      t = BLANK              # define name defn
      call pbstr(ptoken)
      }
   call skpblk(fd)
   if (gtok(token, toksiz, fd) ^= ALPHA)
      call baderr("non-alphanumeric name.")
   call skpblk(fd)
   c = gtok(ptoken, MAXTOK, fd)
   if (t == BLANK) {         # define name defn
      call pbstr(ptoken)
      i = 1
      repeat {
         c = ngetch(c, fd)
         if (i > defsiz)
            call baderr("definition too long.")
         defn(i) = c
         i = i + 1
         } until (c == SHARP | c == NEWLINE | c == EOF)
      if (c == SHARP)
         call putbak(c)
      }
   else if (t == LPAREN) {   # define (name, defn)
      if (c ^= COMMA)
         call baderr("missing comma in define.")
      # else got (name,
      nlpar = 0
      for (i = 1; nlpar >= 0; i = i + 1)
         if (i > defsiz)
            call baderr("definition too long.")
         else if (ngetch(defn(i), fd) == EOF)
            call baderr("missing right paren.")
         else if (defn(i) == LPAREN)
            nlpar = nlpar + 1
         else if (defn(i) == RPAREN)
            nlpar = nlpar - 1
         # else normal character in defn(i)
      }
   else
      call baderr("getdef is confused.")
   defn(i-1) = EOS
   return
   end
#-h- instal           681  asc  27-apr-81 10:26:03  [002,100]
 ## instal - add name and definition to table
 subroutine instal(name, defn)

 character name(MAXTOK), defn(MAXDEF)
 integer nlen, dlen, length, c, hshfcn

 # include commonblocks
 include clook

 nlen = length(name) + 1
 dlen = length(defn) + 1
 if (lastt + nlen + dlen > MAXTBL | lastp >= MAXPTR)
    {
    call putlin(name, ERROUT)
    call remark(" : too many definitions.")
    }
 else
    {
    lastp = lastp + 1
    tabptr(2, lastp) = lastt + 1
    c = hshfcn(name, NHASHPTR)
    tabptr(1, lastp) = hshptr(c)
    hshptr(c) = lastp
    call scopy(name, 1, table, lastt + 1)
    call scopy(defn, 1, table, lastt + nlen + 1)
    lastt = lastt + nlen + dlen
    }

 return
 end
#-h- lookup           518  asc  27-apr-81 10:26:04  [002,100]
 ## lookup - lookup up definition in table
 integer function lookup(name, defn)

 character name(MAXTOK), defn(MAXDEF)
 integer c, hshfcn, i, j, k

 # include commonblocks
 include clook

 c = hshfcn(name, NHASHPTR)
 lookup = NO
 for (i=hshptr(c); i > 0; i=tabptr(1,i))
    {
    j = tabptr(2, i)
    for (k=1; name(k) == table(j) & name(k) != EOS; k=k+1)
        j = j + 1
    if (name(k) == table(j))
        {
        call scopy(table, j+1, defn, 1)
        lookup = YES
        break
        }
    }

 return
 end
#-h- hshfcn           388  asc  27-apr-81 10:26:06  [002,100]
 ## hshfcn - hash function
#
#	this is a portable version of the hash function.  It takes the first
#	and last characters of the string, sums them, and then returns
#	the (sum modulo n) + 1.
#
 integer function hshfcn(strng, n)

 character strng(ARB)
 integer n, i, length, i1, i2

 i = length(strng)
 i = max(i, 1)
 i1 = strng(1)
 i2 = strng(i)
 hshfcn = mod(i1+i2, n) + 1

 return
 end
#-h- tbinit           204  asc  27-apr-81 10:26:07  [002,100]
 ## tbinit - initialize hash table
 subroutine tbinit
 
 # include commonblocks
 include clook
 
			#initialize hash table
 lastp = 0
 lastt = 0
 for (i=1; i<=NHASHPTR; i=i+1)
	hshptr(i) = 0
 return
 end
#-h- docode           566  asc  27-apr-81 10:26:07  [002,100]
# do statement - routines in this group are docode, dostat


# docode - generate code for beginning of do
   subroutine docode(lab)
   integer labgen
   integer lab
 character gnbtok
 character lexstr(MAXTOK)
   # include commonblocks
   include cgoto
   string sdo "do"
 
   xfer = NO
   call outtab
   call outstr(sdo)
   call outch(BLANK)
   lab = labgen(2)
   if (gnbtok(lexstr, MAXTOK) == DIGIT)	#check for fortran DO
	call outstr(lexstr)
   else
	{
	call pbstr(lexstr)
   	call outnum(lab)
	}
   call outch(BLANK)
   call eatup
   call outdon
   return
   end
#-h- dostat           153  asc  27-apr-81 10:26:09  [002,100]
 # dostat - generate code for end of do statement
    subroutine dostat(lab)
    integer lab
  
 
  call outcon(lab)
  call outcon(lab+1)
  return
  end
#-h- baderr           151  asc  28-apr-81 00:19:38  [002,100]
 ## error processing - routines in this group are baderr, synerr
 
 subroutine baderr(msg)
 character msg(ARB)
 call synerr(msg)
 call endst(ERR)
 end
#-h- synerr           568  asc  27-apr-81 10:26:10  [002,100]
 subroutine synerr(msg)
 character lc(MAXCHARS), msg(ARB)
 integer itoc
 integer i, junk
 # include commonblocks
 include cline
 string in " in "
 string errmsg "error at line "
 
 call putlin(errmsg, ERROUT)
 if (level >= 1)
   	i = level
 else
	i = 1	#for EOF errors
 junk = itoc (linect(i), lc, MAXCHARS)
 call putlin(lc, ERROUT)
 for (i = fnamp-1; i>1; i=i-1)
	if (fnames(i-1) == EOS)		#print file name
		{
		call putlin(in, ERROUT)
		call putlin(fnames(i), ERROUT)
		break
		}
 call putch(COLON, ERROUT)
 call putch(BLANK, ERROUT)
 call remark (msg)
 return
 end
#-h- forcod          2175  asc  27-apr-81 10:26:12  [002,100]
# for statement - routines in this group are forcod, fors


# forcod - beginning of for statement
   subroutine forcod(lab)
   character gettok, gnbtok
   character t, token(MAXTOK)
   integer length, labgen
   integer i, j, lab, nlpar
   # include commonblocks
   include cfor
   string ifnot "if(.not."
 
   lab = labgen(3)
   call outcon(0)
   if (gnbtok(token, MAXTOK) ^= LPAREN) {
      call synerr("missing left paren.")
      return
      }
   if (gnbtok(token, MAXTOK) ^= SEMICOL) {   # real init clause
      call pbstr(token)
      call outtab
      call eatup
      call outdon
      }
   if (gnbtok(token, MAXTOK) == SEMICOL)   # empty condition
      call outcon(lab)
   else {   # non-empty condition
      call pbstr(token)
      call outnum(lab)
      call outtab
      call outstr(ifnot)
      call outch(LPAREN)
      nlpar = 0
      while (nlpar >= 0) {
         t = gettok(token, MAXTOK)
         if (t == SEMICOL)
            break
         if (t == LPAREN)
            nlpar = nlpar + 1
         else if (t == RPAREN)
            nlpar = nlpar - 1
         if (t == EOF) {
            call pbstr(token)
            return
            }
         if (t ^= NEWLINE & t ^= UNDERLINE)
            call outstr(token)
         }
      call outch(RPAREN)
      call outch(RPAREN)
      call outgo(lab+2)
      if (nlpar < 0)
         call synerr("invalid for clause.")
      }
   fordep = fordep + 1   # stack reinit clause
   j = 1
   for (i = 1; i < fordep; i = i + 1)   # find end
      j = j + length(forstk(j)) + 1
   forstk(j) = EOS   # null, in case no reinit
   nlpar = 0
   t = gnbtok(token, MAXTOK)
   call pbstr(token)
   while (nlpar >= 0) {
      t = gettok(token, MAXTOK)
      if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      if (t == EOF) {
         call pbstr(token)
         break
         }
      if (nlpar >= 0 & t ^= NEWLINE & t ^= UNDERLINE) {
         if (j + length(token) >= MAXFORSTK)
            call baderr("for clause too long.")
         call scopy(token, 1, forstk, j)
         j = j + length(token)
         }
      }
   lab = lab + 1   # label for next's
   return
   end
#-h- fors             465  asc  27-apr-81 10:26:14  [002,100]
# fors - process end of for statement
   subroutine fors(lab)
   integer length
   integer i, j, lab
   # include commonblocks
   include cfor
   include cgoto

   xfer = NO
   call outnum(lab)
   j = 1
   for (i = 1; i < fordep; i = i + 1)
      j = j + length(forstk(j)) + 1
   if (length(forstk(j)) > 0) {
      call outtab
      call outstr(forstk(j))
      call outdon
      }
   call outgo(lab-1)
   call outcon(lab+1)
   fordep = fordep - 1
   return
   end
#-h- balpar           857  asc  27-apr-81 10:26:15  [002,100]
# if statement - routines in this group are balpar, elseif, ifcode, ifgo


# balpar - copy balanced paren string
   subroutine balpar
   character gettok, gnbtok
   character t, token(MAXTOK)
   integer nlpar
 
   if (gnbtok(token, MAXTOK) ^= LPAREN) {
      call synerr("missing left paren.")
      return
      }
   call outstr(token)
   nlpar = 1
   repeat {
      t = gettok(token, MAXTOK)
      if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) {
         call pbstr(token)
         break
         }
      if (t == NEWLINE)      # delete newlines
         token(1) = EOS
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      # else nothing special
      call outstr(token)
      } until (nlpar <= 0)
   if (nlpar ^= 0)
      call synerr("missing parenthesis in condition.")
   return
   end
#-h- elseif           151  asc  27-apr-81 10:26:16  [002,100]
# elseif - generate code for end of if before else
   subroutine elseif(lab)
   integer lab

   call outgo(lab+1)
   call outcon(lab)
   return
   end
#-h- ifcode           210  asc  27-apr-81 10:26:17  [002,100]
# ifcode - generate initial code for if
   subroutine ifcode(lab)
   integer labgen
   integer lab
   # include commonblocks
   include cgoto

   xfer = NO
   lab = labgen(2)
   call ifgo(lab)
   return
   end
#-h- ifgo             339  asc  27-apr-81 10:26:18  [002,100]
# ifgo - generate "if(.not.(...))goto lab"
   subroutine ifgo(lab)
   integer lab
   string ifnot "if(.not."
 
   call outtab         # get to column 7
   call outstr(ifnot)      # " if(.not. "
   call balpar         # collect and output condition
   call outch(RPAREN)      # " ) "
   call outgo(lab)      # " goto lab "
   return
   end
#-h- gettok          3131  asc  27-apr-81 10:26:19  [002,100]
# lexical analyzer
# routines in this group are gettok, gnbtok, gtok, lex, ngetch,
# pbstr, putbak, relate


# deftok - get token; process macro calls and invocations
# this routine has been disabled to allow defines with parameters to be added
# see deftok for the code for deftok
#   character function deftok(token, toksiz, fd)
#   character gtok
#   integer fd, toksiz
#   character defn(MAXDEF), t, token(MAXTOK)
#   integer lookup
# 
#   for (t=gtok(token, toksiz, fd); t^=EOF; t=gtok(token, toksiz, fd)) {
#      if (t ^= ALPHA)   # non-alpha
#         break
#      if (lookup(token, defn) == NO)   # undefined
#         break
#      if (defn(1) == DEFTYPE) {   # get definition
#         call getdef(token, toksiz, defn, MAXDEF, fd)
#         call instal(token, defn)
#         }
#      else
#         call pbstr(defn)   # push replacement onto input
#      }
#   deftok = t
#   if (deftok == ALPHA)   # convert to single case
#      call fold(token)
#   return
#   end
# gettok - get token. handles file inclusion and line numbers
   character function gettok(token, toksiz)
   integer equal, open, length
   integer  i, toksiz, f, len
   character t
   character deftok, ngetch
   character getch
   character name(MAXNAME), token(MAXTOK)
   # include commonblocks
   include cline
   include cfname
   string fncn "function"
   string incl "include"

   for ( ; level > 0; level = level - 1) 
      {
      f = infile(level)
      for (gettok = deftok(token, toksiz, f); gettok ^= EOF;
         gettok = deftok(token, toksiz, f)) {
         if (equal(token, fncn) == YES) {
            call skpblk(infile(level))
            t = deftok(fcname, MAXNAME, f)
            call pbstr(fcname)
            if (t ^= ALPHA)
               call synerr("missing function name.")
            call putbak(BLANK)
            return
            }
         else if (equal(token, incl) == NO)
            return
                                   #process includes
         call skpblk(infile(level))
	t = deftok(name, MAXNAME, infile(level))
	if (t == SQUOTE | t == DQUOTE)
	    {
	    len = length(name) - 1
	    for (i=1; i < len; i=i+1)
		name(i) = name(i+1)
	    name(i) = EOS
	    }
	i = length(name) + 1
         if (level >= NFILES)
            call synerr("includes nested too deeply.")
         else {
            infile(level+1) = open(name, READ)
            linect(level+1) = 1
            if (infile(level+1) == ERR)
               call synerr("can't open include.")
            else {
               level = level + 1
               if (fnamp + i <= MAXFNAMES) {
                  call scopy(name, 1, fnames, fnamp)
                  fnamp = fnamp + i    # push file name stack
                  }
               f = infile(level)
               }
            }
         }
      if (level > 1) {      # close include and pop file name stack
         call close(infile(level))
         for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1)
            if (fnames(fnamp-1) == EOS)
               break
         }
      }
   token(1) = EOF   # in case called more than once
   token(2) = EOS
   gettok = EOF
   return
   end
#-h- gnbtok           252  asc  27-apr-81 10:26:22  [002,100]
# gnbtok - get nonblank token
   character function gnbtok(token, toksiz)
   integer toksiz
   character token(MAXTOK), gettok
   # include commonblocks
   include cline

   call skpblk(infile(level))
   gnbtok = gettok(token, toksiz)
   return
   end
#-h- gtok            3865  asc  27-apr-81 10:26:23  [002,100]
# gtok - get token for Ratfor
   character function gtok(lexstr, toksiz, fd)
   character ngetch, type
   integer fd, i, b, n, toksiz, itoc
   character c, lexstr(MAXTOK)
   # include commonblocks
   include cline
 
   c = ngetch(lexstr(1), fd)
   if (c == BLANK | c == TAB) {
      lexstr(1) = BLANK
      while (c == BLANK | c == TAB)    # compress many blanks to one
         c = ngetch(c, fd)
      if (c == SHARP)
         while (ngetch(c, fd) ^= NEWLINE)   # strip comments
            ;
      if (c ^= NEWLINE)
         call putbak(c)
      else
         lexstr(1) = NEWLINE
      lexstr(2) = EOS
      gtok = lexstr(1)
      return
      }
   i = 1
   gtok = type(c)
   if (gtok == LETTER) {	# alpha
      for (i = 1; i < toksiz - 2; i = i + 1) {
         gtok = type(ngetch(lexstr(i+1), fd))
         if (gtok ^= LETTER & gtok ^= DIGIT & gtok ^= UNDERLINE
             & gtok ^= PERIOD)
               break
         }
      call putbak(lexstr(i+1))
      gtok = ALPHA
      }
   else if (gtok == DIGIT) {	# digits
      b = c - DIG0	# in case alternate base number
      for (i = 1; i < toksiz - 2; i = i + 1) {
         if (type(ngetch(lexstr(i+1), fd)) ^= DIGIT)
            break
         b = 10*b + lexstr(i+1) - DIG0
         }
      if (lexstr(i+1) == RADIX & b >= 2 & b <= 36) {   #n%ddd...
         for (n = 0;; n = b*n + c - DIG0) {
            c = ngetch(lexstr(1), fd)
            if (c >= LETA & c <= LETZ)
               c = c - LETA + DIG9 + 1
            else if (c >= BIGA & c <= BIGZ)
               c = c - BIGA + DIG9 + 1
            if (c < DIG0 | c >= DIG0 + b)
               break
            }
         call putbak(lexstr(1))
         i = itoc(n, lexstr, toksiz)
         }
      else
         call putbak(lexstr(i+1))
      gtok = DIGIT
      }
   else if (c == LBRACK) {   # allow [ for {
      lexstr(1) = LBRACE
      gtok = LBRACE
      }
   else if (c == RBRACK) {   # allow ] for }
      lexstr(1) = RBRACE
      gtok = RBRACE
      }
#   else if (c == DOLLAR) {   # allow $( and $) for { and }
#      if (ngetch(lexstr(2), fd) == LPAREN) {
#         lexstr(1) = LBRACE
#         gtok = LBRACE
#         }
#      else if (lexstr(2) == RPAREN) {
#         lexstr(1) = RBRACE
#         gtok = RBRACE
#         }
#      else
#         call putbak(lexstr(2))
#      }
# the above code has been disabled in order to allow $( and $) to 
# surround strings to be copied directly to the evaluation stack within
# macros.  This is done by returninig dummy character values when these
# digraphs are seen
   else if (c == DOLLAR) {   
      if (ngetch(lexstr(2), fd) == LPAREN) {
         lexstr(1) = LSTRIPC
         gtok = LSTRIPC
         }
      else if (lexstr(2) == RPAREN) {
         lexstr(1) = RSTRIPC
         gtok = RSTRIPC
         }
      else
         call putbak(lexstr(2))
      }
   else if (c == SQUOTE | c == DQUOTE) {
      for (i = 2; ngetch(lexstr(i), fd) ^= lexstr(1); i = i + 1) {
         if (lexstr(i) == UNDERLINE)
            if (ngetch(c, fd) == NEWLINE) {
               while (c == NEWLINE | c == BLANK | c == TAB)
                  c = ngetch(c, fd)
               lexstr(i) = c
               }
            else
               call putbak(c)
         if (lexstr(i) == NEWLINE | i >= toksiz-1) {
            call synerr("missing quote.")
            lexstr(i) = lexstr(1)
            call putbak(NEWLINE)
            break
            }
         }
      }
   else if (c == SHARP) {   # strip comments
      while (ngetch(lexstr(1), fd) ^= NEWLINE)
         ;
      gtok = NEWLINE
      }
   else if (c == GREATER | c == LESS | c == NOT | c == BANG | c == CARET
      | c == EQUALS | c == AND | c == OR)
      call relate(lexstr, i, fd)
   if (i >= toksiz-1)
      call synerr("token too long.")
   lexstr(i+1) = EOS
   if (lexstr(1) == NEWLINE)
      linect(level) = linect(level) + 1
   return
   end
#-h- lex             1680  asc  27-apr-81 10:26:26  [002,100]
# lex - return lexical type of token
   integer function lex(lexstr)
   character gnbtok, deftok
   character lexstr(MAXTOK)
   integer equal
   # include commonblocks
   string sif "if"
   string selse "else"
   string swhile "while"
   string sdo "do"
   string sbreak "break"
   string snext "next"
   string sfor "for"
   string srept "repeat"
   string suntil "until"
   string sret "return"
   string sstr "string"
   string sswtch "switch"
   string scase "case"
   string sdeflt "default"
 
   for (lex = gnbtok(lexstr, MAXTOK); lex == NEWLINE;
      lex = gnbtok(lexstr, MAXTOK))
         ;
   if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE)
      return
   if (lex == DIGIT)
      lex = LEXDIGITS
   else if (lex == TOGGLE)
     lex = LEXLITERAL
   else if (equal(lexstr, sif) == YES)
      lex = LEXIF
   else if (equal(lexstr, selse) == YES)
      lex = LEXELSE
   else if (equal(lexstr, swhile) == YES)
      lex = LEXWHILE
   else if (equal(lexstr, sdo) == YES)
      lex = LEXDO
   else if (equal(lexstr, sbreak) == YES)
      lex = LEXBREAK
   else if (equal(lexstr, snext) == YES)
      lex = LEXNEXT
   else if (equal(lexstr, sfor) == YES)
      lex = LEXFOR
   else if (equal(lexstr, srept) == YES)
      lex = LEXREPEAT
   else if (equal(lexstr, suntil) == YES)
      lex = LEXUNTIL
   else if (equal(lexstr, sret) == YES)
      lex = LEXRETURN
   else if (equal(lexstr, sstr) == YES)
      lex = LEXSTRING
   else if (equal(lexstr, sswtch) == YES)
      lex = LEXSWITCH
   else if (equal(lexstr, scase) == YES)
      lex = LEXCASE
   else if (equal(lexstr, sdeflt) == YES)
      lex = LEXDEFAULT
   else
      lex = LEXOTHER
   return
   end
#-h- ngetch           303  asc  27-apr-81 10:26:28  [002,100]
# ngetch - get a (possibly pushed back) character
   character function ngetch(c, fd)
   character getch
   character c
   integer fd
   # include commonblocks
   include cdefio
 
   if (bp > 0) {
      c = buf(bp)
      bp = bp - 1
      }
   else
      c = getch(c, fd)
   ngetch = c
   return
   end
#-h- pbstr            200  asc  27-apr-81 10:26:29  [002,100]
# pbstr - push string back onto input
   subroutine pbstr(in)
   character in(ARB)
   integer length
   integer i
 
   for (i = length(in); i > 0; i = i - 1)
      call putbak(in(i))
   return
   end
#-h- putbak           249  asc  27-apr-81 10:26:30  [002,100]
# putbak - push character back onto input
   subroutine putbak(c)
   character c
   # include commonblocks
   include cdefio
 
   bp = bp + 1
   if (bp > BUFSIZE)
      call baderr("too many characters pushed back.")
   buf(bp) = c
   return
   end
#-h- relate          1214  asc  27-apr-81 10:26:31  [002,100]
# relate - convert relational shorthands into long form
   subroutine relate(token, last, fd)
   character ngetch
   character token(ARB)
   integer length
   integer fd, last
 
   if (ngetch(token(2), fd) ^= EQUALS) {
      call putbak(token(2))
      token(3) = LETT
      }
   else
      token(3) = LETE
   token(4) = PERIOD
   token(5) = EOS
   token(6) = EOS	# for .not. and .and.
   if (token(1) == GREATER)
      token(2) = LETG
   else if (token(1) == LESS)
      token(2) = LETL
   else if (token(1) == NOT | token(1) == BANG | token(1) == CARET) {
      if (token(2) ^= EQUALS) {
         token(3) = LETO
         token(4) = LETT
         token(5) = PERIOD
         }
      token(2) = LETN
      }
   else if (token(1) == EQUALS) {
      if (token(2) ^= EQUALS) {
         token(2) = EOS
         last = 1
         return
         }
      token(2) = LETE
      token(3) = LETQ
      }
   else if (token(1) == AND) {
      token(2) = LETA
      token(3) = LETN
      token(4) = LETD
      token(5) = PERIOD
      }
   else if (token(1) == OR) {
      token(2) = LETO
      token(3) = LETR
      }
   else   # can't happen
      token(2) = EOS
   token(1) = PERIOD
   last = length(token)
   return
   end
#-h- rat4s           1084  asc  27-apr-81 10:26:33  [002,100]
 ## rat4 - driver subroutine for ratfor preprocessor
 
 DRIVER(rat4)
 
 integer getarg, open
 character buf(FILENAMESIZE)
 integer i
 
 # include commonblocks
 include cline		#needed to set input file
 
 string defns STDEFNS	#set name of standard definitions file
 
 call query("usage:  rat4 [file] ... [>outfile].")
 call initkw		#initialize variables
 
 # Read file containing standard definitions
 # If this isn't desired, define(STDEFNS,"")
 if (defns(1) != EOS)
	{
	call getdir(BINDIRECTORY, LOCAL, buf)
	call concat(buf, defns, buf)
	infile(1) = open(buf, READ)
    	if (infile(1) == ERR)
		call remark ("can't open standard definitions file.")
	else
		{
		call parse
		call close (infile(1))
		}
	}
 
 for (i=1; getarg(i, buf, FILENAMESIZE) != EOF; i=i+1)
	{
	if (buf(1) == MINUS & buf(2) == EOS)
		infile(1) = STDIN
	else
		{
		infile(1) = open(buf, READ)
		if (infile(1) == ERR)
			call cant(buf)
		}
	call parse
	if (infile(1) != STDIN)
		call close(infile(1))
	}
 
 if (i == 1)		#no files given on command line, use STDIN
	{
	infile(1) = STDIN
	call parse
	}
 DRETURN
 end
#-h- eatup           1113  asc  27-apr-81 10:26:34  [002,100]
# ordinary fortran statements - routines in this group are eatup, labelc, otherc


# eatup - process rest of statement; interpret continuations
   subroutine eatup
   character gettok
   character ptoken(MAXTOK), t, token(MAXTOK)
   integer nlpar
 
   nlpar = 0
   repeat {
      t = gettok(token, MAXTOK)
      if (t == SEMICOL | t == NEWLINE)
         break
      if (t == RBRACE | t == LBRACE) {
         call pbstr(token)
         break
         }
      if (t == EOF) {
         call synerr("unexpected EOF.")
         call pbstr(token)
         break
         }
      if (t == COMMA | t == PLUS | t == MINUS | t == STAR | t == LPAREN |
        t == AND | t == BAR | t == BANG | t == EQUALS | t == UNDERLINE ) {
         while (gettok(ptoken, MAXTOK) == NEWLINE)
            ;
         call pbstr(ptoken)
         if (t == UNDERLINE)
            token(1) = EOS
         }
      if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      call outstr(token)
      } until (nlpar < 0)
   if (nlpar ^= 0)
      call synerr("unbalanced parentheses.")
   return
   end
#-h- labelc           413  asc  27-apr-81 10:26:36  [002,100]
# labelc - output statement number
   subroutine labelc(lexstr)
   character lexstr(ARB)
   integer length
   # include commonblocks
   include cgoto
 
   xfer = NO   # can't suppress goto's now
   if (length(lexstr) == 5)   # warn about 23xxx labels
      if (lexstr(1) == DIG2 & lexstr(2) == DIG3)
         call synerr("warning: possible label conflict.")
   call outstr(lexstr)
   call outtab
   return
   end
#-h- otherc           240  asc  27-apr-81 10:26:36  [002,100]
# otherc - output ordinary Fortran statement
   subroutine otherc(lexstr)
   character lexstr(ARB)
   # include commonblocks
   include cgoto

   xfer = NO
   call outtab
   call outstr(lexstr)
   call eatup
   call outdon
   return
   end
#-h- outch            482  asc  27-apr-81 10:26:37  [002,100]
# output routines
# routines in this group are outch, outcon, outdon, outgo, outnum, outstr,
# outtab, allblk


# outch - put one character into output buffer
   subroutine outch(c)
   character c
   integer i
   # include commonblocks
   include coutln
 
   if (outp >= 72) {   # continuation card
      call outdon
      for (i = 1; i < 6; i = i + 1)
         outbuf(i) = BLANK
      outbuf(6) = STAR
      outp = 6
      }
   outp = outp + 1
   outbuf(outp) = c
   return
   end
#-h- outcon           363  asc  27-apr-81 10:26:39  [002,100]
# outcon - output "n   continue"
   subroutine outcon(n)
   integer n
   # include commonblocks
   include cgoto
   include coutln
   string contin "continue"
 
   xfer = NO
   if (n <= 0 & outp == 0)
      return            # don't need unlabeled continues
   if (n > 0)
      call outnum(n)
   call outtab
   call outstr(contin)
   call outdon
   return
   end
#-h- outdon           266  asc  27-apr-81 10:26:39  [002,100]
# outdon - finish off an output line
   subroutine outdon
  integer allblk
   # include commonblocks
   include coutln
 
   outbuf(outp+1) = NEWLINE
   outbuf(outp+2) = EOS
   if (allblk(outbuf) == NO)
       call putlin(outbuf, STDOUT)
   outp = 0
   return
   end
#-h- outgo            250  asc  27-apr-81 10:26:40  [002,100]
# outgo - output "goto  n"
   subroutine outgo(n)
   integer n
   # include commonblocks
   include cgoto
   string goto "goto "
 
   if (xfer == YES)
      return
   call outtab
   call outstr(goto)
   call outnum(n)
   call outdon
   return
   end
#-h- outnum           357  asc  27-apr-81 10:26:41  [002,100]
# outnum - output decimal number
   subroutine outnum(n)
   character chars(MAXCHARS)
   integer i, m

   m = iabs(n)
   i = 0
   repeat {
      i = i + 1
      chars(i) = mod(m, 10) + DIG0
      m = m / 10
      } until (m == 0 | i >= MAXCHARS)
   if (n < 0)
      call outch(MINUS)
   for ( ; i > 0; i = i - 1)
      call outch(chars(i))
   return
   end
#-h- outstr           632  asc  27-apr-81 10:26:42  [002,100]
# outstr - output string; handles quoted literals
   subroutine outstr(str)
   character c, str(ARB)
   integer i, j
 
   for (i = 1; str(i) ^= EOS; i = i + 1) {
      c = str(i)
      if (c ^= SQUOTE & c ^= DQUOTE) {
         if (c >= LETA & c <= LETZ)	# remove this if you
            c = c - LETA + BIGA		# don't need upper case fortran
         call outch(c)
         }
      else {
         i = i + 1
         for (j = i; str(j) ^= c; j = j + 1)   # find end
            ;
         call outnum(j-i)
         call outch(BIGH)
         for ( ; i < j; i = i + 1)
            call outch(str(i))
         }
      }
   return
   end
#-h- outtab           157  asc  27-apr-81 10:26:44  [002,100]
# outtab - get past column 6
   subroutine outtab
   # include commonblocks
   include coutln
 
   while (outp < 6)
      call outch(BLANK)
   return
   end
#-h- allblk           434  asc  27-apr-81 10:26:44  [002,100]
# allblk - determine if line consists of all blanks
# this routine is called by outdon, and is here to fix
# a bug which sometimes occurs if two or more includes precede the
# first line of executable code.  Could not trace down the cause
 integer function allblk(buf)

 character buf(ARB)
 integer i

 allblk = YES
 for (i=1; buf(i) != NEWLINE & buf(i) != EOS; i=i+1)
    if (buf(i) != BLANK)
	{
	allblk = NO
	break
	}

 return
 end
#-h- initkw          1204  asc  27-apr-81 10:26:46  [002,100]
# parsing - routines in this group are initkw, init, parse, unstak, ulstal

 ## initkw - initialize table and install keywords 'define' and 'DEFINE' 
 subroutine initkw 
  
# character deft(2), mact(2), inct(2), subt(2), ift(2), art(2)
 character deft(2), inct(2), subt(2), ift(2), art(2), ifdft(2), ifndt(2)
 # include commonblocks
 include clabel
 
 string defnam "define"
# string macnam "macro"
 string incnam "incr"
 string subnam "substr"
 string ifnam "ifelse"
 string arnam "arith"
 string ifdfnm "ifdef"
 string ifndnm "ifnotdef"

 data deft(1), deft(2) /DEFTYPE, EOS/
# data mact(1), mact(2) /MACTYPE, EOS/
 data inct(1), inct(2) /INCTYPE, EOS/
 data subt(1), subt(2) /SUBTYPE, EOS/
 data ift(1), ift(2) /IFTYPE, EOS/
 data art(1), art(2) /ARITHTYPE, EOS/
 data ifdft(1), ifdft(2) /IFDEFTYPE, EOS/
 data ifndt(1), ifndt(2) /IFNOTDEFTYPE, EOS/
  
 call tbinit		#initialize hash table
			#install keywords 'define' and 'DEFINE'
 call ulstal(defnam, deft)
# call ulstal(macnam, mact)
 call ulstal(incnam, inct)
 call ulstal(subnam, subt)
 call ulstal(ifnam, ift)
 call ulstal(arnam, art)
 call ulstal(ifdfnm, ifdft)
 call ulstal(ifndnm, ifndt)
			#initialize label
 label = 23000

 return 
 end 

#-h- init             555  asc  27-apr-81 10:26:47  [002,100]
 # init - initialize for each input file
   subroutine init
   integer i
   # include commonblocks
   include coutln
   include cline
   include cdefio
   include cfor
   include clook
   include cfname
   include clabel
   include csbuf
   include cswtch
 
   outp = 0		# output character pointer
   level = 1		# file control
   linect(1) = 1
   sbp  = 1
   fnamp = 2
   fnames(1) = EOS
   bp = 0		# pushback buffer pointer
   fordep = 0		# for stack
   fcname(1) = EOS	# current function name
   swtop = 0		# switch stack
   swlast = 1
   return
   end
#-h- parse           2728  asc  27-apr-81 10:26:49  [002,100]
# parse - parse Ratfor source program
   subroutine parse
   character lexstr(MAXTOK)
   integer lex
   integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token, i
   include cgoto
   include cfor
   include cfname
   include cline
   include csbuf
   include clabel
   include clook
   include cdefio
   include coutln
 
   call init
   sp = 1
   lextyp(1) = EOF
   for (token = lex(lexstr); token ^= EOF; token = lex(lexstr)) 
      {
      if (token == LEXIF)
         call ifcode(lab)
      else if (token == LEXDO)
         call docode(lab)
      else if (token == LEXWHILE)
         call whilec(lab)
      else if (token == LEXFOR)
         call forcod(lab)
      else if (token == LEXREPEAT)
         call repcod(lab)
      else if (token == LEXSWITCH)
         call swcode(lab)
      else if (token == LEXCASE | token == LEXDEFAULT) 
	 {
         for (i = sp; i > 0; i = i - 1)   # find for most recent switch
            if (lextyp(i) == LEXSWITCH)
               break
         if (i == 0)
            call synerr("illegal case or default.")
         else
            call cascod(labval(i), token)
         }
      else if (token == LEXDIGITS)
         call labelc(lexstr)
      else if (token == LEXELSE) 
         {
         if (lextyp(sp) == LEXIF)
            call elseif(labval(sp))
         else
            call synerr("illegal else.")
         }
      else if (token == LEXLITERAL)
	call litral
      if (token == LEXIF | token == LEXELSE | token == LEXWHILE
        | token == LEXFOR | token == LEXREPEAT | token == LEXSWITCH
        | token == LEXDO | token == LEXDIGITS | token == LBRACE) {
         sp = sp + 1         # beginning of statement
         if (sp > MAXSTACK)
            call baderr("stack overflow in parser.")
         lextyp(sp) = token      # stack type and value
         labval(sp) = lab
         }
      else if (token ^= LEXCASE & token ^= LEXDEFAULT) {
         if (token == RBRACE) {
            if (lextyp(sp) == LBRACE)
               sp = sp - 1
            else if (lextyp(sp) == LEXSWITCH) {
               call swend(labval(sp))
               sp = sp - 1
               }
            else
               call synerr("illegal right brace.")
            }
         else if (token == LEXOTHER)
            call otherc(lexstr)
         else if (token == LEXBREAK | token == LEXNEXT)
            call brknxt(sp, lextyp, labval, token)
         else if (token == LEXRETURN)
            call retcod
         else if (token == LEXSTRING)
            call strdcl
         token = lex(lexstr)      # peek at next token
         call pbstr(lexstr)
         call unstak(sp, lextyp, labval, token)
         }
      }
   if (sp ^= 1)
      call synerr("unexpected EOF.")
   return
   end
#-h- unstak           828  asc  27-apr-81 10:26:51  [002,100]
# unstak - unstack at end of statement
   subroutine unstak(sp, lextyp, labval, token)
   integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token
 
   for ( ; sp > 1; sp = sp - 1) {
      if (lextyp(sp) == LBRACE | lextyp(sp) == LEXSWITCH)
         break
      if (lextyp(sp) == LEXIF & token == LEXELSE)
         break
      if (lextyp(sp) == LEXIF)
         call outcon(labval(sp))
      else if (lextyp(sp) == LEXELSE) {
         if (sp > 2)
            sp = sp - 1
         call outcon(labval(sp)+1)
         }
      else if (lextyp(sp) == LEXDO)
         call dostat(labval(sp))
      else if (lextyp(sp) == LEXWHILE)
         call whiles(labval(sp))
      else if (lextyp(sp) == LEXFOR)
         call fors(labval(sp))
      else if (lextyp(sp) == LEXREPEAT)
         call untils(labval(sp), token)
      }
   return
   end

#-h- ulstal           201  asc  27-apr-81 10:26:52  [002,100]
## install both lower and upper case versions of name
 subroutine ulstal(name, defn)

 character name(ARB), defn(ARB)

 call instal(name, defn)
 call upper(name)
 call instal(name, defn)

 return
 end
#-h- repcod           322  asc  27-apr-81 10:26:53  [002,100]
# repeat statement - routines in this group are repcod, untils


# repcod - generate code for beginning of repeat
   subroutine repcod(lab)
   integer labgen
   integer lab
 
   call outcon(0)   # in case there was a label
   lab = labgen(3)
   call outcon(lab)
   lab = lab + 1   # label to go on next's
   return
   end
#-h- untils           388  asc  27-apr-81 10:26:54  [002,100]
# untils - generate code for until or end of repeat
   subroutine untils(lab, token)
   character ptoken(MAXTOK)
   integer lex
   integer junk, lab, token
   # include commonblocks
   include cgoto

   xfer = NO
   call outnum(lab)
   if (token == LEXUNTIL) {
      junk = lex(ptoken)
      call ifgo(lab-1)
      }
   else
      call outgo(lab-1)
   call outcon(lab+1)
   return
   end
#-h- retcod           550  asc  27-apr-81 10:26:55  [002,100]
# return statement


# retcod - generate code for return
   subroutine retcod
   character token(MAXTOK), gnbtok, t
   # include commonblocks
   include cfname
   include cgoto
   string sret "return"

   t = gnbtok(token, MAXTOK)
   if (t ^= NEWLINE & t ^= SEMICOL & t ^= RBRACE) {
      call pbstr(token)
      call outtab
      call outstr(fcname)
      call outch(EQUALS)
      call eatup
      call outdon
      }
   else if (t == RBRACE)
      call pbstr(token)
   call outtab
   call outstr(sret)
   call outdon
   xfer = YES
   return
   end
#-h- strdcl          2531  asc  27-apr-81 10:26:56  [002,100]
# string declaration


# strdcl - generate code for string declaration
   subroutine strdcl
   character t, token(MAXTOK), gnbtok, esc
   integer i, j, k, n, len
   integer length, ctoi, lex, elenth
   character dchar(MAXTOK)
   include csbuf
   string char "character/"
   string dat "data "
   string eoss "EOS/"

   t = gnbtok(token, MAXTOK)
   if (t ^= ALPHA)
      call synerr("missing string token.")
   call outtab
   call pbstr(char)	#use defined meaning of "character"
   repeat
	{
	t = gnbtok(dchar, MAXTOK)
        if (t == SLASH) 
		break
	call outstr (dchar)
	}
   call outch(BLANK)		# separator in declaration
   call outstr(token)
   call addstr(token, sbuf, sbp, SBUFSIZE)  # save for later
   call addchr(EOS, sbuf, sbp, SBUFSIZE)
   if (gnbtok(token, MAXTOK) ^= LPAREN) {  # make size same as initial value
      len = elenth(token) + 1
      if (token(1) == SQUOTE | token(1) == DQUOTE)
         len = len - 2
      }
   else {	# form is string name(size) init
      t = gnbtok(token, MAXTOK)
      i = 1
      len = ctoi(token, i)
      if (token(i) ^= EOS)
         call synerr("invalid string size.")
      if (gnbtok(token, MAXTOK) ^= RPAREN)
         call synerr("missing right paren.")
      else
         t = gnbtok(token, MAXTOK)
      }
   call outch(LPAREN)
   call outnum(len)
   call outch(RPAREN)
   call outdon
   if (token(1) == SQUOTE | token(1) == DQUOTE) {
      len = length(token)
      token(len) = EOS
      call addstr(token(2), sbuf, sbp, SBUFSIZE)
      }
   else
      call addstr(token, sbuf, sbp, SBUFSIZE)
   call addchr(EOS, sbuf, sbp, SBUFSIZE)
   t = lex(token)   # peek at next token
   call pbstr(token)
   if (t ^= LEXSTRING) {   # dump accumulated data statements
      for (i = 1; i < sbp; i = j + 1) {
         call outtab
         call outstr(dat)
         k = 1
         for (j = i + length(sbuf(i)) + 1; ; j = j + 1) {
            if (k > 1)
               call outch(COMMA)
            call outstr(sbuf(i))
            call outch(LPAREN)
            call outnum(k)
            call outch(RPAREN)
            call outch(SLASH)
            if (sbuf(j) == EOS)
               break
#            n = sbuf(j)
            n = esc(sbuf, j)
            call outnum (n)
            call outch(SLASH)
            k = k + 1
            }
         call pbstr(eoss)	# use defined meaning of EOS
         repeat {
            t = gnbtok(token, MAXTOK)
            call outstr(token)
         } until (t == SLASH)
         call outdon
         }
      sbp = 1
      }
   return
   end
#-h- addchr           343  asc  27-apr-81 10:26:59  [002,100]
# miscellaneous routines
# routines in this group are addchr, addstr, alldig, labgen, skpblk


# addchr - put c in buf(bp) if it fits, increment bp
   subroutine addchr(c, buf, bp, maxsiz)
   integer bp, maxsiz
   character c, buf(ARB)
 
   if (bp > maxsiz)
      call baderr("buffer overflow.")
   buf(bp) = c
   bp = bp + 1
   return
   end
#-h- addstr           256  asc  27-apr-81 10:26:59  [002,100]
# addstr - put s in buf(bp) by repeated calls to addchr
   subroutine addstr(s, buf, bp, maxsiz)
   character s(ARB), buf(ARB)
   integer bp, maxsiz
   integer i

   for (i = 1; s(i) ^= EOS; i=i+1)
      call addchr(s(i), buf, bp, maxsiz)
   return
   end
#-h- alldig           303  asc  27-apr-81 10:27:00  [002,100]
# alldig - return YES if str is all digits
   integer function alldig(str)
   character type
   character str(ARB)
   integer i
 
   alldig = NO
   if (str(1) == EOS)
      return
   for (i = 1; str(i) ^= EOS; i = i + 1)
      if (type(str(i)) ^= DIGIT)
         return
   alldig = YES
   return
   end
#-h- labgen           206  asc  27-apr-81 10:27:01  [002,100]
# labgen - generate  n  consecutive labels, return first one
   integer function labgen(n)
   integer n
   # include commonblocks
   include clabel
 
   labgen = label
   label = label + n
   return
   end
#-h- skpblk           219  asc  27-apr-81 10:27:02  [002,100]
# skpblk - skip blanks and tabs in file  fd
   subroutine skpblk(fd)
   integer fd
   character c, ngetch

   for (c = ngetch(c, fd); c == BLANK | c == TAB; c = ngetch(c, fd))
      ;
   call putbak(c)
   return
   end
#-h- cascod          1911  asc  27-apr-81 10:27:03  [002,100]
# switch statement - routines involved are cascod, caslab, swcode, swend, swvar


# cascod - generate code for case or default label
   subroutine cascod(lab, token)
   integer lab, token
   integer t, l, lb, ub, i, j
   character tok(MAXTOK)
   integer caslab, labgen, gnbtok
   include cswtch
   include cgoto

   if (swtop <= 0) {
      call synerr("illegal case or default.")
      return
      }
   call outgo(lab+1)	# terminate previous case
   xfer = YES
   l = labgen(1)
   if (token == LEXCASE) {	# case n[,n]... : ...
      while (caslab(lb, t) ^= EOF) {
         ub = lb
         if (t == MINUS)
            junk = caslab(ub, t)
         if (lb > ub) {
            call synerr("illegal range in case label.")
            ub = lb
            }
         if (swlast + 3 > MAXSWITCH)
            call baderr("switch table overflow.")
         for (i = swtop + 3; i < swlast; i = i + 3)
            if (lb <= swstak(i))
               break
            else if (lb <= swstak(i+1))
               call synerr("duplicate case label.")
         if (i < swlast & ub >= swstak(i))
            call synerr("duplicate case label.")
         for (j = swlast; j > i; j = j - 1)   # insert new entry
            swstak(j+2) = swstak(j-1)
         swstak(i) = lb
         swstak(i+1) = ub
         swstak(i+2) = l
         swstak(swtop+1) = swstak(swtop+1) + 1
         swlast = swlast + 3
         if (t == COLON)
            break
         else if (t ^= COMMA)
            call synerr("illegal case syntax.")
         }
      }
   else { 		# default : ...
      t = gnbtok(tok, MAXTOK)
      if (swstak(swtop+2) ^= 0)
         call error("multiple defaults in switch statement.")
      else
         swstak(swtop+2) = l
      }
   if (t == EOF)
      call synerr("unexpected EOF.")
   else if (t ^= COLON)
      call error("missing colon in case or default label.")
   xfer = NO
   call outcon(l)
   return
   end
#-h- caslab           609  asc  27-apr-81 10:27:05  [002,100]
# caslab - get one case label
   integer function caslab(n, t)
   integer n, t
   character tok(MAXTOK)
   integer i, s
   integer gnbtok, ctoi

   t = gnbtok(tok, MAXTOK)
   while (t == NEWLINE)
      t = gnbtok(tok, MAXTOK)
   if (t == EOF)
      return (t)
   if (t == MINUS)
      s = -1
   else
      s = +1
   if (t == MINUS | t == PLUS)
      t = gnbtok(tok, MAXTOK)
   if (t ^= DIGIT) {
      call synerr("invalid case label.")
      n = 0
      }
   else {
      i = 1
      n = s*ctoi(tok, i)
      }
   t = gnbtok(tok, MAXTOK)
   while (t == NEWLINE)
      t = gnbtok(tok, MAXTOK)
   return
   end
#-h- swcode           733  asc  27-apr-81 10:27:06  [002,100]
# swcode - generate code for beginning of switch statement
   subroutine swcode(lab)
   integer lab
   character tok(MAXTOK)
   integer labgen, gnbtok
   include cswtch
   include cgoto

   lab = labgen(2)
   if (swlast + 3 > MAXSWITCH)
      call baderr("switch table overflow.")
   swstak(swlast) = swtop
   swstak(swlast+1) = 0
   swstak(swlast+2) = 0
   swtop = swlast
   swlast = swlast + 3
   xfer = NO
   call outtab		# Innn=(e)
   call swvar(lab)
   call outch(EQUALS)
   call balpar
   call outdon
   call outgo(lab)	# goto L
   xfer = YES
   while(gnbtok(tok, MAXTOK) == NEWLINE) ;
   if (tok(1) != LBRACE)
      {
      call synerr("missing left brace in switch statement.")
      call pbstr(tok)
      }
   return
   end
#-h- swend           2623  asc  27-apr-81 10:27:08  [002,100]
# swend - finish off switch statement; generate dispatch code
   subroutine swend(lab)
   integer lab
   integer lb, ub, n, i, j
   include cswtch
   include cgoto
   string sif "if("
   string slt ".lt.1.or."
   string sgt ".gt."
   string sgoto "goto("
   string seq ".eq."
   string sge ".ge."
   string sle ".le."
   string sand ".and."

   lb = swstak(swtop+3)
   ub = swstak(swlast-2)
   n = swstak(swtop+1)
   call outgo(lab+1)	# terminate last case
   if (swstak(swtop+2) == 0)
      swstak(swtop+2) = lab + 1		# default default label
   xfer = NO
   call outcon(lab)		# L   continue
   if (n >= CUTOFF & ub - lb + 1 < DENSITY*n) {	# output branch table
      if (lb ^= 1) {		# L  Innn=Innn-lb+1
         call outtab
         call swvar(lab)
         call outch(EQUALS)
         call swvar(lab)
         if (lb < 1)
            call outch(PLUS)
         call outnum(-lb + 1)
         call outdon
         }
      call outtab		#  if(Innn.lt.1.or.Innn.gt.ub-lb+1)goto default
      call outstr(sif)
      call swvar(lab)
      call outstr(slt)
      call swvar(lab)
      call outstr(sgt)
      call outnum(ub - lb + 1)
      call outch(RPAREN)
      call outgo(swstak(swtop+2))
      call outtab		#  goto (....),Innn
      call outstr(sgoto)
      j = lb
      for (i = swtop + 3; i < swlast; i = i + 3) {
         for ( ; j < swstak(i); j = j + 1) {	# fill in vacancies
            call outnum(swstak(swtop+2))
            call outch(COMMA)
            }
         for (j = swstak(i+1) - swstak(i); j >= 0; j = j - 1)
            call outnum(swstak(i+2))	# fill in range
         j = swstak(i+1) + 1
         if (i < swlast - 3)
            call outch(COMMA)
         }
      call outch(RPAREN)
      call outch(COMMA)
      call swvar(lab)
      call outdon
      }
   else if (n > 0) {		# output linear search form
      for (i = swtop + 3; i < swlast; i = i + 3) {
         call outtab		# if(Innn
         call outstr(sif)
         call swvar(lab)
         if (swstak(i) == swstak(i+1)) {
            call outstr(seq)	#   .eq....
            call outnum(swstak(i))
            }
         else {
            call outstr(sge)	#   .ge.lb.and.Innn.le.ub
            call outnum(swstak(i))
            call outstr(sand)
            call swvar(lab)
            call outstr(sle)
            call outnum(swstak(i+1))
            }
         call outch(RPAREN)	#    ) goto ...
         call outgo(swstak(i+2))
         }
      if (lab + 1 ^= swstak(swtop+2))
         call outgo(swstak(swtop+2))
      }
   call outcon(lab+1)			# L+1  continue
   swlast = swtop	# pop switch stack
   swtop = swstak(swtop)
   return
   end
#-h- swvar            153  asc  27-apr-81 10:27:10  [002,100]
# swvar - output switch variable Innn, where nnn = lab
   subroutine swvar(lab)
   integer lab

   call outch(BIGI)
   call outnum(lab)
   return
   end
#-h- whilec           313  asc  27-apr-81 10:27:11  [002,100]
# while statement - routines involved are whilec, whiles


# whilec - generate code for beginning of while
   subroutine whilec(lab)
   integer labgen
   integer lab
 
   call outcon(0)    # unlabeled continue, in case there was a label
   lab = labgen(2)
   call outnum(lab)
   call ifgo(lab+1)
   return
   end
#-h- whiles           143  asc  27-apr-81 10:27:12  [002,100]
# whiles - generate code for end of while
   subroutine whiles(lab)
   integer lab
 
   call outgo(lab)
   call outcon(lab+1)
   return
   end
#-h- litral           646  asc  27-apr-81 10:27:13  [002,100]
 ## litral - process literal ratfor lines
  
  subroutine litral 
  
  integer getlin, index
  integer i
  
 include coutln 
 include cline 
  
 # Finish off any left-over characters 
 if (outp > 0)  call outdon 
 i = getlin (outbuf, infile(level))   # throw away end of current line 
  
  
 #loop through input until matching toggle found 
  
     while ( getlin (outbuf, infile(level)) != EOF ) 
           { 
	   i = 1
           call skipbl (outbuf, i)
           if (outbuf(i) == TOGGLE)
                break 
           call putlin (outbuf, STDOUT) 
           linect(level) = linect(level) + 1 
           } 
  outp = 0 
  return 
  end 
#-h- brknxt          1077  asc  27-apr-81 10:27:14  [002,100]
# break and next statements


# brknxt - generate code for break n and next n; n = 1 is default
   subroutine brknxt(sp, lextyp, labval, token)
   integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token
   integer i, n, alldig, ctoi
   character t, ptoken(MAXTOK), gnbtok
   # include commonblocks
   include cgoto

   n = 0
   t = gnbtok(ptoken, MAXTOK)
   if (alldig(ptoken) == YES) {     # have break n or next n
      i = 1
      n = ctoi(ptoken, i) - 1
      }
   else if (t ^= SEMICOL)      # default case
      call pbstr(ptoken)
   for (i = sp; i > 0; i = i - 1)
      if (lextyp(i) == LEXWHILE | lextyp(i) == LEXDO
        | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) {
         if (n > 0) {
            n = n - 1
            next             # seek proper level
            }
         else if (token == LEXBREAK)
            call outgo(labval(i)+1)
         else
            call outgo(labval(i))
         xfer = YES
         return
         }
   if (token == LEXBREAK)
      call synerr("illegal break.")
   else
      call synerr("illegal next.")
   return
   end
#-h- deftok          2451  asc  27-apr-81 10:27:16  [002,100]
 ## deftok - get token; process macro calls and invocations 
   character function deftok(token, toksiz, fd) 

 character token(MAXTOK)			# formal parameters
 integer toksiz, fd				#    "       "
 character gtok					# external function
 integer lookup, push, ifparm			#     "       "
 character t, c, defn(MAXDEF), balp(3), mdefn(MAXDEF)	# local variables
 integer ap, argstk(ARGSIZE), callst(CALLSIZE), #   "       "
	 nlb, plev(CALLSIZE), ifl

 include cmacro

 data balp/LPAREN, RPAREN, EOS/

 cp = 0
 ap = 1
 ep = 1
 for (t=gtok(token,toksiz,fd); t != EOF; t=gtok(token,toksiz,fd))
    {
    if (t == ALPHA)
	if (lookup(token, defn) == NO)
	    if (cp == 0)
		break
	    else
		call puttok(token)
	else if (defn(1) == DEFTYPE)	# process defines directly
	    {
	    call getdef(token, toksiz, defn, MAXDEF, fd)
	    call instal(token, defn)
	    }
	else if (defn(1) == IFDEFTYPE | defn(1) == IFNOTDEFTYPE)
	    {
	    c = defn(1)
	    call getdef(token, toksiz, defn, MAXDEF, fd)
	    ifl = lookup(token, mdefn)
	    if ((ifl == YES & c == IFDEFTYPE) |
		(ifl == NO & c == IFNOTDEFTYPE))
		call pbstr(defn)
	    }
	else
	    {
	    cp = cp +  1
	    if (cp > CALLSIZE)
		call baderr("call stack overflow.")
	    callst(cp) = ap
	    ap = push(ep, argstk, ap)
	    call puttok(defn)
	    call putchr(EOS)
	    ap = push(ep, argstk, ap)
	    call puttok(token)
	    call putchr(EOS)
	    ap = push(ep, argstk, ap)
	    t = gtok(token, toksiz, fd)
	    call pbstr(token)
	    if (t != LPAREN)
		call pbstr(balp)
	    else if (ifparm(defn) == NO)
		call pbstr(balp)
	    plev(cp) = 0
	    }
    else if (t == LSTRIPC)
	{
	nlb = 1
	repeat
	    {
	    t = gtok(token, toksiz, fd)
	    if (t == LSTRIPC)
		nlb = nlb + 1
	    else if (t == RSTRIPC)
		{
		nlb = nlb - 1
		if (nlb == 0)
		    break
		}
	    else if (t == EOF)
		call baderr("EOF in string.")
	    call puttok(token)
	    }
	}
    else if (cp == 0)
	break
    else if (t == LPAREN)
	{
	if (plev(cp) > 0)
	    call puttok(token)
	plev(cp) = plev(cp) + 1
	}
    else if (t == RPAREN)
	{
	plev(cp) = plev(cp) - 1
	if (plev(cp) > 0)
	    call puttok(token)
	else
	    {
	    call putchr(EOS)
	    call evalr(argstk, callst(cp), ap-1)
	    ap = callst(cp)
	    ep = argstk(ap)
	    cp =  cp - 1
	    }
	}
    else if (t == COMMA & plev(cp) == 1)
	{
	call putchr(EOS)
	ap = push(ep, argstk, ap)
	}
    else
	call puttok(token)
    }
 deftok = t
 if (t == ALPHA)
    call fold(token)

 return
 end
#-h- doarth           962  asc  27-apr-81 10:27:18  [002,100]
# process macros with arguments
# routines involved are doarth, doif, doincr, dosub, evalr, ifparm,
# pbnum, push, putchr, puttok
 ## doarth - do arithmetic operation
 subroutine doarth(argstk,i,j)
 integer ctoi
 integer argstk(ARGSIZE), i, j, k, l, val1, val2
 character op
 include cmacro
  
 k = argstk(i+2)
 l = argstk(i+4)
 op = evalst(argstk(i+3))
 val1 = ctoi(evalst, k)
 val2 = ctoi(evalst, l)
 if (op == PLUS)
	call pbnum(val1+val2)
 else if (op == MINUS)
	call pbnum(val1-val2)
 else if (op ==  STAR )
	call pbnum(val1*val2)
 else if (op ==  SLASH )
	call pbnum(val1/val2)
 else
	call remark('arith error')
 return
 end
  ## domac - install macro definition in table   /*/sor/macror/domac
#    subroutine domac(argstk, i, j)
#    integer a2, a3, argstk(ARGSIZE), i, j
#    include cmacro
# 
#    if (j - i > 2) {
#       a2 = argstk(i+2)
#       a3 = argstk(i+3)
#       call instal(evalst(a2), evalst(a3))   # subarrays
#       }
#    return
#    end
#-h- doif             457  asc  27-apr-81 10:27:20  [002,100]
 ## doif - select one of two (macro) arguments    /*/sor/macror/doif
    subroutine doif(argstk, i, j)
    integer equal
    integer a2, a3, a4, a5, argstk(ARGSIZE), i, j
    include cmacro
 
    if (j - i < 5)
       return
    a2 = argstk(i+2)
    a3 = argstk(i+3)
    a4 = argstk(i+4)
    a5 = argstk(i+5)
    if (equal(evalst(a2), evalst(a3)) == YES)   # subarrays
       call pbstr(evalst(a4))
    else
       call pbstr(evalst(a5))
    return
    end
#-h- doincr           252  asc  27-apr-81 10:27:21  [002,100]
  ## doincr - increment macro argument by 1    /*/sor/macror/doincr
    subroutine doincr(argstk, i, j)
    integer ctoi
    integer argstk(ARGSIZE), i, j, k
    include cmacro
 
    k = argstk(i+2)
    call pbnum(ctoi(evalst, k)+1)
    return
    end
#-h- dosub            711  asc  27-apr-81 10:27:22  [002,100]
  ## dosub - select macro substring   /*/sor/macror/dosub
    subroutine dosub(argstk, i, j)
    integer ctoi, length
    integer ap, argstk(ARGSIZE), fc, i, j, k, nc
    include cmacro
 
    if (j - i < 3)
       return
    if (j - i < 4)
       nc = MAXTOK
    else {
       k = argstk(i+4)
       nc = ctoi(evalst, k)      # number of characters
       }
    k = argstk(i+3)         # origin
    ap = argstk(i+2)         # target string
    fc = ap + ctoi(evalst, k) - 1   # first char of substring
    if (fc >= ap & fc < ap + length(evalst(ap))) {   # subarrays
       k = fc + min(nc, length(evalst(fc))) - 1
       for ( ; k >= fc; k = k - 1)
          call putbak(evalst(k))
       }
    return
    end
#-h- evalr           1452  asc  27-apr-81 10:27:23  [002,100]
 ## evalr - expand args i through j: evaluate builtin or push back defn
    subroutine evalr(argstk, i, j)
    integer index, length
    integer argno, argstk(ARGSIZE), i, j, k, m, n, t, td
    include cmacro
 #   string digits '0123456789'
    character digits(11)
    data digits(1) /DIG0/
    data digits(2) /DIG1/
    data digits(3) /DIG2/
    data digits(4) /DIG3/
    data digits(5) /DIG4/
    data digits(6) /DIG5/
    data digits(7) /DIG6/
    data digits(8) /DIG7/
    data digits(9) /DIG8/
    data digits(10) /DIG9/
    data digits(11) /EOS/
 
    t = argstk(i)
    td = evalst(t)
#    if (td == MACTYPE)
#       call domac(argstk, i, j)
#    else if (td == INCTYPE)
    if (td == INCTYPE)
       call doincr(argstk, i, j)
    else if (td == SUBTYPE)
       call dosub(argstk, i, j)
    else if (td == IFTYPE)
       call doif(argstk, i, j)
    else if (td == ARITHTYPE)
        call doarth(argstk, i, j)
    else {
       for (k = t+length(evalst(t))-1; k > t; k = k - 1)
          if (evalst(k-1) != ARGFLAG)
             call putbak(evalst(k))
          else {
             argno = index(digits, evalst(k)) - 1
             if (argno >= 0 & argno < j-i) {
                n = i + argno + 1
                m = argstk(n)
                call pbstr(evalst(m))
                }
             k = k - 1   # skip over $
             }
       if (k == t)         # do last character
          call putbak(evalst(k))
       }
    return
    end
#-h- ifparm           690  asc  27-apr-81 10:27:25  [002,100]
# ifparm - determines if the defined symbol has arguments in its
# definition.  This effects how the macro is expanded.
 integer function ifparm(strng)

 character strng(ARB), c
 integer i, index, type

 c = strng(1)
 if (c == INCTYPE | c == SUBTYPE | c == IFTYPE |
     c == ARITHTYPE | c == IFDEFTYPE | c == IFNOTDEFTYPE)
    ifparm = YES
 else
    {
    ifparm = NO
    for (i=1; index(strng(i), ARGFLAG) > 0; )
       {
       i = i + index(strng(i), ARGFLAG)	# i points at char after ARGFLAG
       if (type(strng(i)) == DIGIT)
           andif (type(strng(i+1)) != DIGIT)
               {
               ifparm = YES
               break
               }
       }
    }

 return
 end
#-h- pbnum            676  asc  27-apr-81 10:27:26  [002,100]
 ## pbnum - convert number to string, push back on input    /*/sor/macror/pbnum
    subroutine pbnum(n)
    integer mod
    integer m, n, num
 #   string digits '0123456789'
    character digits(11)
    data digits(1) /DIG0/
    data digits(2) /DIG1/
    data digits(3) /DIG2/
    data digits(4) /DIG3/
    data digits(5) /DIG4/
    data digits(6) /DIG5/
    data digits(7) /DIG6/
    data digits(8) /DIG7/
    data digits(9) /DIG8/
    data digits(10) /DIG9/
    data digits(11) /EOS/
 
    num = abs(n)
    repeat {
       m = mod(num, 10)
       call putbak(digits(m+1))
       num = num / 10
       } until (num == 0)
    if (n < 0)
	call putbak(MINUS)
    return
    end
#-h- push             276  asc  27-apr-81 10:27:27  [002,100]
 ## push - push ep onto argstk, return new pointer ap   /*/sor/macror/push
    integer function push(ep, argstk, ap)
    integer ap, argstk(ARGSIZE), ep
 
    if (ap > ARGSIZE)
       call baderr('arg stack overflow.')
    argstk(ap) = ep
    push = ap + 1
    return
    end
#-h- putchr           255  asc  27-apr-81 10:27:28  [002,100]
 ## putchr - put single char into eval stack  /*/sor/macror/putchr
    subroutine putchr(c)
    character c
    include cmacro
 
    if (ep > EVALSIZE)
       call baderr('evaluation stack overflow.')
    evalst(ep) = c
    ep = ep + 1
    return
    end
#-h- puttok           216  asc  27-apr-81 10:27:29  [002,100]
 ## puttok-put token into eval stack  /*/sor/macror/puttok
    subroutine puttok(str)
    character str(MAXTOK)
    integer i
 
    for (i = 1; str(i) != EOS; i = i + 1)
       call putchr(str(i))
    return
    end
#-h- elenth           262  asc  27-apr-81 10:27:30  [002,100]
# calculate length of buf, taking escaped characters into account
 integer function elenth(buf)

 character buf(ARB), c
 character esc
 integer i, n

 n = 0
 for (i=1; buf(i) != EOS; i=i+1)
    {
    c = esc(buf, i)
    n = n + 1
    }
 elenth = n

 return
 end
#-h- rat4.rof       15755  asc  08-may-81 17:05:33  [002,100]
..... For VAX/VMS and RSX versions, use .pl 60
.pl 60
.bp 
.in 0 
.he 'RAT4'06/12/80'RAT4'
.fo ''-#-'' 
.fi 
.in 7 
.ti -7 
NAME 
.br 
rat4 - Ratfor preprocessor
.sp 1 
.ti -7 
SYNOPSIS 
.br 
rat4 [files ...] >outfile
.sp 1 
.ti -7 
DESCRIPTION 
.br 
rat4 translates the ratfor programs in the named files into Fortran.
If no input files are given, or the filename '-' appears, the
standard input will be read.
 
A file containing general purpose software tools definitions
(e.g. EOF, NEWLINE, EOS, etc.) will be automatically opened and
processed before any of the files specified are read.
.sp 2 
Syntax:
 
Ratfor has the following syntax:
.nf
           prog:   stmt
                   prog stmt
           stmt:   if (expr) stmt
                   if (expr) stmt else stmt
                   while (expr) stmt
                   repeat (expr) stmt
                   repeat stmt until (expr)
                   for (init expr; test expr; incr expr) stmt
                   do expr stmt
                   do n expr stmt
                   break
                   break n
                   next
                   next n
                   return (expr)
                   switch (expr)
                     {
                     case expr:  stmt
                     ....
                     default: stmt
                     }
                   digits stmt
.mc | 2
                   { prog }  or  [ prog ]
.mc
                   anything unrecognizable (i.e. fortran)
           
.fi
where 'stmt' is any Fortran or Ratfor statement.
A statement is terminated by an end-of-line or a semicolon.
.sp
.ne 11
Character Translation:
.sp
The following character translations are performed:
.in +5
.nf
<       .lt.
<=      .le.
==      .eq.
!=      .ne.         ^=      .ne.         ~=      .ne.
>=      .ge.
>       .gt.
|       .or.
&       .and.
!       .not.        ^       .not.        ~       .not.
.in -5
.fi
.sp 2
Included files:
 
.fi
The statement
 
.in +15
.nf
include file        or
include "file"
.in -15
 
.fi
will insert the contents of the specified file into the ratfor input
in place of the 'include' statement.
Quotes must surround the file name if it contains characters other
than alphanumerics, underscores, or dots.
.sp 2
.mc | 2
Macro Definitions:

The statement

.ti +15
define(name,replacement text)

defines 'name' as a macro which will be replaced with the indicated text
when encountered in the source files.  Any occurrences of the strings
'$n' in the replacement text, where 1 <= n <= 9, will be replaced with the
nth argument when the macro is actually invoked.  For example:

.ti +15
define(bump, $1 = $1 + 1)

will cause the source line

.ti +15
bump(i)

to be expanded into

.ti +15
i = i + 1

The names of macros may contain letters, digits, periods and underline
characters, but must start with a letter (e.g. B.FLAG).  Upper case is
not equivalent to lower case in macro names.

The replacement text is copied directly into the lookup table with no
intepretation of the arguments, which differs from the procedure used in
the macro utility.  This "deferred evaluation" has the effect of eliminating
the need for quoting strings to get them through the macro processor
unchanged.  A side effect of the deferred evaluation is that defined names
cannot be forced through the processor - i.e. the string define will never
be output from the preprocessor.
The inequivalence of upper and lower case in macro names may be used in this
case to force the name of a user defined macro onto the output - i.e. if the
user has defined a macro named mymac, the replacement text may contain the
string MYMAC, which is not defined, and will pass through the processor.

In addition to define, four other built-in macros are provided:

.in +17
.ti -16
arith(x,op,y)   performs the "integer" arithmetic specified by op (+,-,*,/)
on the two numeric operands and returns the result as its replacement.
.ti -16
incr(x)         converts the string x to a number, adds one to it, and returns
the value as its replacement (as a character string).
.ti -16
ifelse(a,b,c,d) compares a and b as character strings; if they are the same,
c is pushed back onto the input, else d is pushed back.
.ti -16
substr(s,m,n)   produces the substring of s which starts at position m
(with origin one), of length n.  If n is omitted or too big, the rest of
the string is used, while if m is out of range the result is a null string.
.in -17

Note: the statement

.ti +15
define name text

may also be used, but will not always perform correctly for macros with
parameters or multi-line replacement text.  It is suggested that the functional
form be preferred.


.ne 9
Conditional Preprocessing:

The statements

.in +15
ifdef(macro,text)
.br
ifnotdef(macro,text)
.in -15

conditionalize the preprocessing upon whether the macro has been previously
defined or not.
.br
.mc


String Data Types:
 
The statements
 
.in +10
string name "character string"          or
.br
string name(size) "character string"
 
.in -10
declare 'name' to be a character array long enough to accomodate
the ascii codes for the given character string, one per array
element.
The array is then filled by data statements.
The last word of 'name' is initialized to the symbolic parameter
EOS, and indicates the end of a string.
EOS must be defined either in the standard definitions file or
by the user.
If a size is given, name is declared to be a character array
of 'size' elements.
If several string declarations appear consecutively, the 
generated declarations for the arrays will precede the data
statements that initialize them.
Escape sequences are recognized in string declarations, such that
@n maps into the NEWLINE character and @t maps into the TAB character.
@c for any other character simply maps into the character c.  In
particular, to embed an atsign '@' in a string, one must type '@@'.
.sp 2
String Literals:
 
Conversion of in-line quoted strings to hollerith constants is performed
in the following manner:
 
.in +5
.nf
"str"         nHstr     
'str'         nHstr
         (where 'n' is the number of characters in str)
.in -5
.br
.fi
String literals can be continued across line boundaries by ending
the line to be continued with an underline.
The underline is not included as part of the literal.
Leading blanks and tabs on the next line are ignored.
.sp 2
Integer Constants:
 
Integer constants in bases other than decimal may be specified
as n%dddd... where 'n' is a decimal number indicating
the base and 'dddd...' are digits in that base.
For bases > 10, letters are used for digits above 9.
Examples include:  8%77 (=63), 16%2ff (=767), 2%0010011 (=19).
The number is converted to the equivalent decimal value using
multiplication; this may cause sign problems if the number has
too many digits.
.sp 2
Lines and Continuation:
 
.fi
Input is free-format; that is, statements may appear anywhere
on a line.
Lines ending with a comma, +, -, or * are assumed to be continued
on the next line.
An exception to this rule is within a condition; the line
is assumed to be continued if the condition does not fit on one line.
Explicit continuation is indicated by ending a line with an
underline character (_).
The underline character is not copied to the output file.
.sp 2
Comments:
 
Comments are preceded by '#' signs and may appear anywhere in
the code.
.sp 2
Literal (unprocessed) Lines:
 
Lines can be passed through rat4 without being processed by
preceding and following the blocks of lines with a line containing
only a '%'.
The '%' lines will not be copied to standard output.
.sp 4
.ti -7
CHANGES
.br
This ratfor preprocessor differs from the original (as released
by Kernighan and Plauger) in the following ways:
 
The code has been rewritten and reorganized for clarity.
 
A hash table has been added for increased efficiency in searching
the definitions list.
 
The 'string' data type has been included.
 
.mc | 2
The define processor has been augmented to support macros with arguments.

Conditional preprocessing upon the definition (or lack therof) of a
symbol has been included.
.br
.mc

Many extraneous gotos have been avoided.
 
Some blanks have been included in the output for increased readability.
 
Multi-level 'break' and 'next' statements have been included.
 
The Fortran 'DO' is allowed, as well as the ratfor one.
 
The capability of specifying integer constants in bases other than
decimal has been added.
 
Underscores and dots have been allowed in defined names.
 
The 'define' syntax has been expanded to include the form:
.ce
define name value
 
The 'return(value)' feature has been added.
 
Quoted file names following 'include' statements have been added
to allow for special characters in file names.
 
A toggle for allowing lines to pass through un-processed has been added.
 
The 'switch' control statement has been included.
 
Continuation lines have been implemented.
 
.mc | 2
Brackets have been allowed to replace braces.
.br
.mc
.sp 3
.ti -7 
FILES 
.br 
A generalized definition file (e.g. 'ratdef') is automatically
opened and read.
.sp 3 
.ti -7 
SEE ALSO 
.br 
.nf 
Kernighan and Plauger's "Software Tools" 
Kernighan's "RATFOR - A Preprocessor for a Rational Fortran" 
The Unix command rc in the Unix Manual 
The tools 'incl' and 'macro'
.fi 
.sp 1 
.ti -7 
DIAGNOSTICS 
.br 
(The errors marked with asterisk '*' are fatal; all others are simply
warning messages.)
.sp 1
.in +5
.mc | 2
.ti -5
* arg stack overflow
.br
The argument stack for the macro processor has been exceeded.  The size of the
stack is determined by the symbol ARGSIZE in the file macsym.
.br
.mc
.ti -5
* buffer overflow
.br
One of the preprocessor's internal buffers overflowed,
possibly, but not necessarily, because the string buffers
were exceeded.
The definition SBUFSIZE in the preprocessor symbols file 
determines the size
of the string buffers.
.br
.ti -5
.mc | 2
* call stack overflow
.br
The call stack (used to store call frames) in the macro processor has
been exceeded.  The definition CALLSIZE in the file macsym determines the
size of this stack.
.br
.mc
.ti -5
can't open standard definitions file
.br
The special file containing general purpose ratfor definitions
could not be opened, possibly because it did not exist or the
user did not have access to the directory on which it resides.
.br
.ti -5
can't open include 
.br 
File to be included could not be located,
the user did not have privilege to access it,
or the file could not be opened due to some problem in the
local primitives.
.br 
.ti -5 
* definition too long 
.br 
The number of characters in the name to be defined exceeded 
Ratfor's internal array size.
The size is defined by the MAXTOK definition in the preprocessor 
symbols file.
.br 
.ti -5
.mc | 2
* EOF in string
.br
The macro processor detected an EOF in the current input file while
evaluating a macro.
.ti -5
* evaluation stack overflow
.br
The evaluation stack for the macro processor has been exceeded.
This stack's size is determined by the symbol EVALSIZE in the file macsym.
.br
.mc
.ti -5
* for clause too long
.br
The internal buffer used to hold the clauses for the 'for'
statement was exceeded.
Size of this buffer is determined by the MAXFORSTK definition
in the preprocessor symbols file.
.br
.ti -5
* getdef is confused
.br
There were horrendous problems when attempting to access
the definition table
.br
.ti -5 
illegal break 
.br 
Break did not occur inside a valid "while", "for", or "repeat" loop 
.br 
.ti -5 
illegal else 
.br 
Else clause probably did not follow an "if" clause 
.br 
.ti -5 
illegal next 
.br 
"Next" did not occur inside a valid "for", "while", or "repeat" loop 
.br 
.ti -5 
illegal right brace 
.br 
A right brace was found without a matching left brace 
.br 
.ti -5 
includes nested too deeply 
.br 
There is a limit to the level of nesting of included files.
It is dependent upon the maximum number of opened files allowed
at a time,
and is set by the
NFILES definition in the preprocessor symbols file.
.br 
.ti -5 
invalid for clause 
.br 
The "for" clause did not contain a valid init, condition, and/or 
increment section 
.ti -5
invalid string size
.br
The string format 'string name(size) "..."' was used, but the
size was given improperly.
.br
.ti -5 
* missing comma in define 
.br 
Definitions of the form 'define(name,defn)' must include the
comma as a separator.
.br 
.br 
.ti -5
missing function name
.br
There was an error in declaring a function
.br
.ti -5 
missing left paren 
.br 
A parenthesis was expected, probably in an "if" statement, but 
not found 
.br 
.ti -5 
missing parenthesis in condition 
.br 
A right parenthesis was expected, probably in an "if" statement, 
but not found 
.br 
.ti -5 
missing quote 
.br 
A quoted string was not terminated by a quote 
.br 
.ti -5 
missing right paren 
.br 
A right parenthesis was expected in a Fortran (as opposed to 
Ratfor) statement but not found 
.br 
.ti -5
missing string token
.br
No array name was given when declaring a string variable
.br
.ti -5 
* non-alphanumeric name 
.br 
Definitions may contain only alphanumeric characters, dots,
and underscores.
.br 
.ti -5 
* stack overflow in parser 
.br 
Statements were nested at too deep a level. 
The stack depth is set by the MAXSTACK definition in the
preprocessor symbols file.
.br 
.ti -5 
token too long 
.br 
A token (word) in the source code was too long to fit into one 
of Ratfor's internal arrays. 
The maximum size is set by the MAXTOK definition in the
preprocessor symbols file.
.br 
.ti -5 
* too many characters pushed back 
.br 
The source code has illegally specified a Ratfor command, or has 
used a Ratfor keyword in an illegal manner, and the parser has 
attempted but failed to make sense out of it 
The size of the push-back buffer is set by BUFSIZE in the
preprocessor symbols file.
.br 
.ti -5 
too many definitions 
.br 
Ratfor's internal arrays could not hold all the definitions. 
The size of the definition table is determined by the MAXTBL
and MAXPTR definitions in the preprocessor symbols file.
.br 
.ti -5 
unbalanced parentheses 
.br 
Unbalanced parentheses detected in a Fortran (as opposed 
to Ratfor) statement 
.br 
.ti -5 
unexpected brace or EOF 
.br 
A brace occurred after a Fortran (but not Ratfor) statement 
or an end-of-file was reached before the end of a statement 
.br 
.ti -5 
unexpected EOF 
.br 
An end-of-file was reached before all braces had been 
accounted for.  This is usually caused by unmatched braces 
somewhere deep in the source code. 
.br 
.ti -5 
warning:  possible label conflict 
.br 
This message is printed when the user has labeled a statement 
with a label in the 23000-23999 range.  Ratfor statements are 
assigned in this range and a user-defined one may conflict 
with a Ratfor-generated one. 
.br 
.ne 3
.ti -5 
"file":  cannot open
.br 
Ratfor could not open an input file specified by the user
on the command line.
.br 
.in -5
.sp 2 
.ti -7 
AUTHORS 
.br 
Original by B. Kernighan and P. J. Plauger, with rewrites and
enhancements by David Hanson and friends (U. of Arizona),
Joe Sventek and Debbie Scherrer (Lawrence Berkeley Laboratory).
.sp 1 
.ti -7 
BUGS/DEFICIENCIES 
.br 
  
The line numbers given in error messages are NOT correct. 
They indicate only a general area in which to look for the error. 
  
Missing parentheses or braces may cause erratic behavior, including a 
read-past-eof message.  Eventually  Ratfor should be taught 
to terminate parentheses/brace checking at the end of each subroutine. 
 
Extraneous 'continue' statements are generated within Fortran
'do' statements.
 
There is no way to explicitly cause a statement to begin in column 6
(i.e. a Fortran continued statement),
although implicit continuation is performed.