# FILE 8 SOFTWARE TOOLS FROM LBL

 ##################################################################
 #                                                                #
 #           Part 1 - Symbols and common blocks for the           #
 #                    ratfor preprocessor                         #
 #           Extract each one and place it on a file              #
 #                     with the name specified                    #
 #                                                                #
 ##################################################################

 #-----------------------------------------------------------------------
 ## definitions for the preprocessor (hashed version from Dave Hanson)
 # put on a file named 'rat4sym'
 # Used by ratfor preprocessor, macro, and form tools

  define(BUFSIZE,300)       #pushback buffer for ngetch and putbak
  define(DEFTYPE,-4)
  define(LEXBREAK,-8)
  define(LEXDIGITS,-9)
  define(LEXDO,-10)
  define(LEXELSE,-11)
  define(LEXFOR,-16)
  define(LEXIF,-12)
  define(LEXLITERAL,-19)
  define(LEXNEXT,-13)
  define(LEXOTHER,-14)
  define(LEXREPEAT,-17)
  define(LEXRETURN,-20)
  define(LEXUNTIL,-18)
  define(LEXWHILE,-15)
  define(MAXCHARS,10)      # characters for outnum
                           # (should be compatible with "putdec")
  define(MAXDEF,200)       #max chars in a definition
  define(MAXFILE,15)        #max files which can be open at a time
  define(MAXFNAMES,150)
  define(MAXFORSTK,200)    #max space for for reinit clauses
  define(MAXNAME,30)       #file name size in gettok
  define(MAXPTR,650)       #number of defines in lookup
  define(MAXSTACK,100)     #max stack depth for parser
  define(MAXTBL,6500)      #max chars in all definitions
  define(MAXTOK,200)       #max chars in a token
  define(NFILES,11)         #max depth of file inclusion
                           #(should be max nbr open files allowed - 4)
  define(TOGGLE,PERCENT)   #literal toggle flag
 #----------------------------------------------------------------------

 ## preprocessor common block to hold input characters
 # Put on a file called 'cdefio'
 # Used by ratfor preprocessor, macro, form, and shell tools

 common /cdefio/ bp, buf(BUFSIZE)
   integer bp           # next available character; init = 0
   character buf        # pushed-back characters
 #--------------------------------------------------------------------------
 ## preprocessor common block to hold current function name
 # put on a file named 'cfname'
 # Used only by ratfor preprocessor

 common /cfname/  fcname(MAXNAME)
   character fcname     #text of current function name
 #--------------------------------------------------------------------------
 ## preprocessor common block to hold info about 'for' statements
 # put on a file named 'cfor'
 # Used only by ratfor preprocessor

 common /cfor/  fordep, forstk (MAXFORSTK)
   integer fordep       # current depth of for statements
   character forstk     # stack of reinit strings
 #--------------------------------------------------------------------
 ## preprocessor common block to hold 'goto' flags
 # put on a file named 'cgoto'
 # Used only by ratfor preprocessor

 common /cgoto/ xfer
        integer xfer    #YES if just made transfer; else NO
 #--------------------------------------------------------------------
 ## preprocessor common block to hold ratfor keywords
 # put on a file named 'ckeywd'
 # Used only by ratfor preprocessor

common /ckeywd/ sdo, sif, selse, swhile, sbreak, snext,
   sfor, srept, suntil, slitrl,  sret,
   vdo, vif, velse, vwhile, vbreak, vnext, vfor, vrept, vuntil,
   vlitrl , vret

   character sdo(4), sif(4), selse(6), swhile(6), sbreak(6), snext(6)
   character sfor(4), srept(8), suntil(6), slitrl(2) , sret(8)
   integer vdo(2), vif(2), velse(2), vwhile(2), vbreak(2), vnext(2)
   integer vfor(2), vrept(2), vuntil(2), vlitrl(2) , vret(2)

 #NOTE: On the IAS and VMS implementations, where characters are stored
 #      as logical*1 (bytes), DEC requires that common block dimensions
 #      be an even number.   These dimensions have been adjusted
 #      accordingly.
 #------------------------------------------------------------------
 ## preprocessor common block 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
 #--------------------------------------------------------------------
 ## preprocessor common block to hold definitions
 # put on a file named 'clook'
 # Used by ratfor preprocessor, macro, and form tools

 common /clook/ avail, tabptr(127), table(MAXTBL)

        integer avail   #first location in table; init = 1
        integer tabptr  #name poiners; init = 0
        integer table   #actual text of names and definitions
 #------------------------------------------------------------------
 ## preprocessor common block to hold output characters
 # put on a file named 'coutln'
 # Used only by ratfor preprocessor

 common /coutln/ outp, outbuf(MAXLINE)
  integer outp          # last position filled in outbuf; init = 0
  character outbuf      # output lines collected here
 #------------------------------------------------------------------
#-h- RAT4.R 39062 asc  8-JUN-79 13:30:01
#-h- MAIN 575 13-JAN-79 20:50:16
 #--------------------------------------------------------------------
 #include symbols definitions
 #      include symbols
        include rat4sym
 #--------------------------------------------------------------------
##      rat4 -- main program


#BKY    subroutine driver
        call initr4
        call rat4
        call endr4
        end

#BKY   #assembly code main program (used to avoid loading fortran I/O)
#BKY %
#BKY         ident main
#BKY         entry main
#BKY         vfd   42/0lmain,18/main
#BKY         ext   driver
#BKY         rj    uzero00
#BKY         rj    driver
#BKY         end   main
#BKY%
#-h- RAT4S 1748 asc  8-JUN-79 13:29:35
  ##rat4 - driver subroutine for ratfor compiler     /*/sor/rat4r/rat4s
   subroutine rat4

   integer getarg, open
    character buf(MAXLINE)

    character sym(FILENAMESIZE)         #file containing general definitions
    character symbls(8)                 #standard part of file spec for symbols
    integer i
   #BKY  integer ovride, inbuf(OPTSIZE), outbf(OPTSIZE)

   include cline        #needed to set input file

 # initialize standard part of file specification

 data symbls /LETS, LETY, LETM, LETB, LETO, LETL, LETS, EOS/

 #set STDOUT file type to that needed by fortran compiler
 #BKY   if (ovride (STDOUT) == NO)
 #BKY        call settyp (STDOUT, CDC)

 #Expand I/O buffers for BKY
 #BKY   call xpdfet (STDOUT, outbf, OPTSIZE)

  call initrt   #initialize variables

 # read file containing standard definitions
 # (remove this section if desired)
 call usrbin(sym)                       # get portion of file name for usr/bin
 for (i=1; sym(i) ^= EOS; i=i+1) ;      # move pointer to end
 call scopy(symbls, 1, sym, i)          # copy remainder of name into sym
 infile(1) = open (sym, READ)
 if (infile(1) == ERR)
        call remark ("can't open symbols file")
 else
        {
        call parse
        call close (infile(1))
        }

  # loop through all input files
 for (i=1; ; i=i+1)
        {
        if (getarg(i,buf,MAXLINE) == EOF)
                {
                if (i ^= 1)
                        break
                infile(1) = STDIN
                }
        else if (buf(1) == QMARK & buf(2) == EOS)
                call error ('usage:  rat4  file ...! >outfile.')
        else if (buf(1) == MINUS & buf(2) == EOS)
                infile(1) = STDIN
        else
                {
                infile(1) = open(buf,READ)
                if (infile(1) == ERR)
                        call cant(buf)
                }
 #For BKY, expand input buffer
 #BKY      call xpdfet (infile(1), inbuf, OPTSIZE)


        call parse
        if (infile(1) ^= STDIN)
                call close(infile(1))
      }


    return
    end
#-h- BALPAR 807 08-NOV-78 19:36:12
 ## balpar - copy balanced paren string
   subroutine balpar
   character gettok
   character t, token(MAXTOK)
   integer nlpar

   if (gettok(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- BRKNXT 1059 08-NOV-78 20:52:19
 ## 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), gettok

   include cgoto

   n = 0
   t = gettok(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
            }
         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 757 08-NOV-78 19:36:16
 ## deftok - get token; process macro calls and invocations
   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
#-h- DOCODE 405 08-NOV-78 19:36:39
 ## docode - generate code for beginning of do
   subroutine docode(lab)
   integer labgen
   integer lab

   include cgoto
#   string dostr 'do'
   character dostr(4)
   data dostr(1), dostr(2), dostr(3),

      dostr(4)/LETD, LETO, BLANK, EOS/

   xfer = NO
   call outtab
   call outstr(dostr)
   lab = labgen(2)
   call outnum(lab)
   call eatup
   call outdon
   return
   end
#-h- DOSTAT 161 08-NOV-78 19:36:41
 ## dostat - generate code for end of do statement
   subroutine dostat(lab)
   integer lab

   call outcon(lab)
   call outcon(lab+1)
   return
   end
#-h- EATUP 1070 08-NOV-78 19:36:42
 ## 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- ELSEIF 162 08-NOV-78 19:36:44
 ## elseif - generate code for end of if before else
   subroutine elseif(lab)
   integer lab

   call outgo(lab+1)
   call outcon(lab)
   return
   end
#-h- FORCOD 2368 08-NOV-78 19:36:46
 ## forcod - beginning of for statement
   subroutine forcod(lab)
   character gettok
   character t, token(MAXTOK)
   integer length, labgen
   integer i, j, lab, nlpar

   include cfor
#   string ifnot 'if(.not.'
   character ifnot(9)
   data ifnot(1) /LETI/
   data ifnot(2) /LETF/
   data ifnot(3) /LPAREN/
   data ifnot(4) /PERIOD/
   data ifnot(5) /LETN/
   data ifnot(6) /LETO/
   data ifnot(7) /LETT/
   data ifnot(8) /PERIOD/
   data ifnot(9) /EOS/

   lab = labgen(3)
   call outcon(0)
   if (gettok(token, MAXTOK) ^= LPAREN) {
      call synerr('missing left paren.')
      return
      }
   if (gettok(token, MAXTOK) ^= SEMICOL) {   # real init clause
      call pbstr(token)
      call outtab
      call eatup
      call outdon
      }
   if (gettok(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
   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 error('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 469 08-NOV-78 19:37:16
 ## fors - process end of for statement
   subroutine fors(lab)
   integer length
   integer i, j, lab

   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- GETDEF 1591 08-NOV-78 19:37:18
 ## 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)

   c = gtok(ptoken, MAXTOK, fd)
   if (c == LPAREN)
       t = LPAREN             # define (name, defn)
   else {
       t = BLANK              # define name defn
       call pbstr(ptoken)
       }
   if (gtok(token, toksiz, fd) ^= ALPHA)
      call error('non-alphanumeric name.')
   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 error('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 error('missing comma in define.')
      # else got (name,
      nlpar = 0
      for (i = 1; nlpar >= 0; i = i + 1)
         if (i > defsiz)
            call error('definition too long.')
         else if (ngetch(defn(i), fd) == EOF)
            call error('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 error('getdef is confused.')
   defn(i-1) = EOS
   return
   end
#-h- GETTOK 2888 16-NOV-78 18:13:53
 ## gettok - get token. handles file inclusion and line numbers
   character function gettok(token, toksiz)
   integer equal, open
   integer t, i, j, toksiz
   character deftok
   character name(FILENAMESIZE), token(MAXTOK), filnam(FILENAMESIZE)

   include cline
   include cfname
#   string incl 'include'
   character incl(8)
#   string fncn 'function'
   character fncn(9)
   data incl(1) /LETI/
   data incl(2) /LETN/
   data incl(3) /LETC/
   data incl(4) /LETL/
   data incl(5) /LETU/
   data incl(6) /LETD/
   data incl(7) /LETE/
   data incl(8) /EOS/
   data fncn(1) /LETF/
   data fncn(2) /LETU/
   data fncn(3) /LETN/
   data fncn(4) /LETC/
   data fncn(5) /LETT/
   data fncn(6) /LETI/
   data fncn(7) /LETO/
   data fncn(8) /LETN/
   data fncn(9) /EOS/

   for ( ; level > 0; level = level - 1) {
      for (gettok = deftok(token, toksiz, infile(level)); gettok ^= EOF;
         gettok = deftok(token, toksiz, infile(level))) {
         if (equal(token, fncn) == YES) {
            t = deftok(fcname, FILENAMESIZE, infile(level))
            call pbstr(fcname)
            return
            }
         if (equal(token, incl) == NO)
            return

         i = 0
         #pick up file name -- watch out for characters that might
         #have been prnnessed by deftoo
         repeaq {
            t = degtok(name, FILENAMESIZE, infile(level))

            for (j = 1; name(j) ^= EOS; j = j + 1) {
               i = i + 1
               filnam(i) = name(j)
 #IAS          if (filnam(i) == LBRACE)  filnam(i) = LBRACK
 #IAS          if (filnam(i) == RBRACE)  filnam(i) = RBRACK
               ig (filnam(i) == LBRACE)  filnam(i) = LBRACK
               if (filnam(i) == RBRACE)  filnam(i) = RBRACK
               }
         } until (t == NEWLINE | t == SEMICOL)
         filnam(i) = EOS
         if (level >= NFILES)
            call synerr('includes nested too deeply.')
         else {
            infile(level+1) = open(filnam, READ)
            linect(level+1) = 1
            if (infile(level+1) == ERR)
               {
               call putlin(filnam, ERROUT)
               call synerr ("can't open include.")      #NOTIAS
 #IAS          call synerr ('can''t open include')
               }
            else {
               level = level + 1
               if (fnamp + i <= MAXFNAMES) {
                  call scopy(filnam, 1, fnames, fnamp)
                  fnamp = fnamp + i    # push file name stack
                  }
               }
            }
         }
      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- GTOK 2029 08-NOV-78 19:37:23
 ## gtok - get token for Ratfor
   character function gtok(lexstr, toksiz, fd)
   character ngetch, type
   integer fd, i, toksiz
   character c, lexstr(MAXTOK)

   include cline

   while (ngetch(c, fd) ^= EOF)
      if (c ^= BLANK & c ^= TAB)
         break
   call putbak(c)
   for (i = 1; i < toksiz-1; i = i + 1) {

      gtok = type(ngetch(lexstr(i), fd))
      if (gtok ^= LETTER & gtok ^= DIGIT)
         break
      }
   if (i >= toksiz-1)
      call synerr('token too long.')
   if (i > 1) {            # some alpha seen
      call putbak(lexstr(i))      # went one too far
      lexstr(i) = EOS
      gtok = ALPHA
      }
   else if (lexstr(1) == LBRACK) {   # allow   for {
      lexstr(1) = LBRACE
      gtok = LBRACE
      }
   else if (lexstr(1) == RBRACK) {   # allow ! for }
      lexstr(1) = RBRACE
      gtok = RBRACE
      }
   else if (lexstr(1) == 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))
      }
   else if (lexstr(1) == SQUOTE | lexstr(1) == DQUOTE) {
      for (i = 2; ngetch(lexstr(i), fd) ^= lexstr(1); i = i + 1)
         if (lexstr(i) == NEWLINE | i >= toksiz-1) {
            call synerr('missing quote.')
            lexstr(i) = lexstr(1)
            call putbak(NEWLINE)
            break
            }
      }
   else if (lexstr(1) == SHARP) {   # strip comments
      while (ngetch(lexstr(1), fd) ^= NEWLINE)
         ;
      gtok = NEWLINE
      }
   else if (lexstr(1) == GREATER | lexstr(1) == LESS | lexstr(1) == NOT
      | lexstr(1) == BANG | lexstr(1) == CARET
      | lexstr(1) == EQUALS | lexstr(1) == AND | lexstr(1) == OR)
      call relate(lexstr, i, fd)
   lexstr(i+1) = EOS
   if (lexstr(1) == NEWLINE)
      linect(level) = linect(level) + 1
   return
   end
#-h- IFCODE 203 08-NOV-78 19:37:25
 ## ifcode - generate initial code for if

   subroutine ifcode(lab)
   integer labgen
   integer lab

   include cgoto

   xfer = NO
   lab = labgen(2)
   call ifgo(lab)
   return
   end
#-h- IFGO 634 08-NOV-78 19:37:26
 ## ifgo - generate 'if(.not.(...))goto lab'
   subroutine ifgo(lab)
   integer lab
#   string ifnot 'if(.not.'
   character ifnot(9)
      data ifnot(1) /LETI/
      data ifnot(2) /LETF/
      data ifnot(3) /LPAREN/
      data ifnot(4) /PERIOD/
      data ifnot(5) /LETN/
      data ifnot(6) /LETO/
      data ifnot(7) /LETT/
      data ifnot(8) /PERIOD/
      data ifnot(9) /EOS/

   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- INITKW 710 08-NOV-78 19:37:59
 ## initkw - initialize table and install keywords 'define' and 'DEFINE'
   subroutine initkw
   integer i

   include clook
#   string defnam 'define' and 'DEFINE'
   character defnam(14), deftyp(2)
   data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/
   data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/
   data defnam(7) /EOS/
   data defnam(8) /BIGD/, defnam(9) /BIGE/, defnam(10) /BIGF/
   data defnam(11) /BIGI/, defnam(12) /BIGN/, defnam(13) /BIGE/
   data defnam(14) /EOS/
   data deftyp(1), deftyp(2) /DEFTYPE, EOS/

   avail = 1
  for (i=1; i<=127; i=i+1)
      tabptr(i) = 0
   call instal(defnam, deftyp)
   call instal(defnam(8), deftyp)
   return

   end
#-h- INITRT 2609 09-NOV-78 11:55:55
  ##initrt - initialize variables for ratfor compiler   /*/sor/rat4r/initrt

   subroutine initrt

 # initialize global variables
 # these may be put in a block data program
 # if available on your system
   # common blocks
      include coutln
      include cline
      include cdefio
      include cfor
      include clook
      include ckeywd
      include cgoto
      include cfname


    # keywords:
    data sdo(1), sdo(2), sdo(3) /LETD, LETO, EOS/
    data vdo(1), vdo(2) /LEXDO, EOS/

    data sif(1), sif(2), sif(3) /LETI, LETF, EOS/
    data vif(1), vif(2) /LEXIF, EOS/

    data selse(1), selse(2), selse(3), selse(4), selse(5) /LETE,
       LETL, LETS, LETE, EOS/
    data velse(1), velse(2) /LEXELSE, EOS/

    data swhile(1), swhile(2), swhile(3), swhile(4), swhile(5),
       swhile(6) /LETW, LETH, LETI, LETL, LETE, EOS/
    data vwhile(1), vwhile(2) /LEXWHILE, EOS/

    data sbreak(1), sbreak(2), sbreak(3), sbreak(4), sbreak(5),
       sbreak(6) /LETB, LETR, LETE, LETA, LETK, EOS/
    data vbreak(1), vbreak(2) /LEXBREAK, EOS/

    data snext(1), snext(2), snext(3), snext(4), snext(5) /LETN,
       LETE, LETX, LETT, EOS/
    data vnext(1), vnext(2) /LEXNEXT, EOS/

    data sfor(1), sfor(2), sfor(3), sfor(4) /LETF,
       LETO, LETR, EOS/
    data vfor(1), vfor(2) /LEXFOR, EOS/

    data srept(1), srept(2), srept(3), srept(4), srept(5), srept(6),
       srept(7) /LETR, LETE, LETP, LETE, LETA, LETT, EOS/
    data vrept(1), vrept(2) /LEXREPEAT, EOS/

  data slitrl(1), slitrl(2)  /TOGGLE, EOS/
  data vlitrl(1), vlitrl(2)   /LEXLITERAL, EOS/


    data suntil(1), suntil(2), suntil(3), suntil(4), suntil(5),

       suntil(6) /LETU, LETN, LETT, LETI, LETL, EOS/
    data vuntil(1), vuntil(2) /LEXUNTIL, EOS/

  data sret(1), sret(2), sret(3), sret(4), sret(5), sret(6),
       sret(7) /LETR, LETE, LETT, LETU, LETR, LETN, EOS/
  data vret(1), vret(2) /LEXRETURN, EOS/

  # output character pointer
  #(note--this is also initialized in 'parse')
  data outp /0/

  #  file conrol
  # (note--also initialized in 'parse')
  data level /1/
  data linect(1) /1/
  data infile(1) /STDIN/
  data fnamp /2/
  data fnames(1) /EOS/

  # pushback buffer pointer
  # (note--also initialized in 'parse')
  data bp /0/

  # depth of for stack
  # (note--also initialized in 'parse')
  data fordep /0/

  # pointers for table lookup code
  data avail /1/
  data tabptr /127*0/

  # current function name for return
  data fcname(1) /EOS/

   call initkw   #install keywords in table
   return
   end
#-h- INSTAL 811 asc 17-JAN-79 18:23:41
 ## instal - add name and definition to table
   subroutine instal(name, defn)
   character defn(MAXTOK), name(MAXDEF)
   integer c
   integer length
   integer dlen, nlen

   include clook

   nlen = length(name) + 1
   dlen = length(defn) + 1
   if (avail + nlen + dlen > MAXTBL) {
      call putlin(name, ERROUT)
      call remark(': too many definitions.')
      return
      }
   c = name(1)
   table(avail) = tabptr(c)

   tabptr(c) = avail
 #***NOTE*** Some systems allow byte-addressable character strings
 #           which differ in format from integered strings.  Thus
 #           special 'scopy' routines are needed to deal with them.
   call scopyi (name, 1, table, avail+1)
   call scopyi (defn, 1, table, avail+nlen+1)
   avail = avail + nlen + dlen + 1
   return
   end
#-h- LABELC 405 08-NOV-78 19:38:05
 ## labelc - output statement number
   subroutine labelc(lexstr)
   character lexstr(ARB)
   integer length

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- LITRAL 636 08-NOV-78 19:38:06
 ## litral - process literal ratfor lines

  subroutine litral

  integer getlin

 include coutln
 include cline

 # Finish off any left-over characters
 if (outp > 0)  call outdon
 call getlin (outbuf, infile(level))   # throw away end of current line


 #loop through input until matching toggle found

     while ( getlin (outbuf, infile(level)) ^= EOF )
           {
           for (i=1; outbuf(i) == BLANK; i=i+1) ;
           if (outbuf(i) == TOGGLE)
                break
           call putlin (outbuf, STDOUT)
           linect(level) = linect(level) + 1
           }
  outp = 0
  return
  end
#-h- LABGEN 202 08-NOV-78 19:38:08
 ## labgen - generate  n  consecutive labels, return first one
   integer function labgen(n)

   integer label, n
   data label /23000/

   labgen = label
   label = label + n
   return
   end
#-h- LEX 1135 08-NOV-78 19:38:41
 ## lex - return lexical type of token
   integer function lex(lexstr)
   character gettok
   character lexstr(MAXTOK)
   integer alldig, equal

   include ckeywd

   while (gettok(lexstr, MAXTOK) == NEWLINE)
      ;
   lex = lexstr(1)
   if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE)
      return
   if (alldig(lexstr) == YES)
      lex = LEXDIGITS
   else if (equal(lexstr, sif) == YES)
      lex = vif(1)
   else if (equal(lexstr, selse) == YES)
      lex = velse(1)
   else if (equal(lexstr, swhile) == YES)
      lex = vwhile(1)
   else if (equal(lexstr, sdo) == YES)
      lex = vdo(1)
   else if (equal(lexstr, sbreak) == YES)
      lex = vbreak(1)
   else if (equal(lexstr, snext) == YES)
      lex = vnext(1)
   else if (equal(lexstr, sfor) == YES)
      lex = vfor(1)
   else if (equal(lexstr, srept) == YES)
      lex = vrept(1)
   else if (equal(lexstr, suntil) == YES)
      lex = vuntil(1)
   else if (equal(lexstr, sret) == YES)
      lex = vret(1)
   else if (equal(lexstr, slitrl) == YES)
      lex = vlitrl(1)
   else
      lex = LEXOTHER
   return
   end
#-h- LOOKUP 745 asc 17-JAN-79 18:23:44
 ## lookup - locate name, extract definition from table
   integer function lookup(name, defn)
   character defn(MAXDEF), name(MAXTOK)
   integer i, j, k , c

   include clook


   c = name(1)
   for (i = tabptr(c); i > 0; i = table(i)) {
      j = i + 1
      for (k = 1; name(k) == table(j) & name(k) ^= EOS; k = k + 1)
         j = j + 1
      if (name(k) == table(j)) {      # got one
 #***NOTE*** Some systems allow byte-addressable character
 #           strings, which differ from integer strings.  Thus
 #           special 'scopy' routines are needed to deal with
 #           them.
         call icopys(table, j+1, defn, 1)
         lookup = YES
         return
         }
      }
   lookup = NO
   return
   end
#-h- NGETCH 300 08-NOV-78 19:38:44
 ## ngetch - get a (possibly pushed back) character
   character function ngetch(c, fd)
   character getch
   character c
   integer fd

   include cdefio

   if (bp > 0) {
      c = buf(bp)
      bp = bp - 1
      }
   else
      c = getch(c, fd)
   ngetch = c
   return
   end
#-h- OTHERC 234 08-NOV-78 19:38:45
 ## otherc - output ordinary Fortran statement
   subroutine otherc(lexstr)
   character lexstr(ARB)

   include cgoto

   xfer = NO
   call outtab
   call outstr(lexstr)
   call eatup
   call outdon
   return
   end
#-h- OUTCH 368 08-NOV-78 19:38:47
 ## outch - put one character into output buffer
   subroutine outch(c)
   character c
   integer i


   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 619 08-NOV-78 19:38:48
 ## outcon - output 'n   continue'
   subroutine outcon(n)
   integer n

   include cgoto
   include coutln
#   string contin 'continue'
   character contin(9)
   data contin(1) /LETC/
   data contin(2) /LETO/
   data contin(3) /LETN/
   data contin(4) /LETT/
   data contin(5) /LETI/
   data contin(6) /LETN/
   data contin(7) /LETU/
   data contin(8) /LETE/
   data contin(9) /EOS/

   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 207 08-NOV-78 19:39:25
 ## outdon - finish off an output line
   subroutine outdon

   include coutln

   outbuf(outp+1) = NEWLINE
   outbuf(outp+2) = EOS
   call putlin(outbuf, STDOUT)
   outp = 0
   return
   end
#-h- OUTGO 411 08-NOV-78 19:39:26

 ## outgo - output 'goto  n'
   subroutine outgo(n)
   integer n

   include cgoto
#   string goto 'goto'
   character goto(6)
   data goto(1) /LETG/
   data goto(2) /LETO/
   data goto(3) /LETT/
   data goto(4) /LETO/
   data goto(5) /BLANK/
   data goto(6) /EOS/

   if (xfer == YES)
      return
   call outtab
   call outstr(goto)
   call outnum(n)
   call outdon
   return
   end
#-h- OUTNUM 704 08-NOV-78 19:39:28
 ## outnum - output positive decimal number
   subroutine outnum(n)
   character chars(MAXCHARS)
   integer d, i, m
#   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/

   m = n
   i = 0
   repeat {
      i = i + 1
      d = mod(m, 10)
      chars(i) = digits(d+1)
      m = m / 10
      } until (m == 0 | i >= MAXCHARS)
   for ( ; i > 0; i = i - 1)
      call outch(chars(i))
   return
   end
#-h- OUTSTR 660 13-NOV-78 18:20:22
 ## outstr - output string
   subroutine outstr(str)


 #***NOTE*** - strings on BKY were converted to nL... format, a
 #             hollerith string terminated with a zero byte.

   character c, str(ARB)
   integer i, j

   for (i = 1; str(i) ^= EOS; i = i + 1) {
      c = str(i)
      if (c ^= SQUOTE & c ^= DQUOTE)
         call outch(c)
      else {
         i = i + 1
         for (j = i; str(j) ^= c; j = j + 1)   # find end
            ;
         call outnum(j-i)
         call outch (LETH)                      #NOTBKY
 #BKY    call outch (LETL)
         for ( ; i < j; i = i + 1)
            call outch(str(i))
         }
      }
   return
   end
#-h- OUTTAB 146 08-NOV-78 19:39:31
 ## outtab - get past column 6
   subroutine outtab

   include coutln

   while (outp < 6)
      call outch(BLANK)
   return
   end
#-h- PARSE 2249 13-JAN-79 19:41:13
 ## parse - parse Ratfor source program
   subroutine parse
   character lexstr(MAXTOK)
   integer lex
   integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token

  include coutln
  include cline
  include cdefio
  include cfor
  include cfname
  include cgoto

 #initialize variables for current input file
 outp = 0
 level = 1
 linect(1) = 1
 fnamp = 2
 fnames(1) = EOS
 bp = 0
 fordep = 0

 fcname(1) = EOS
   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 == LEXDIGITS)
         call labelc(lexstr)
      else if (token == LEXELSE) {
         if (lextyp(sp) == LEXIF)
            call elseif(labval(sp))
         else
            "`hh rpberr('illlgam!eme.')
         }
      else if (token == LEXLITERAL)
         call litral

      if (token == LEXIF | token == LEXELSE | token == LEXWHILE
        | token == LEXFOR | token == LEXREPEAT
        | token == LEXDO | token == LEXDIGITS | token == LBRACE) {
         sp = sp + 1         # beginning of statement
         if (sp > MAXSTACK)
            call error('stack overflow in parser.')
         lextyp(sp) = token      # stack type and value
         labval(sp) = lab
         }
      else {      # end of statement - prepare to unstack
         if (token == RBRACE) {
            if (lextyp(sp) == LBRACE)
               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
         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- PBSTR 212 08-NOV-78 19:40:09
 ## 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 240 08-NOV-78 19:40:10
 ## putbak - push character back onto input
   subroutine putbak(c)
   character c

   include cdefio

   bp = bp + 1
   if (bp > BUFSIZE)
      call error('too many characters pushed back.')
   buf(bp) = c
   return
   end
#-h- RELATE 2457 08-NOV-78 19:40:12
 ## relate - convert relational shorthands into long form
   subroutine relate(token, last, fd)
   character ngetch
   character token(ARB)
   integer length
   integer fd, last
#   string dotge '.ge.'
#   string dotgt '.gt.'
#   string dotlt '.lt.'
#   string dotle '.le.'
#   string dotne '.ne.'
#   string dotnot '.not.'
#   string doteq '.eq.'
#   string dotand '.and.'
#   string dotor '.or.'
   character dotge(5), dotgt(5), dotlt(5), dotle(5)
   character dotne(5), dotnot(6), doteq(5), dotand(6), dotor(5)
   data dotge(1), dotge(2), dotge(3), dotge(4), dotge(5)/ PERIOD,
      LETG, LETE, PERIOD, EOS/
   data dotgt(1), dotgt(2), dotgt(3), dotgt(4), dotgt(5)/ PERIOD,
      LETG, LETT, PERIOD, EOS/
   data dotle(1), dotle(2), dotle(3), dotle(4), dotle(5)/ PERIOD,
      LETL, LETE, PERIOD, EOS/
   data dotlt(1), dotlt(2), dotlt(3), dotlt(4), dotlt(5)/ PERIOD,
      LETL, LETT, PERIOD, EOS/
   data dotne(1), dotne(2), dotne(3), dotne(4), dotne(5)/ PERIOD,
      LETN, LETE, PERIOD, EOS/
   data doteq(1), doteq(2), doteq(3), doteq(4), doteq(5)/ PERIOD,
      LETE, LETQ, PERIOD, EOS/
   data dotor(1), dotor(2), dotor(3), dotor(4), dotor(5)/ PERIOD,
      LETO, LETR, PERIOD, EOS/

   data dotand(1), dotand(2), dotand(3), dotand(4), dotand(5),
      dotand(6) /PERIOD, LETA, LETN, LETD, PERIOD, EOS/
   data dotnot(1), dotnot(2), dotnot(3), dotnot(4), dotnot(5),
      dotnot(6) /PERIOD, LETN, LETO, LETT, PERIOD, EOS/

   if (ngetch(token(2), fd) ^= EQUALS)
      call putbak(token(2))
   if (token(1) == GREATER) {
      if (token(2) == EQUALS)
         call scopy(dotge, 1, token, 1)
      else
         call scopy(dotgt, 1, token, 1)
      }
   else if (token(1) == LESS) {
      if (token(2) == EQUALS)
         call scopy(dotle, 1, token, 1)
      else
         call scopy(dotlt, 1, token, 1)
      }
   else if (token(1) == NOT | token(1) == BANG | token(1) == CARET) {
      if (token(2) == EQUALS)
         call scopy(dotne, 1, token, 1)
      else
         call scopy(dotnot, 1, token, 1)
      }
   else if (token(1) == EQUALS) {
      if (token(2) == EQUALS)
         call scopy(doteq, 1, token, 1)
      else
         token(2) = EOS
      }
   else if (token(1) == AND)
      call scopy(dotand, 1, token, 1)
   else if (token(1) == OR)
      call scopy(dotor, 1, token, 1)
   else   # can't happen
      token(2) = EOS
   last = length(token)
   return
   end
#-h- REPCOD 270 08-NOV-78 19:40:14
 ## 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- RETCOD 735 08-NOV-78 19:41:27
 ## retcod - generate code for return
   subroutine retcod
   character token(MAXTOK), gettok, t

   include cfname
   include cgoto
#   string retrn 'return'
   character retrn(7)
   data retrn(1) /LETR/
   data retrn(2) /LETE/
   data retrn(3) /LETT/
   data retrn(4) /LETU/
   data retrn(5) /LETR/
   data retrn(6) /LETN/
   data retrn(7) /EOS/

   t = gettok(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(retrn)
   call outdon
   xfer = YES
   return
   end
#-h- SYNERR 1314 08-NOV-78 19:41:29
 ## synerr - report Ratfor syntax error
   subroutine synerr(msg)
   character lc(MAXCHARS), msg(ARB)
   integer itoc
   integer i, junk

   include cline
#   string serror '? error at line '
   character serror(17)
#   string in ' in '
   character in(5)
   data serror(1) /QMARK/
   data serror(2) /BLANK/
   data serror(3) /LETE/
   data serror(4) /LETR/
   data serror(5) /LETR/
   data serror(6) /LETO/
   data serror(7) /LETR/
   data serror(8) /BLANK/
   data serror(9) /LETA/
   data serror(10) /LETT/
   data serror(11) /BLANK/
   data serror(12) /LETL/
   data serror(13) /LETI/
   data serror(14) /LETN/
   data serror(15) /LETE/
   data serror(16) /BLANK/
   data serror(17) /EOS/
   data in(1) /BLANK/
   data in(2) /LETI/
   data in(3) /LETN/
   data in(4) /BLANK/
   data in(5) /EOS/

   call putlin(serror, 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- UNSTAK 830 08-NOV-78 19:41:31
 ## 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)
         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- UNTILS 388 08-NOV-78 19:41:33
 ## untils - generate code for until or end of repeat
   subroutine untils(lab, token)
   character ptoken(MAXTOK)
   integer lex
   integer junk, lab, token

   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- WHILEC 267 08-NOV-78 19:41:34
 ## 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 153 08-NOV-78 19:41:35
 ## whiles - generate code for end of while
   subroutine whiles(lab)
   integer lab

   call outgo(lab)
   call outcon(lab+1)
   return
   end
#-h- ICOPYS 251 10-NOV-78 14:52:53
 ## icopys - copy integer string to character string
 subroutine icopys(from, i, to, j)
 character to(ARB)
 integer from(ARB), i, j, k1, k2

 k2 = j
 for (k1=i; from(k1)^=EOS; k1=k1+1)
        {
        to(k2) = from(k1)
        k2 = k2 + 1
        }
 to(k2) = EOS
 return
 end
#-h- SCOPYI 251 10-NOV-78 14:52:55
 ## scopyi - copy character string to integer string
 subroutine scopyi(from, i, to, j)
 character from(ARB)
 integer to(ARB), i, j, k1, k2

 k2 = j
 for (k1=i; from(k1)^=EOS; k1=k1+1)
        {
        to(k2) = from(k1)
        k2 = k2 + 1
        }
 to(k2) = EOS
 return
 end