%%s 77/16/3770
%%d D 1.10 17-Dec-81 01:16:23 sventek 10 9
%%c Several enhancements due to Gregg Whitcomb (North Carolina State University)
%%c have been added:
%%c 
%%c a) a flag '-n' may be specified in the command line; this flag prevents the
%%c    inclusion of the standard definitions file.
%%c 
%%c    Modules modified: common, ratfor.r`main, ratfor.r`ratarg (added)
%%c 
%%c b) the set of characters which may be included in an alpha token has been
%%c    parameterized; thus, in environments where it makes sense, this set of
%%c    legal characters may be easily extended.  The set of characters
%%c    is defined in ratfor.r`defns by
%%c 
%%c    define(ALPHA_CHARACTERS,"_")
%%c 
%%c    by default.  As an example of an extension which makes sense, on VMS
%%c    the following definition could be made
%%c 
%%c    define(ALPHA_CHARACTERS,"_$")
%%c 
%%c    thus permitting one to define SS$_NORMAL, IO$_READVBLK, etc.
%%c 
%%c    NOTE: if you do not include '_' in the string, you can be well assured
%%c    that nothing will build correctly, since that character has always been
%%c    legal.
%%c 
%%c    Modules modified: ratfor.r`defns, ratfor.r`gtok
%%c 
%%c c) It is possible to build ratfor to pass strings delimited by apostrophes
%%c    (') straight through the processor by placing the following
%%c 
%%c    define(F77_CHARACTER_STRINGS,)
%%c 
%%c    in ratfor.r`defns.  This permits one to use F77-style strings for
%%c    system-specific manipulations.  Since character strings of the form
%%c    'c' and '@c' are turned into integers by the processor, an escape
%%c    mechanism is provided (if this option is turned on, of course) as
%%c 
%%c    '!c' ==> 'c'
%%c    '!@c' ==> '@c'
%%c 
%%c    i.e. a leading bang (!) will be stripped from such strings.
%%c 
%%c    Modules modified: ratfor.r`outstr
%%s 30/27/3756
%%d D 1.9 16-Dec-82 16:30:23 sventek 9 8
%%c Modified ratfor.r`defns to ease the size increases for storage areas on
%%c systems with LARGE_ADDRESS_SPACE defined.  The symbol A_S_X is a multiplier
%%c used to scale array sizes, and is set to 4 for large systems and to 1 for
%%c small systems.  This was originally put into the preprocessor by Dave
%%c Martin.
%%s 6/2/3777
%%d D 1.8 14-Dec-82 16:31:05 sventek 8 7
%%c Update manual to reflect the addition of ** to the list of arith operations
%%c and the ability to use apostrophes "'" to delimit string literals if they
%%c are longer than a single character.
%%s 1/1/3778
%%d D 1.7 23-Nov-82 13:17:50 sventek 7 6
%%c Modified ratfor.w`ratfor.r`gctok to fix a bug in the handling of conditionals
%%c within continued statements.  For example,
%%c 
%%c common /x/ xx,
%%c ifdef(YY_DEF)
%%c            yy,
%%c enddef
%%c            zz
%%c 
%%c did not work correctly.  This fix is to have gctok gobble blanks and newlines
%%c after successfully detecting on of the conditional directives.
%%s 113/61/3666
%%d D 1.6 19-Oct-82 21:52:02 sventek 6 5
%%c Modified ratfor.w`ratfor.r`gtok to permit strings quoted with apostrophes
%%c (') to be handled as before if the length of the string exceeds 1 character
%%c (or 2, if it is an escaped character).  Character constants still work
%%c correctly.  This modification was necessary to reduce trauma to existing
%%c applications.
%%s 208/206/3519
%%d D 1.5 18-Oct-82 13:56:26 sventek 5 4
%%c Modified ratfor.w`common, ratfor.w`ratfor.r and ratfor.w`ratfor.fmt to
%%c reflect the interchangability of the `select' and `switch' keywords.
%%c The addition of `switch' was to conform with the STUG ratfor, and the
%%c retention of `select' was to avoid breaking code without requiring support
%%c within symbols.  The modules were also renamed to be consistent with the
%%c STUG ratfor modules.
%%s 7/3/3718
%%d D 1.4 28-May-82 11:04:17 tools 4 3
%%c Modified ratfor.w`ratfor.r`defns to cause MEMSIZE to be doubled if the
%%c symbol LARGE_ADDRESS_SPACE is defined.
%%s 11/8/3710
%%d D 1.3 04-May-82 12:12:37 j 3 2
%%c Modified ratfor.w`ratfor.r`evalr to fix a bug which crept in when attempting
%%c to prevent ratfor from gobbling $<c> when <c> was not a digit.  The bug
%%c manifested itself by print $n instead of outputting the null string for
%%c undefined arguments in macros.  This bug was reported to me by Charles
%%c Johnson of USF Physics Research.
%%s 3/3/3715
%%d D 1.2 28-Apr-82 10:20:50 j 2 1
%%c Decrease value of Dynamic Storage Region size from 4800 to 4250 in
%%c ratfor.w`ratfor.r`defns.  This is necessary for Fortran IV version
%%c of ratfor on RSX-11M.
%%s 0/0/0
%%d D 1.1 25-Mar-82 12:11:21 v1.1 1 0
%%c Version 1.1 is the Spring 1982 Distribution of the LBL/Hughes release
%%c of the Software Tools Virtual Operating System software and documentation.
%%T
%%I 1
%%D 5
#-h- common          2594  asc  25-mar-82 08:26:26  v1.1 (sw-tools v1.1)
%%E 5
%%I 5
%%D 10
#-h- common          2594  asc  18-oct-82 13:12:32  sventek (joseph sventek)
%%E 10
%%E 5
%%I 10
#-h- common          2689  asc  17-dec-81 00:26:51  sventek (joseph sventek)
%%E 10
# Common blocks used by the Ratfor preprocessor
#     Place on a file called 'common'


 common /cdefio/ bp, buf (BUFSIZE)
    integer bp         # next available character; init = 0
    character buf      # pushed-back characters

 common /cfname/ fcname (MAXNAME)
   character fcname    # text of current function name

 common /cfor/ fordep, forstk (MAXFORSTK)
   integer fordep      # current depth of for statements
   character forstk    # stack of reinit strings

 common /cgoto/ xfer
   integer xfer        # YES if just made transfer, NO otherwise

 common /clabel/ label
   integer label       # next label returned by labgen

 common /cline/ level, linect (NFILES), infile (NFILES),
   fnamp, fnames (MAXFNAMES)
   integer level       # level of file inclusion; init = 1
   integer linect      # line count on input file (level); init = 1
   integer infile      # file number (level); init infile (1) = STDIN
   integer fnamp       # next free slot in fnames; init = 2
   character fnames    # stack of include names; init fnames (1) = EOS

 common /cmacro/ cp, ep, evalst (EVALSIZE), deftbl
    integer cp         # current call stack pointer
    integer ep         # next free position in evalst
    character evalst   # evaluation stack
    pointer deftbl     # symbol table holding macro names

 common /coutln/ outp, outbuf (74)
   integer outp        # last position filled in outbuf; init = 0
   character outbuf    # output lines collected here

 common /csbuf/ sbp, sbuf (SBUFSIZE)
   integer sbp         # next available character position; init = 1
   character sbuf      # saved for data statements

%%D 5
 ifdef (DO_SELECT)
 common /cselct/ setop, selast, sestak (MAXSELECT)
   integer setop       # current select entry; init = 0
   integer selast      # next available position; init = 1
   integer sestak      # select information
%%E 5
%%I 5
 ifdef (DO_SWITCH)
 common /cswtch/ swtop, swlast, swstak (MAXSWITCH)
   integer swtop       # current switch entry; init = 0
   integer swlast      # next available position; init = 1
   integer swstak      # switch information
%%E 5
 enddef

 common /ckword/ rkwtbl
   pointer rkwtbl      # symbol table containing Ratfor key words

 ifdef (DO_LONGNAME)
 common /clname/ fkwtbl, namtbl, gentbl
   pointer fkwtbl      # a list of long Fortran keywords
   pointer namtbl      # map of long-form names to short-form names
   pointer gentbl      # list of generated names
 enddef

 common /condpp/ csp, curcnd, cndstk(COND_STACK_DEPTH)
   integer csp         # last used location in cond stack; init = 0
   integer curcnd      # current conditional state; (+/-)C_TRUE; init C_TRUE
   integer cndstk      # stack of saved condition values


  common / csctok / scrtok(MAXTOK)

  character scrtok     # scratch token buffer used by routines called by parse

%%I 10
common / cflags / dosym
  integer dosym        # whether to load "symbols" or not; init = YES

%%E 10
 DS_DECL(mem, MEMSIZE)
%%D 2
#-h- ratfor.r       75055  asc  25-mar-82 08:26:51  v1.1 (sw-tools v1.1)
#-h- defns           4331  asc  25-mar-82 08:22:15  v1.1 (sw-tools v1.1)
%%E 2
%%I 2
%%D 3
#-h- ratfor.r       75050  asc  28-apr-82 09:40:07  j (sventek j)
%%E 3
%%I 3
%%D 4
#-h- ratfor.r       75144  asc  04-may-82 11:38:38  j (sventek j)
%%E 4
%%E 3
%%D 4
#-h- defns           4331  asc  28-apr-82 07:19:32  system (system)
%%E 4
%%E 2
%%I 4
%%D 5
#-h- ratfor.r       75167  asc  28-may-82 10:59:57  tools (lblh csam sventek)
%%E 5
%%I 5
%%D 6
#-h- ratfor.r       75241  asc  18-oct-82 13:12:47  sventek (joseph sventek)
%%E 6
%%E 5
%%I 6
%%D 7
#-h- ratfor.r       76984  asc  19-oct-82 21:18:16  sventek (joseph sventek)
%%E 7
%%E 6
%%I 7
%%D 9
#-h- ratfor.r       76984  asc  23-nov-82 12:34:13  sventek (joseph sventek)
%%E 9
%%E 7
%%D 9
#-h- defns           4344  asc  28-may-82 10:58:44  tools (lblh csam sventek)
%%E 9
%%E 4
%%I 9
%%D 10
#-h- ratfor.r       76959  asc  16-dec-82 15:48:09  sventek (joseph sventek)
#-h- defns           4320  asc  16-dec-82 11:30:39  sventek (joseph sventek)
%%E 10
%%E 9
%%I 10
#-h- ratfor.r       78590  asc  17-dec-81 00:27:06  sventek (joseph sventek)
#-h- defns           4870  asc  16-dec-81 23:22:24  sventek (joseph sventek)
%%E 10
# Ratfor preprocessor


%%D 9
   # include ratdef
%%E 9
%%I 9
# include ratdef
%%E 9

#---------------------------------------------------------------
# The definition STDEFNS defines the file which contains the
# standard definitions to be used when preprocessing a file.
# It is opened and read automatically by the ratfor preprocessor.
# Set STDEFNS to the name of the file in which the standard
# definitions reside.  If you don't want the preprocessor to
# automatically open this file, set STDENFS to "".
#
#---------------------------------------------------------------
#    If you want the preprocessor to output upper case only,
#    set the following definition:
#
#              define (UPPERC,)
#
#---------------------------------------------------------------
#    If you want the preprocessor to perform the long name conversion,
#    set the following definition
#
#              define (DO_LONGNAME,)
#
#---------------------------------------------------------------
%%D 5
#    If you want the preprocessor to process the select statement,
%%E 5
%%I 5
#    If you want the preprocessor to process the switch statement,
%%E 5
#    set the following definition
#
%%D 5
#              define (DO_SELECT,)
%%E 5
%%I 5
#              define (DO_SWITCH,)
%%E 5
#
#---------------------------------------------------------------
%%I 10
#    If you want F77 style character strings (delimited by apostrophes)
#    to be passed through the pre-processor, set the following
#    definition
#
#		define(F77_CHARACTER_STRINGS,)
#
#    Note that to get single character F77 strings through the processor,
#    the following escape mapping is performed when this option is selected
#
#    '!c' ===> 'c'
#
#---------------------------------------------------------------
%%E 10
#    If you want to generate the fortran bootstrap,
#    set the following definition
#
#              define (DO_BOOTSTRAP,)
#
#    In addition, it will be necessary to append the fortran of several
#    of the library routines to the generated fortran file.
#---------------------------------------------------------------
#  Some of the buffer sizes and other symbols might have to be
#  changed.  Especially check the following:
#
#        MAXDEF         (number of characters in a definition)
#        SBUFSIZE       (nbr string declarations allowed per module)
#        MAXSTRTBL      (size of table to buffer string declarations)
%%D 5
#        MAXSELECT      (max stack for select statement)
%%E 5
%%I 5
#        MAXSWITCH      (max stack for switch statement)
%%E 5
#
#-----------------------------------------------------------------


%%D 9
define (STDEFNS,"symbols") # name of file containing standard defns
define (UPPERC,)           # define if Fortran compiler wants upper case
%%E 9
%%D 5
define(DO_SELECT,)	   # process the select statement
%%E 5
%%I 5
%%D 9
define(DO_SWITCH,)	   # process the switch statement
%%E 9
%%E 5
%%I 9
define (STDEFNS,"symbols")	# name of file containing standard defns
%%I 10
define (ALPHA_CHARACTERS,"_")	# the set of legal characters in alpha tokens
				# VMS users might like to set this to "_$"
%%E 10
define (UPPERC,)		# define if Fortran compiler wants upper case
define (DO_SWITCH,)		# process the switch statement
%%E 9

%%D 9
define (RADIX,'%')     # % indicates alternate radix
define (TOGGLE,'%')    # toggle for literal lines
define (ARGFLAG,'$')       # parameter delimeter in macros
define (CUTOFF,3)          # min nbr of cases to generate branch table
%%E 9
%%D 5
                           # (for select statement)
%%E 5
%%I 5
%%D 9
                           # (for switch statement)
%%E 9
%%E 5
%%D 9
define (DENSITY,2)         # reciprocal of density necessary for
                           # branch table
define (FILLCHAR,'0')     # used in long-name uniquing
define (MAXIDLENGTH,6)     # for Fortran 66 and 77
%%E 9
%%I 9
define (RADIX,'%')		# % indicates alternate radix
define (TOGGLE,'%')		# toggle for literal lines
define (ARGFLAG,'$')		# parameter delimeter in macros
define (CUTOFF,3)		# min nbr of cases to generate branch table
				# (for switch statement)
define (DENSITY,2)		# reciprocal of density necessary for
				# branch table
define (FILLCHAR,'0')		# used in long-name uniquing
define (MAXIDLENGTH,6)		# for Fortran 66 and 77
%%E 9


# Lexical items:

define (LEXBREAK,-8)
define (LEXCASE,-25)
define (LEXDEFAULT,-26)
define (LEXDIGITS,-9)
define (LEXDO,-10)
define (LEXELSE,-11)
define (LEXEND,-21)
define (LEXFOR,-16)
define (LEXIF,-19)
define (LEXLITERAL,-27)
define (LEXNEXT,-13)
define (LEXOTHER,-14)
define (LEXREPEAT,-17)
define (LEXRETURN,-20)
define (LEXSTOP,-22)
define (LEXSTRING,-23)
%%D 5
define (LEXSELECT,-24)
%%E 5
%%I 5
define (LEXSWITCH,-24)
%%E 5
define (LEXUNTIL,-18)
define (LEXWHILE,-15)
define (LSTRIPC,-10)
define (RSTRIPC,-11)


# Built-in macro functions:

define (DEFTYPE,-4)
define (MACTYPE,-10)
define (IFTYPE,-11)
define (INCTYPE,-12)
define (SUBTYPE,-13)
define (ARITHTYPE,-14)
define (IFDEFTYPE,-15)
define (IFNOTDEFTYPE,-16)
define (ELSEDEFTYPE,-17)
define (ENDDEFTYPE,-18)
define (NOTDEFTYPE,-19)


# Size-limiting definitions:

%%D 2
define (MEMSIZE,4800)     # space allotted to symbol tables and macro text
%%E 2
%%I 2
%%D 4
define (MEMSIZE,4250)     # space allotted to symbol tables and macro text
%%E 4
%%E 2
%%I 4
ifdef(LARGE_ADDRESS_SPACE)
%%D 9
  define(MEMSIZE,8500)
%%E 9
%%I 9
  define(A_S_X,4)
%%E 9
elsedef
%%D 9
  define(MEMSIZE,4250)
%%E 9
%%I 9
  define(A_S_X,1)
%%E 9
enddef
%%E 4
%%I 9

define(EVALSIZE,arith(A_S_X,*,500))
define(MEMSIZE,arith(A_S_X,*,4250))	# symbol tables and macro text
define(MAXDEF,arith(A_S_X,*,250))	# max chars in a defn
define(SBUFSIZE,arith(A_S_X,*,600))	# buffer for string statements

%%E 9
define (BUFSIZE,arith(2,*,MAXDEF))	# pushback buffer size
%%D 9
define (SBUFSIZE,600)      # buffer for string statements
define (MAXDEF,250)       # max chars in a defn
define (MAXFORSTK,300)     # max space for for reinit clauses
%%E 9
%%I 9
define (MAXFORSTK,300)			# max space for for reinit clauses
%%E 9
define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE))
%%D 9
define (MAXSTACK,100)      # max stack depth for parser
%%E 9
%%D 5
define (MAXSELECT,300)    # max stack for select statement
%%E 5
%%I 5
%%D 9
define (MAXSWITCH,300)    # max stack for switch statement
%%E 9
%%E 5
%%D 9
define (MAXTOK,120)		# max chars in a token
%%E 9
%%I 9
define (MAXSTACK,100)			# max stack depth for parser
define (MAXSWITCH,300)			# max stack for switch statement
define (MAXTOK,120)			# max chars in a token
%%E 9
define (NFILES,arith(MAXOFILES,-,3))	# maximum number of include file nests
%%D 9
define (MAXNBRSTR,20)      #max nbr string declarations per module
%%E 9
%%I 9
define (MAXNBRSTR,20)			# max nbr string decls per module
%%E 9
define (CALLSIZE,50)
define (ARGSIZE,100)
%%D 9
define (EVALSIZE,500)
define (COND_STACK_DEPTH,10)  # size of conditional stack
define (C_TRUE,1)             # conditional value is true
%%E 9
%%I 9
define (COND_STACK_DEPTH,10)		# size of conditional stack
define (C_TRUE,1)			# conditional value is true
%%E 9


# Where to find the common blocks:

define(COMMON_BLOCKS,"common")

define(ext_subr,#)
define(ext_func,)
%%D 10
#-h- main             998  asc  25-mar-82 08:22:19  v1.1 (sw-tools v1.1)
%%E 10
%%I 10
#-h- main            1163  asc  16-dec-81 23:58:15  sventek (joseph sventek)
%%E 10
   DRIVER(ratfor)

   include COMMON_BLOCKS

   integer i, n
   ext_func integer getarg, open
%%D 10
   ext_subr query, initkw, lodsym, cant, parse, close, lndict
%%E 10
%%I 10
   ext_subr query, initkw, ratarg, lodsym, cant, parse, close, lndict
%%E 10

   character arg (FILENAMESIZE)

  ifnotdef (DO_BOOTSTRAP)
%%D 10
   call query ("usage:  ratfor [file] ... >outfile.")
%%E 10
%%I 10
   call query ("usage:  ratfor [-n] [file] ... >outfile.")
%%E 10
  enddef

   call initkw  # initialize variables

  ifnotdef (DO_BOOTSTRAP)
%%D 10
   call lodsym(arg)	# Read standard definitions file
%%E 10
%%I 10
   call ratarg		# process command line flags
   if (dosym == YES)	# load symbols
      call lodsym(arg)	# Read standard definitions file
%%E 10

   n = 1
   for (i = 1; getarg (i, arg, FILENAMESIZE) != EOF; i = i + 1) {
%%D 10
      n = n + 1
      if (arg (1) == '-' & arg (2) == EOS)
         infile (1) = STDIN
%%E 10
%%I 10
      if (arg (1) == '-')
         if (arg(2) == EOS)
            infile (1) = STDIN
         else
            next			# skip command flags
%%E 10
      else {
         infile (1) = open (arg, READ)
         if (infile (1) == ERR)
            call cant (arg)
         }
%%I 10
      n = n + 1
%%E 10
      call parse
      if (infile (1) != STDIN)
         call close (infile (1))
      }

   if (n == 1) {   # no files given on command line, use STDIN
  enddef
      infile (1) = STDIN
      call parse
  ifnotdef (DO_BOOTSTRAP)
      }
  enddef

  ifdef (DO_LONGNAME)
   call lndict
  enddef

   DRETURN
   end
#-h- addchr           268  asc  25-mar-82 08:22:21  v1.1 (sw-tools v1.1)
# addchr - put c in buf(bp) if it fits, increment bp
   subroutine addchr(c, buf, bp, maxsiz)
   integer bp, maxsiz
   character c, buf(ARB)

   ext_subr baderr
 
   if (bp > maxsiz)
      call baderr("buffer overflow.")
   buf(bp) = c
   bp = bp + 1
   return
   end
#-h- addstr           276  asc  25-mar-82 08:22:21  v1.1 (sw-tools v1.1)
# addstr - put s in buf(bp) by repeated calls to addchr
   subroutine addstr(s, buf, bp, maxsiz)
   character s(ARB), buf(ARB)
   integer bp, maxsiz
   integer i

   ext_subr addchr

   for (i = 1; s(i) != EOS; i=i+1)
      call addchr(s(i), buf, bp, maxsiz)
   return
   end
#-h- alldig           306  asc  25-mar-82 08:22:22  v1.1 (sw-tools v1.1)
# alldig - return YES if str is all digits

   integer function alldig (str)
   character str (ARB)

   character type

   integer i

   alldig = NO
   if (str (1) == EOS)
      return
   for (i = 1; str (i) != EOS; i = i + 1)
      if (!IS_DIGIT(str (i)))
         return
   alldig = YES
   return
   end
#-h- baderr           176  asc  25-mar-82 08:22:23  v1.1 (sw-tools v1.1)
# baderr --- report fatal error message, then die

   subroutine baderr (msg)
   character msg (ARB)

   ext_subr synerr, endst

   call synerr (msg)
   call endst(ERR)
   end
#-h- balpar           920  asc  25-mar-82 08:22:24  v1.1 (sw-tools v1.1)
# balpar - copy balanced paren string

   subroutine balpar

   character t, token (MAXTOK)
   ext_func character gettok, gnbtok
   ext_subr synerr, outstr, pbstr, squash

   integer nlpar

   if (gnbtok (token, MAXTOK) != '(') {
      call synerr ("missing left paren.")
      return
      }
   call outstr (token)
   nlpar = 1
   repeat {
      t = gettok (token, MAXTOK)
      if (t == ';' | t == '{' | t == '}' | t == EOF) {
         call pbstr (token)
         break
         }
      if (t == '@n')      # delete newlines
         token (1) = EOS
      else if (t == '(')
         nlpar = nlpar + 1
      else if (t == ')')
         nlpar = nlpar - 1
     ifdef (DO_LONGNAME)
      if (t == ALPHA)
         call squash (token)
     enddef
      # else nothing special
      call outstr (token)
      } until (nlpar <= 0)

   if (nlpar != 0)
      call synerr ("missing parenthesis in condition.")

   return
   end
#-h- brknxt          1107  asc  25-mar-82 08:22:26  v1.1 (sw-tools v1.1)
# brknxt - generate code for break n and next n; n = 1 is default

   subroutine brknxt (sp, lextyp, labval, token)
   integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token

   integer i, n
   character t

   ext_func integer alldig, ctoi
   ext_func character gnbtok
   ext_subr pbstr, outgo, synerr

   include COMMON_BLOCKS

   n = 0
   t = gnbtok (scrtok, MAXTOK)
   if (alldig (scrtok) == YES) {     # have break n or next n
      i = 1
      n = ctoi (scrtok, i) - 1
      }
   else if (t != ';')      # default case
      call pbstr (scrtok)
   for (i = sp; i > 0; i = i - 1)
      if (lextyp (i) == LEXWHILE | lextyp (i) == LEXDO
        | lextyp (i) == LEXFOR | lextyp (i) == LEXREPEAT) {
         if (n > 0) {
            n = n - 1
            next             # seek proper level
            }
         else if (token == LEXBREAK)
            call outgo (labval (i) + 1)
         else
            call outgo (labval (i))
         xfer = YES
         return
         }

   if (token == LEXBREAK)
      call synerr ("illegal break.")
   else
      call synerr ("illegal next.")

   return
   end
#-h- cascod          1948  asc  25-mar-82 08:22:28  v1.1 (sw-tools v1.1)
# cascod - generate code for case or default label

%%D 5
  ifdef (DO_SELECT)
%%E 5
%%I 5
  ifdef (DO_SWITCH)
%%E 5
   subroutine cascod (lab, token)
   integer lab, token

   include COMMON_BLOCKS

   integer t, l, lb, ub, i, j, junk

   ext_func integer caslab, labgen
   ext_func character gnbtok
   ext_subr synerr, outgo, baderr, outcon

%%D 5
   if (setop <= 0) {
%%E 5
%%I 5
   if (swtop <= 0) {
%%E 5
      call synerr ("illegal case or default.")
      return
      }
   call outgo (lab + 1) # terminate previous case
   xfer = YES
   l = labgen (1)
   if (token == LEXCASE) { # case n[,n]... : ...
      while (caslab (lb, t) != EOF) {
         ub = lb
         if (t == '-')
            junk = caslab (ub, t)
         if (lb > ub) {
            call synerr ("illegal range in case label.")
            ub = lb
            }
%%D 5
         if (selast + 3 > MAXSELECT)
            call baderr ("select table overflow.")
         for (i = setop + 3; i < selast; i = i + 3)
            if (lb <= sestak (i))
%%E 5
%%I 5
         if (swlast + 3 > MAXSWITCH)
            call baderr ("switch table overflow.")
         for (i = swtop + 3; i < swlast; i = i + 3)
            if (lb <= swstak (i))
%%E 5
               break
%%D 5
            else if (lb <= sestak (i+1))
%%E 5
%%I 5
            else if (lb <= swstak (i+1))
%%E 5
               call synerr ("duplicate case label.")
%%D 5
         if (i < selast & ub >= sestak (i))
%%E 5
%%I 5
         if (i < swlast & ub >= swstak (i))
%%E 5
            call synerr ("duplicate case label.")
%%D 5
         for (j = selast; j > i; j = j - 1)   # insert new entry
            sestak (j+2) = sestak (j-1)
         sestak (i) = lb
         sestak (i + 1) = ub
         sestak (i + 2) = l
         sestak (setop + 1) = sestak (setop + 1)  +  1
         selast = selast + 3
%%E 5
%%I 5
         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
%%E 5
         if (t == ':')
            break
         else if (t != ',')
            call synerr ("illegal case syntax.")
         }
      }
   else {   # default : ...
      t = gnbtok (scrtok, MAXTOK)
%%D 5
      if (sestak (setop + 2) != 0)
         call baderr ("multiple defaults in select statement.")
%%E 5
%%I 5
      if (swstak (swtop + 2) != 0)
         call baderr ("multiple defaults in switch statement.")
%%E 5
      else
%%D 5
         sestak (setop + 2) = l
%%E 5
%%I 5
         swstak (swtop + 2) = l
%%E 5
      }

   if (t == EOF)
      call synerr ("unexpected EOF.")
   else if (t != ':')
      call baderr ("missing colon in case or default label.")

   xfer = NO
   call outcon (l)
   return
   end
  enddef
#-h- caslab           691  asc  25-mar-82 08:22:30  v1.1 (sw-tools v1.1)
# caslab - get one case label

%%D 5
  ifdef (DO_SELECT)
%%E 5
%%I 5
  ifdef (DO_SWITCH)
%%E 5
   integer function caslab (n, t)
   integer n, t

   character tok (MAXTOK)
   integer i, s

   ext_func character gnbtok
   ext_func integer ctoi
   ext_subr synerr

   t = gnbtok (tok, MAXTOK)
   while (t == '@n')
      t = gnbtok (tok, MAXTOK)
   if (t == EOF)
      return (t)
   if (t == '-')
      s = -1
   else
      s = +1
   if (t == '-' | t == '+')
      t = gnbtok (tok, MAXTOK)
   if (t != DIGIT) {
      call synerr ("invalid case label.")
      n = 0
      }
   else {
      i = 1
      n = s * ctoi (tok, i)
      }
   t = gnbtok (tok, MAXTOK)
   while (t == '@n')
      t = gnbtok (tok, MAXTOK)

   return
   end
  enddef
#-h- cndget           828  asc  25-mar-82 08:22:31  v1.1 (sw-tools v1.1)
# cndget - get conditional token and look it up in table

   integer function cndget(token, toksiz)

   character token(MAXTOK)
   integer toksiz

   include COMMON_BLOCKS

   pointer value
   character ptok(3)

   ext_func integer lookup
   ext_func character gtok
   ext_subr baderr, skpblk

   if (csp >= COND_STACK_DEPTH)
      call baderr("Conditionals nested too deeply.")
   csp = csp + 1
   cndstk (csp) = curcnd
   call skpblk
   if (gtok(token, toksiz) != '(')
      call baderr("missing `(' in conditional.")
   call skpblk
   if (gtok(token, toksiz) != ALPHA)
      call baderr("invalid conditional token.")
   call skpblk
   if (gtok(ptok, 3) != ')')
      call baderr("missing `)' in conditional.")
   if (lookup(token, value, deftbl) == YES)
      cndget = C_TRUE
   else
      cndget = -C_TRUE

   return
   end
#-h- cndlu            952  asc  25-mar-82 08:22:33  v1.1 (sw-tools v1.1)
# cndlu - look up token in list of conditionals

   character function cndlu (token)

   character token(MAXTOK)

   integer i, j
   character temp (9)

   ext_func integer index, equal
   ext_subr upper

   string letts "eEiI"
   string cndtbl "ifdef/ ifnotdef/ elsedef/ enddef/ "

   data cndtbl(7)/IFDEFTYPE/,cndtbl(17)/IFNOTDEFTYPE/,cndtbl(26)/ELSEDEFTYPE/,
        cndtbl(34)/ENDDEFTYPE/

   cndlu = NOTDEFTYPE
   if (index (letts, token (1)) > 0)
      {
      for (i=1; cndtbl(i) != EOS; i=i+1)
         {
         for (j=1; cndtbl(i) != '/'; [i=i+1; j=j+1])
            temp(j) = cndtbl(i)
         temp(j) = EOS
         i = i + 1                 # bump past /
         j = equal(token, temp)
         if (j == NO)
            {
            call upper(temp)
            j = equal(token, temp)
            }
         if (j == YES)
            {
            cndlu = cndtbl(i)
            break
            }
         }
      }

   return
   end
#-h- deftok          3848  asc  25-mar-82 08:22:36  v1.1 (sw-tools v1.1)
# deftok - get token; process macro calls and invocations

# this routine has been disabled to allow defines with parameters to be added

#   character function deftok (token, toksiz)
#   character gtok
#   integer toksiz
#   character defn (MAXDEF), t, token (MAXTOK)
#   integer ludef
#   include COMMON_BLOCKS
#
#   for (t = gtok (token, toksiz); t!=EOF; t = gtok (token, toksiz)) {
#      if (t != ALPHA)   # non-alpha
#         break
#      if (ludef (token, defn, deftbl) == NO)     # undefined
#         break
#      if (defn (1) == DEFTYPE) {   # get definition
#         call getdef (token, toksiz, defn, MAXDEF)
#         call entdef (token, defn, deftbl)
#         }
#      else
#         call pbstr (defn)   # push replacement onto input
#      }
#   deftok = t
#   if (deftok == ALPHA)   # convert to single case
#      call fold (token)
#   return
#   end
# deftok - get token; process macro calls and invocations

   character function deftok (token, toksiz)
   character token (MAXTOK)
   integer toksiz

   include COMMON_BLOCKS

   character t, c, defn (MAXDEF)
   integer ap, argstk (ARGSIZE), callst (CALLSIZE),
      nlb, plev (CALLSIZE), ifl

   ext_func integer ludef, push, ifparm
   ext_func character gctok
   ext_subr puttok, getdef, entdef, baderr, putchr, pbstr, putbak, evalr, fold

   string balp "()"

   cp = 0
   ap = 1
   ep = 1
   for (t = gctok (token, toksiz); t != EOF; t = gctok (token, toksiz)) {
      if (t == ALPHA)
         if (ludef (token, defn, deftbl) == NO)
            if (cp == 0)
               break
            else
               call puttok (token)
         else if (defn (1) == DEFTYPE) {   # process defines directly
            call getdef (token, toksiz, defn, MAXDEF)
            call entdef (token, defn, deftbl)
            }
         else {
            cp = cp +  1
            if (cp > CALLSIZE)
               call baderr ("call stack overflow.")
            callst (cp) = ap
            ap = push (ep, argstk, ap)
            call puttok (defn)
            call putchr (EOS)
            ap = push (ep, argstk, ap)
            call puttok (token)
            call putchr (EOS)
            ap = push (ep, argstk, ap)
            t = gctok (token, toksiz)
            if (t == ' ') {             # allow blanks before arguments
               t = gctok (token, toksiz)
               call pbstr (token)
               if (t != '(')
                  call putbak (' ')
               }
            else
               call pbstr (token)
            if (t != '(')
               call pbstr (balp)
            else if (ifparm (defn) == NO)
               call pbstr (balp)
            plev (cp) = 0
            }
      else if (t == LSTRIPC) {
         nlb = 1
         repeat {
            t = gctok (token, toksiz)
            if (t == LSTRIPC)
               nlb = nlb + 1
            else if (t == RSTRIPC) {
               nlb = nlb - 1
               if (nlb == 0)
                  break
               }
            else if (t == EOF)
            call baderr ("EOF in string.")
            call puttok (token)
            }
         }
      else if (cp == 0)
         break
      else if (t == '(') {
         if (plev (cp) > 0)
            call puttok (token)
         plev (cp) = plev (cp) + 1
         }
      else if (t == ')') {
         plev (cp) = plev (cp) - 1
         if (plev (cp) > 0)
            call puttok (token)
         else {
            call putchr (EOS)
            call evalr (argstk, callst (cp), ap - 1)
            ap = callst (cp)
            ep = argstk (ap)
            cp =  cp - 1
            }
         }
      else if (t == ',' & plev (cp) == 1) {
         call putchr (EOS)
         ap = push (ep, argstk, ap)
         }
      else
         call puttok (token)
      }

   deftok = t
   if (t == ALPHA)
      call fold (token)

   return
   end
#-h- doarth           873  asc  25-mar-82 08:22:40  v1.1 (sw-tools v1.1)
# doarth - do arithmetic operation

   subroutine doarth (argstk, i, j)
   integer argstk (ARGSIZE), i, j

   include COMMON_BLOCKS

   integer k, l, ans, first, second
   character op

   ext_func integer ctoi
   ext_subr pbnum, synerr

   k = argstk (i + 2)
   first = ctoi(evalst, k)
   l = argstk (i + 4)
   second = ctoi(evalst, l)
   op = evalst (argstk (i + 3))
   if (op == '+')
      call pbnum (first + second)
   else if (op == '-')
      call pbnum (first - second)
   else if (op ==  '*' )
      {
      if (evalst(argstk(i+3) + 1) == '*')
         {
         ans = 1
         for ( ; second > 0; second = second - 1)
            ans = ans * first
         call pbnum(ans)
         }
      else
         call pbnum (first * second)
      }
   else if (op ==  '/' )
      call pbnum (first / second)
   else
      call synerr ("arith error.")

   return
   end
#-h- docode           563  asc  25-mar-82 08:22:42  v1.1 (sw-tools v1.1)
# docode - generate code for beginning of do

   subroutine docode (lab)
   integer lab

   integer labgen

   include COMMON_BLOCKS


   ext_func character gnbtok
   ext_subr outtab, outstr, outch, pbstr, outnum, eatup, outdon

   string sdo "do"

   xfer = NO
   call outtab
   call outstr (sdo)
   call outch (' ')
   lab = labgen (2)
   if (gnbtok (scrtok, MAXTOK) == DIGIT) # check for fortran DO
      call outstr (scrtok)
   else {
      call pbstr (scrtok)
      call outnum (lab)
      }
   call outch (' ')
   call eatup
   call outdon
   return
   end
#-h- doif             486  asc  25-mar-82 08:22:43  v1.1 (sw-tools v1.1)
# doif - select one of two (macro) arguments

   subroutine doif (argstk, i, j)
   integer argstk (ARGSIZE), i, j

   include COMMON_BLOCKS

   integer a2, a3, a4, a5

   ext_func integer equal
   ext_subr pbstr

   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           274  asc  25-mar-82 08:22:44  v1.1 (sw-tools v1.1)
# doincr - increment macro argument by 1

   subroutine doincr (argstk, i, j)
   integer argstk (ARGSIZE), i, j

   include COMMON_BLOCKS

   integer k

   ext_func integer ctoi
   ext_subr pbnum

   k = argstk (i + 2)
   call pbnum (ctoi (evalst, k) + 1)

   return
   end
#-h- domac            346  asc  25-mar-82 08:22:45  v1.1 (sw-tools v1.1)
# domac - install macro definition in table

   subroutine domac (argstk, i, j)
   integer argstk (ARGSIZE), i, j

   include COMMON_BLOCKS

   integer a2, a3

   ext_subr entdef

   if (j - i > 2) {
      a2 = argstk (i + 2)
      a3 = argstk (i + 3)
      call entdef (evalst (a2), evalst (a3), deftbl)     # subarrays
      }
   return
   end
#-h- dostat           176  asc  25-mar-82 08:22:46  v1.1 (sw-tools v1.1)
# dostat - generate code for end of do statement

   subroutine dostat (lab)
   integer lab

   ext_subr outcon

   call outcon (lab)
   call outcon (lab + 1)
   return
   end
#-h- dosub            738  asc  25-mar-82 08:22:47  v1.1 (sw-tools v1.1)
# dosub - select macro substring

   subroutine dosub (argstk, i, j)
   integer argstk (ARGSIZE), i, j

   include COMMON_BLOCKS

   integer ap, fc, k, nc

   ext_func integer ctoi, length
   ext_subr putbak

   if (j - i < 3)
      return
   if (j - i < 4)
      nc = MAXTOK
   else {
      k = argstk (i + 4)
      nc = ctoi (evalst, k)      # number of characters
      }
   k = argstk (i + 3)         # origin
   ap = argstk (i + 2)         # target string
   fc = ap + ctoi (evalst, k) - 1   # first char of substring
   if (fc >= ap & fc < ap + length (evalst (ap))) {   # subarrays
      k = fc + min (nc, length (evalst (fc))) - 1
       for ( ; k >= fc; k = k - 1)
          call putbak (evalst (k))
       }

    return
    end
#-h- dother           510  asc  25-mar-82 08:22:49  v1.1 (sw-tools v1.1)
# process one other string in for clause

character function dother(token)

character token(MAXTOK), t

ext_func character gettok
ext_subr outtab, synerr, pbstr, squash, outstr, outdon

call outtab
repeat
  {
  t = gettok(token, MAXTOK)
  if (t == ';' | t == '}')
    break
  if (t == EOF)
    {
    call synerr("unexpected EOF.")
    call pbstr(token)
    break
    }
 ifdef (DO_LONGNAME)
  if (t == ALPHA)
    call squash(token)
 enddef
  if (t != '@n')
    call outstr(token)
  }
call outdon
return(t)

end
#-h- eatup           1111  asc  25-mar-82 08:22:50  v1.1 (sw-tools v1.1)
# eatup - process rest of statement; interpret continuations

   subroutine eatup

   character ptoken (MAXTOK), t, token (MAXTOK)
   integer nlpar

   ext_func character gettok
   ext_subr pbstr, synerr, squash, outstr

   nlpar = 0
   repeat {
      t = gettok (token, MAXTOK)
      if (t == ';' | t == '@n')
         break
      if (t == '}' | t == '{') {
         call pbstr (token)
         break
         }
      if (t == EOF) {
         call synerr ("unexpected EOF.")
         call pbstr (token)
         break
         }
      if (t == ',' | t == '+' | t == '-' | t == '*' |
       t == '(' | t == AND | t == OR | t == NOT |
       t == '!' | t == '~' | t == '^' | t == '=') {
         while (gettok (ptoken, MAXTOK) == '@n')
            ;
         call pbstr (ptoken)
         }
      if (t == '(')
         nlpar = nlpar + 1
      else if (t == ')')
         nlpar = nlpar - 1
     ifdef (DO_LONGNAME)
      if (t == ALPHA)
         call squash (token)
     enddef
      call outstr (token)
      } until (nlpar < 0)
   if (nlpar != 0)
      call synerr ("unbalanced parentheses.")

   return
   end
#-h- elenth           299  asc  25-mar-82 08:22:53  v1.1 (sw-tools v1.1)
# calculate length of buf, taking escaped characters into account

   integer function elenth(buf)

   character buf(ARB), c
   integer i, n

   ext_func character esc

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

   return
   end
#-h- elseif           182  asc  25-mar-82 08:22:53  v1.1 (sw-tools v1.1)
# elseif - generate code for end of if before else

   subroutine elseif (lab)
   integer lab

   ext_subr outgo, outcon

   call outgo (lab+1)
   call outcon (lab)
   return
   end
#-h- entdkw           757  asc  25-mar-82 08:22:55  v1.1 (sw-tools v1.1)
# entdkw --- install macro processor keywords

   subroutine entdkw

   character deft (2), inct (2), subt (2), ift (2), art (2), mact (2)

   ext_subr ulstal

   string defnam "define"
   string macnam "mdefine"
   string incnam "incr"
   string subnam "substr"
   string ifnam "ifelse"
   string arnam "arith"

   data deft (1), deft (2) /DEFTYPE, EOS/
   data mact (1), mact (2) /MACTYPE, EOS/
   data inct (1), inct (2) /INCTYPE, EOS/
   data subt (1), subt (2) /SUBTYPE, EOS/
   data ift (1), ift (2) /IFTYPE, EOS/
   data art (1), art (2) /ARITHTYPE, EOS/

   call ulstal (defnam, deft)
   call ulstal (macnam, mact)
   call ulstal (incnam, inct)
   call ulstal (subnam, subt)
   call ulstal (ifnam, ift)
   call ulstal (arnam, art)

   return
   end
#-h- entfkw          1080  asc  25-mar-82 08:22:56  v1.1 (sw-tools v1.1)
# entfkw - place Fortran keywords in symbol table

  ifdef (DO_LONGNAME)
   subroutine entfkw

   include COMMON_BLOCKS

   integer junk

   ext_func integer enter

   # Place in the following table any long (> 6 characters)
   #  keyword that is used by your Fortran compiler:

   string sconti "continue"
   string scompl "complex"
   string slogic "logical"
   string simpli "implicit"
   string sparam "parameter"
   string sexter "external"
   string sdimen "dimension"
   string sinteg "integer"
   string sequiv "equivalence"
   string sfunct "function"
   string ssubro "subroutine"
   string spreci "precision"

   junk = enter (sconti, 0, fkwtbl)
   junk = enter (scompl, 0, fkwtbl)
   junk = enter (slogic, 0, fkwtbl)
   junk = enter (simpli, 0, fkwtbl)
   junk = enter (sparam, 0, fkwtbl)
   junk = enter (sexter, 0, fkwtbl)
   junk = enter (sdimen, 0, fkwtbl)
   junk = enter (sinteg, 0, fkwtbl)
   junk = enter (sequiv, 0, fkwtbl)
   junk = enter (sfunct, 0, fkwtbl)
   junk = enter (ssubro, 0, fkwtbl)
   junk = enter (spreci, 0, fkwtbl)

   return
   end
  enddef
%%D 5
#-h- entrkw          1133  asc  25-mar-82 08:22:58  v1.1 (sw-tools v1.1)
%%E 5
%%I 5
#-h- entrkw          1203  asc  18-oct-82 13:09:58  sventek (joseph sventek)
%%E 5
# entrkw --- install Ratfor keywords in symbol table

   subroutine entrkw

   include COMMON_BLOCKS

   integer junk

   ext_func integer enter

   string sif "if"
   string selse "else"
   string swhile "while"
   string sdo "do"
   string sbreak "break"
   string snext "next"
   string sfor "for"
   string srept "repeat"
   string suntil "until"
   string sret "return"
   string sstr "string"
%%D 5
  ifdef (DO_SELECT)
%%E 5
%%I 5
  ifdef (DO_SWITCH)
   string sswtch "switch"
%%E 5
   string sselct "select"
   string scase "case"
   string sdeflt "default"
  enddef

   junk = enter (sif, LEXIF, rkwtbl)
   junk = enter (selse, LEXELSE, rkwtbl)
   junk = enter (swhile, LEXWHILE, rkwtbl)
   junk = enter (sdo, LEXDO, rkwtbl)
   junk = enter (sbreak, LEXBREAK, rkwtbl)
   junk = enter (snext, LEXNEXT, rkwtbl)
   junk = enter (sfor, LEXFOR, rkwtbl)
   junk = enter (srept, LEXREPEAT, rkwtbl)
   junk = enter (suntil, LEXUNTIL, rkwtbl)
   junk = enter (sret, LEXRETURN, rkwtbl)
   junk = enter (sstr, LEXSTRING, rkwtbl)
%%D 5
  ifdef (DO_SELECT)
   junk = enter (sselct, LEXSELECT, rkwtbl)
%%E 5
%%I 5
  ifdef (DO_SWITCH)
   junk = enter (sswtch, LEXSWITCH, rkwtbl)
   junk = enter (sselct, LEXSWITCH, rkwtbl)
%%E 5
   junk = enter (scase, LEXCASE, rkwtbl)
   junk = enter (sdeflt, LEXDEFAULT, rkwtbl)
  enddef

   return
   end
%%D 3
#-h- evalr           1281  asc  25-mar-82 08:23:00  v1.1 (sw-tools v1.1)
%%E 3
%%I 3
#-h- evalr           1382  asc  04-may-82 11:18:43  j (sventek j)
%%E 3
# evalr - expand args i through j: evaluate builtin or push back defn

   subroutine evalr (argstk, i, j)
   integer argstk (ARGSIZE), i, j

   include COMMON_BLOCKS

   integer argno, k, m, n, t, td

   ext_func integer index, length
   ext_subr domac, doincr, dosub, doif, doarth, putbak, pbstr

   string digits "0123456789"

   t = argstk (i)
   td = evalst (t)
   if (td == MACTYPE)
      call domac (argstk, i, j)
   else if (td == INCTYPE)
      call doincr (argstk, i, j)
   else if (td == SUBTYPE)
      call dosub (argstk, i, j)
   else if (td == IFTYPE)
      call doif (argstk, i, j)
   else if (td == ARITHTYPE)
      call doarth (argstk, i, j)
   else {
      for (k = t + length (evalst (t)) - 1; k > t; k = k - 1)
         if (evalst (k - 1) != ARGFLAG)
            call putbak (evalst (k))
         else {
            argno = index (digits, evalst (k))  -  1
%%D 3
            if (argno >= 0 & argno < j - i) {
               n = i + argno + 1
               m = argstk (n)
               call pbstr (evalst (m))
               k = k - 1
%%E 3
%%I 3
            if (argno >= 0)			# was a digit
               {
               if (argno < j - i)		# user provided argument
                  {
                  n = i + argno + 1
                  m = argstk (n)
                  call pbstr (evalst (m))
                  }
               k = k - 1			# skip over $
%%E 3
               }
            else
               call putbak (evalst (k))
%%D 3
#            k = k - 1   # skip over $
%%E 3
            }
      if (k == t)         # do last character
         call putbak (evalst (k))
      }
   return
   end
#-h- fclaus           550  asc  25-mar-82 08:23:02  v1.1 (sw-tools v1.1)
# process for init or re-init clause

subroutine fclaus

character token(MAXTOK), t
integer brace

ext_func character gnbtok, dother
ext_subr pbstr, synerr

if (gnbtok(token, MAXTOK) == '{')	# { mother }
  brace = YES
else
  {
  call pbstr(token)			# other
  brace = NO
  }
t = dother(token)
if (brace == YES)
  {
  while (t != '}' & t != EOF)
    {
    t = gnbtok(token, MAXTOK)		# get rid of leading blanks
    call pbstr(token)
    t = dother(token)
    }
  if (gnbtok(token, MAXTOK) != ';')
    call synerr("invalid for clause.")
  }

return
end
#-h- finit            452  asc  25-mar-82 08:23:03  v1.1 (sw-tools v1.1)
# finit - initialize for each input file

   subroutine finit

   include COMMON_BLOCKS

   outp = 0  # output character pointer
   level = 1  # file control
   linect (1) = 1
   sbp  = 1
   fnamp = 2
   fnames (1) = EOS
   bp = 0	# nothing in push back buffer
   fordep = 0  # for stack
   fcname (1) = EOS # current function name
%%D 5
  ifdef (DO_SELECT)
   setop = 0  # select stack
   selast = 1
%%E 5
%%I 5
  ifdef (DO_SWITCH)
   swtop = 0  # switch stack
   swlast = 1
%%E 5
  enddef
   csp = 0
   curcnd = C_TRUE

   return
   end
#-h- forcod          2718  asc  25-mar-82 08:23:05  v1.1 (sw-tools v1.1)
# forcod - beginning of for statement

   subroutine forcod (lab)
   integer lab

   include COMMON_BLOCKS

   character t
   integer i, j, nlpar, len

   ext_func character gettok, gnbtok
   ext_func integer length, labgen
   ext_subr outcon, synerr, pbstr, fclaus, outnum, outtab, outstr, outch
   ext_subr squash, outgo, baderr, scopy

   string ifnot "if (.not."
   string semi ";"

   lab = labgen (3)
   call outcon (0)
   if (gnbtok (scrtok, MAXTOK) != '(') {
      call synerr ("missing left paren.")
      return
      }
   if (gnbtok (scrtok, MAXTOK) != ';') {   # real init clause
      call pbstr (scrtok)
      call fclaus			# output init clause
      }
   if (gnbtok (scrtok, MAXTOK) == ';')   # empty condition
      call outcon (lab)
   else {   # non-empty condition
      call pbstr (scrtok)
      call outnum (lab)
      call outtab
      call outstr (ifnot)
      call outch ('(')
      nlpar = 0
      while (nlpar >= 0) {
         t = gettok (scrtok, MAXTOK)
         if (t == ';')
            break
         if (t == '(')
            nlpar = nlpar + 1
         else if (t == ')')
            nlpar = nlpar - 1
         if (t == EOF) {
            call pbstr (scrtok)
            return
            }
        ifdef (DO_LONGNAME)
         if (t == ALPHA)
            call squash (scrtok)
        enddef
         if (t != '@n')
            call outstr (scrtok)
         }
      call outch (')')
      call outch (')')
      call outgo (lab+2)
      if (nlpar < 0)
         call synerr ("invalid for clause.")
      }
   fordep = fordep + 1   # stack reinit clause
   len = 0		 # total length of re-init clause
   j = 1
   for (i = 1; i < fordep; i = i + 1)   # find end
      j = j + length (forstk (j)) + 1
   forstk (j) = EOS   # null, in case no reinit
   nlpar = 0
   t = gnbtok (scrtok, MAXTOK)
   call pbstr (scrtok)
   while (nlpar >= 0) {
      t = gettok (scrtok, MAXTOK)
      if (t == '(')
         nlpar = nlpar + 1
      else if (t == ')')
         nlpar = nlpar - 1
      if (t == EOF) {
         call pbstr (scrtok)
         break
         }
      if (nlpar >= 0 & t != '@n') {
        ifdef (DO_LONGNAME)
         if (t == ALPHA)
            call squash (scrtok)
        enddef
         if (j + length (scrtok) >= MAXFORSTK)
            call baderr ("for clause too long.")
         call scopy (scrtok, 1, forstk, j)
         j = j + length (scrtok)
         len = len + length (scrtok)
         }
      else if (nlpar == -1 & len > 0)	# tag clause with semicolon
         {
         if (j < MAXFORSTK)
            call scopy(semi, 1, forstk, j)
         else
            call baderr("for clause too long.")
         }
      }
   lab = lab + 1   # label for next's
   return
   end
#-h- fors             544  asc  25-mar-82 08:23:08  v1.1 (sw-tools v1.1)
# fors - process end of for statement

   subroutine fors (lab)
   integer lab

   include COMMON_BLOCKS

   integer i, j

   ext_func integer length
   ext_subr outnum, pbstr, fclaus, outgo, outcon

   xfer = NO
   call outnum (lab)
   j = 1
   for (i = 1; i < fordep; i = i + 1)
      j = j + length (forstk (j)) + 1
   if (length (forstk (j)) > 0) {
      call pbstr (forstk (j))		# push back re-init clause
      call fclaus			# output clause
      }
   call outgo (lab - 1)
   call outcon (lab + 1)
   fordep = fordep - 1
   return
   end
#-h- gctok            975  asc  25-mar-82 08:23:10  v1.1 (sw-tools v1.1)
# gctok - get next token subject to conditionals

   character function gctok(token, toksiz)

   character token(MAXTOK)
   integer toksiz

   include COMMON_BLOCKS

   character c
   integer newcnd

   ext_func character gtok, cndlu
   ext_func integer cndget
   ext_subr baderr

   for (gctok=gtok(token,toksiz); gctok != EOF; gctok=gtok(token,toksiz))
      {
      c = cndlu (token)
      if (c == NOTDEFTYPE)
         {
         if (curcnd == C_TRUE)
            break
         }
      else if (c == ENDDEFTYPE)
         {
         if (csp <= 0)
            call baderr("Illegal enddef encountered.")
         curcnd = cndstk(csp)
         csp = csp - 1
         }
      else
         {
         if (c == IFDEFTYPE)
            newcnd = cndget (token, toksiz)
         else if (c == IFNOTDEFTYPE)
            newcnd = - cndget (token, toksiz)
         else
            newcnd = - curcnd
         curcnd = min (newcnd, cndstk (csp) )
         }
      }

   return
   end
#-h- getdef          1661  asc  25-mar-82 08:23:11  v1.1 (sw-tools v1.1)
# getdef (for no arguments) - get name and definition

   subroutine getdef (token, toksiz, defn, defsiz)
   character token (MAXTOK), defn (MAXDEF)
   integer toksiz, defsiz

   include COMMON_BLOCKS

   character c, t, ptoken (MAXTOK)
   integer i, nlpar

   ext_func character gctok, ngetch
   ext_subr skpblk, pbstr, baderr, putbak

   call skpblk
   c = gctok (ptoken, MAXTOK)
   if (c == '(')
      t = '('             # define (name, defn)
   else {
      t = ' '              # define name defn
      call pbstr (ptoken)
      }
   call skpblk
   if (gctok (token, toksiz) != ALPHA)
      call baderr ("non-alphanumeric name.")
   call skpblk
   c = gctok (ptoken, MAXTOK)
   if (t == ' ') {         # define name defn
      call pbstr (ptoken)
      i = 1
      repeat {
         c = ngetch (c)
         if (i > defsiz)
            call baderr ("definition too long.")
         defn (i) = c
         i = i + 1
         } until (c == '#' | c == '@n' | c == EOF)
      if (c == '#')
         call putbak (c)
      }
   else if (t == '(') {   # define (name, defn)
      if (c != ',')
         call baderr ("missing comma in define.")
      # else got (name,
      nlpar = 0
      for (i = 1; nlpar >= 0; i = i + 1)
         if (i > defsiz)
            call baderr ("definition too long.")
         else if (ngetch (defn (i)) == EOF)
            call baderr ("missing right paren.")
         else if (defn (i) == '(')
            nlpar = nlpar + 1
         else if (defn (i) == ')')
            nlpar = nlpar - 1
         # else normal character in defn (i)
      }
   else
      call baderr ("getdef is confused.")
   defn (i - 1) = EOS
   return
   end
%%D 6
#-h- gettok          2320  asc  25-mar-82 08:23:14  v1.1 (sw-tools v1.1)
%%E 6
%%I 6
#-h- gettok          2321  asc  19-oct-82 17:16:01  sventek (joseph sventek)
%%E 6
# gettok - get token. handles file inclusion and line numbers

   character function gettok (token, toksiz)
   character token (MAXTOK)
   integer toksiz

   include COMMON_BLOCKS

   integer i, len
   character name (MAXNAME), t

   ext_func integer equal, open, length
   ext_func character deftok
   ext_subr skpblk, pbstr, synerr, putbak, scopy, close

   string fncn "function"
   string incl "include"


  ifnotdef (DO_BOOTSTRAP)
   for ( ; level > 0; level = level - 1) {
  enddef

      for (gettok = deftok (token, toksiz); gettok != EOF;
       gettok = deftok (token, toksiz)) {
         if (equal (token, fncn) == YES) {
            call skpblk
            t = deftok (fcname, MAXNAME)
            call pbstr (fcname)
            if (t != ALPHA)
               call synerr ("missing function name.")
            call putbak (' ')
            return
            }
         else if (equal (token, incl) == NO)
            return
         # process 'include' statements:
         call skpblk
         t = deftok (name, MAXNAME)
%%D 6
         if (t == ''' | t == '"') {
%%E 6
%%I 6
         if (t == '@'' | t == '"') {
%%E 6
            len = length (name) - 1
            for (i = 1; i < len; i = i + 1)
               name (i) = name (i + 1)
            name (i) = EOS
            }
         i = length (name) + 1

        ifnotdef (DO_BOOTSTRAP)
         if (level >= NFILES)
            call synerr ("includes nested too deeply.")
         else {
            infile (level + 1) = open (name, READ)
            linect (level + 1) = 1
            if (infile (level + 1) == ERR)
        enddef

               call synerr ("can't open include.")

        ifnotdef (DO_BOOTSTRAP)
            else {
               level = level + 1
               if (fnamp + i <= MAXFNAMES) {
                  call scopy (name, 1, fnames, fnamp)
                  fnamp = fnamp + i    # push file name stack
                  }
               }
            }
        enddef

         }

     ifnotdef (DO_BOOTSTRAP)
      if (level > 1) {      # close include file pop file name stack
         call close (infile (level))
         for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1)
            if (fnames (fnamp - 1) == EOS)
               break
         }
      }
     enddef


   token (1) = EOF   # in case called more than once
   token (2) = EOS
   gettok = EOF
   return
   end
#-h- gnbtok           322  asc  25-mar-82 08:23:17  v1.1 (sw-tools v1.1)
# gnbtok - get nonblank token

   character function gnbtok (token, toksiz)
   character token (MAXTOK)
   integer toksiz

   include COMMON_BLOCKS

   ext_func character gettok
   ext_subr skpblk

   repeat
      {
      call skpblk
      gnbtok = gettok (token, toksiz)
      }
   until (gnbtok != ' ')
   return
   end
%%D 6
#-h- gtok            4370  asc  25-mar-82 08:23:19  v1.1 (sw-tools v1.1)
%%E 6
%%I 6
%%D 10
#-h- gtok            6067  asc  19-oct-82 20:55:48  sventek (joseph sventek)
%%E 10
%%E 6
%%I 10
#-h- gtok            6114  asc  16-dec-81 23:22:41  sventek (joseph sventek)
%%E 10
# gtok - get token for Ratfor

   character function gtok (lexstr, toksiz)
   character lexstr (MAXTOK)
   integer toksiz

   include COMMON_BLOCKS

   character c
   integer i, b, n, d

   ext_func character ngetch, type, clower, esc
%%D 6
   ext_func integer itoc, index
%%E 6
%%I 6
   ext_func integer itoc, index, ctoi
%%E 6
   ext_subr putbak, synerr, relate

   string digits "0123456789abcdefghijklmnopqrstuvwxyz"
%%I 10
   string alfchr ALPHA_CHARACTERS
%%E 10

   repeat		# get next character, gobbling "_@n"
      {
      c = ngetch (lexstr (1))
      if (c == '_')
         if (ngetch(c) != '@n')
            {
            call putbak(c)
            c = '_'
            break
            }
      }
   until (lexstr(1) != '_')

   if (c == ' ' | c == '@t') {
      lexstr (1) = ' '
      while (c == ' ' | c == '@t')    # compress many blanks to one
         c = ngetch (c)
      if (c == '#')
         while (ngetch (c) != '@n')   # strip comments
            ;
      if (c != '@n')
         call putbak (c)
      else
         lexstr (1) = '@n'
      lexstr (2) = EOS
      gtok = lexstr (1)
      return
      }

   i = 1
   if (IS_LETTER(c)) {    # alpha
      for (i = 1; i < toksiz - 2; i = i + 1) {
         c = ngetch (lexstr (i + 1))
%%D 10
         if (!IS_LETTER(c) & !IS_DIGIT(c) & c != '_')
%%E 10
%%I 10
         if (!IS_LETTER(c) & !IS_DIGIT(c) & index(alfchr, c) == 0)
%%E 10
            break
         }
      call putbak (c)
      gtok = ALPHA
      }

   else if (IS_DIGIT(c)) {   # digits
%%D 6
      b = c - '0' # in case alternate base number
%%E 6
      for (i = 1; i < toksiz - 2; i = i + 1) {
         c = ngetch (lexstr (i + 1))
%%D 6
         if (!IS_DIGIT(c))
%%E 6
%%I 6
         if (c == '_')				# permit embedded underscores
            i = i - 1
         else if (!IS_DIGIT(c))
%%E 6
            break
%%D 6
         b = 10 * b + c - '0'
%%E 6
         }
%%I 6
      if (c == RADIX) {                      # possibly n%ddd
         lexstr(i + 1) = EOS                 # terminate numeric string
         n = 1
         b = ctoi(lexstr, n)                 # have base of number
         }
%%E 6
      if (c == RADIX & b >= 2 & b <= 36) {   #n%ddd...
         n = 0
         repeat {
            d = index (digits, clower (ngetch (c))) - 1
%%D 6
            if (d < 0)
%%E 6
%%I 6
            if (c == '_')
               next
            else if (d < 0)
%%E 6
               break
            n = b * n + d
            }
         call putbak (c)
         i = itoc (n, lexstr, toksiz)
         }
      else
         call putbak (c)
      gtok = DIGIT
      }

   else if (c == '[') {   # allow [ for {
      lexstr (1) = '{'
      gtok = '{'
      }

   else if (c == ']') {   # allow ] for }
      lexstr (1) = '}'
      gtok = '}'
      }

   else if (c == '$') {    # $( and $) now used by macro processor
      if (ngetch (lexstr (2)) == '(') {
         i = 2
         gtok = LSTRIPC
         }
      else if (lexstr (2) == ')') {
         i = 2
         gtok = RSTRIPC
         }
      else {
         call putbak (lexstr (2))
         gtok = '$'
         }
      }

%%D 6
   else if (c == ''')
      {
      i = 2
      if (ngetch(lexstr(1)) == '@@')
         {
         c = ngetch(lexstr(2))
         i = 3
         }
      lexstr(i) = EOS
      i = 1
      c = esc(lexstr, i)
      n = c
      i = itoc(n, lexstr, toksiz)
      gtok = DIGIT
      if (ngetch(c) != ''')
         {
         call synerr("missing apostrophe in character constant.")
         for ( ; c != EOF; c = ngetch(c))
             if (c == ''' | c == '@n')
                break
         if (c == '@n')
            call putbak('@n')
         }
      }

   else if (c == '"') {
%%E 6
%%I 6
#   else if (c == '@'')
#      {
#      i = 2
#      if (ngetch(lexstr(1)) == '@@')
#         {
#         c = ngetch(lexstr(2))
#         i = 3
#         }
#      lexstr(i) = EOS
#      i = 1
#      c = esc(lexstr, i)
#      n = c
#      i = itoc(n, lexstr, toksiz)
#      gtok = DIGIT
#      if (ngetch(c) != '@'')
#         {
#         call synerr("missing apostrophe in character constant.")
#         for ( ; c != EOF; c = ngetch(c))
#             if (c == '@'' | c == '@n')
#                break
#         if (c == '@n')
#            call putbak('@n')
#         }
#      }
#
#   else if (c == '"') {
#      gtok = c
#      for (i = 2; ngetch(c) != EOF; i = i + 1) {
#         lexstr(i) = c
#         if (c == '@@')		# consume @<char>
#            if (ngetch(c) == EOF)
#               call putbak(c)
#            else
#               {
#               i = i + 1
#               if (i >= toksiz -1)
#                  i = toksiz - 1
#               lexstr(i) = c
#               c = '@@'
#               }
#         if (c == '"')
#            break
#         if (lexstr (i) == '_')
#            if (ngetch (c) == '@n') {
#               while (c == '@n' | c == ' ' | c == '@t')
#                  c = ngetch (c)
#               lexstr (i) = c
#               }
#            else
#               call putbak (c)
#         if (lexstr (i) == '@n' | i >= toksiz - 1) {
#            call synerr ("missing quote.")
#            lexstr (i) = lexstr (1)
#            call putbak ('@n')
#            break
#            }
#         }
#      }
   else if (c == '"' | c == '@'') {		# string or character constant
%%E 6
      gtok = c
      for (i = 2; ngetch(c) != EOF; i = i + 1) {
         lexstr(i) = c
%%D 6
         if (c == '@@')		# consume @<char>
%%E 6
%%I 6
         if (lexstr(i) == '_') {		# see if continuation
            if (ngetch(c) == '@n') {
               while (c == '@n' | c == ' ' | c == '@t')
                  c = ngetch(c)
               lexstr(i) = c
               }
            else
               call putbak(c)
            c = lexstr(i)
            }
         if (c == '@@') {			# keep @<char> intact
%%E 6
            if (ngetch(c) == EOF)
               call putbak(c)
%%D 6
            else
               {
%%E 6
%%I 6
            else {
%%E 6
               i = i + 1
%%D 6
               if (i >= toksiz -1)
%%E 6
%%I 6
               if (i >= toksiz - 1)
%%E 6
                  i = toksiz - 1
               lexstr(i) = c
%%D 6
               c = '@@'
%%E 6
               }
%%D 6
         if (c == '"')
%%E 6
%%I 6
            c = '@@'
            }
         if (c == lexstr(1))			# found terminator
%%E 6
            break
%%D 6
         if (lexstr (i) == '_')
            if (ngetch (c) == '@n') {
               while (c == '@n' | c == ' ' | c == '@t')
                  c = ngetch (c)
               lexstr (i) = c
               }
            else
               call putbak (c)
         if (lexstr (i) == '@n' | i >= toksiz - 1) {
%%E 6
%%I 6
         if (lexstr(i) == '@n' | i >= toksiz - 1) {
%%E 6
            call synerr ("missing quote.")
%%D 6
            lexstr (i) = lexstr (1)
            call putbak ('@n')
%%E 6
%%I 6
            lexstr(i) = lexstr(1)
            call putbak('@n')
%%E 6
            break
            }
         }
%%I 6
      if (lexstr(1) == '@'') {			# see if character constant
         n = 2
         c = esc(lexstr, n)
         if (lexstr(n + 1) == '@'') {		# YES, convert it
            n = c
            i = itoc(n, lexstr, toksiz)		# convert to characters
            gtok = DIGIT
            }
         }
%%E 6
      }

   else if (c == '#') {   # strip comments
      while (ngetch (lexstr (1)) != '@n')
         ;
      gtok = '@n'
      }

   else if (c == '>' | c == '<' | c == NOT | c == AND | c == OR |
    c == '=' | c == '!' | c == '~' | c == '^') {
      call relate (lexstr, i)
      gtok = c
      }

   else
      gtok = c

   if (i >= toksiz - 1)
      call synerr ("token too long.")
   lexstr (i + 1) = EOS

   # Note:  line number accounting is now done in 'ngetch'

   return
   end
#-h- ifcode           224  asc  25-mar-82 08:23:22  v1.1 (sw-tools v1.1)
# ifcode - generate initial code for if

   subroutine ifcode (lab)
   integer lab

   include COMMON_BLOCKS

   ext_func integer labgen
   ext_subr ifgo

   xfer = NO
   lab = labgen (2)
   call ifgo (lab)
   return
   end
#-h- ifgo             394  asc  25-mar-82 08:23:23  v1.1 (sw-tools v1.1)
# ifgo - generate "if (.not.(...))goto lab"

   subroutine ifgo (lab)
   integer lab

   ext_subr outtab, outstr, balpar, outch, outgo

   string ifnot "if (.not."

   call outtab         # get to column 7
   call outstr (ifnot)      # " if (.not. "
   call balpar         # collect and output condition
   call outch (')')      # " ) "
   call outgo (lab)      # " goto lab "
   return
   end
#-h- ifparm           729  asc  25-mar-82 08:23:25  v1.1 (sw-tools v1.1)
# ifparm - determines if the defined symbol has arguments in its
# definition.  This effects how the macro is expanded.

   integer function ifparm (strng)
   character strng (ARB)

   character c
   integer i

   ext_func integer index
   ext_func character type

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

   return
   end
#-h- initkw           777  asc  25-mar-82 08:23:26  v1.1 (sw-tools v1.1)
# initkw - initialize tables and important global variables
# this routine assumes that there is no error return from mktabl
# entfkw and entrkw assume successful entry of elements in those tables, also

   subroutine initkw

   include COMMON_BLOCKS

   ext_func pointer mktabl
   ext_subr dsinit, entdkw, entrkw, entfkw

   call dsinit (MEMSIZE)
   deftbl = mktabl (1)     # symbol table for definitions
   call entdkw
   rkwtbl = mktabl (1)     # symbol table for Ratfor key words
   call entrkw

  ifdef (DO_LONGNAME)
   fkwtbl = mktabl (0)     # symbol table for Fortran key words
   call entfkw
   namtbl = mktabl (1)     # symbol table for long identifiers
   gentbl = mktabl (0)     # symbol table for generated identifiers
  enddef

   label = 23000

   return
   end
#-h- labelc           446  asc  25-mar-82 08:23:28  v1.1 (sw-tools v1.1)
# labelc - output statement number

   subroutine labelc (lexstr)
   character lexstr (ARB)

   include COMMON_BLOCKS

   ext_func integer length
   ext_subr synerr, outstr, outtab

   xfer = NO   # can't suppress goto's now
   if (length (lexstr) == 5)   # warn about 23xxx labels
      if (lexstr (1) == '2' & lexstr (2) == '3')
         call synerr ("warning: possible label conflict.")
   call outstr (lexstr)
   call outtab
   return
   end
#-h- labgen           189  asc  25-mar-82 08:23:28  v1.1 (sw-tools v1.1)
# labgen - generate  n  consecutive labels, return first one

   integer function labgen (n)
   integer n

   include COMMON_BLOCKS

   labgen = label
   label = label + n
   return
   end
#-h- lex              547  asc  25-mar-82 08:23:30  v1.1 (sw-tools v1.1)
# lex - return lexical type of token

   integer function lex (lexstr)
   character lexstr (MAXTOK)

   include COMMON_BLOCKS

   ext_func character gnbtok
   ext_func integer lookup

   for (lex = gnbtok (lexstr, MAXTOK); lex == '@n';
    lex = gnbtok (lexstr, MAXTOK))
      ;
   if (lex == EOF | lex == ';' | lex == '{' | lex == '}')
      return
   if (lex == DIGIT)
      lex = LEXDIGITS
   else if (lex == TOGGLE)
      lex = LEXLITERAL
   else if (lookup (lexstr, lex, rkwtbl) == YES)
      ;
   else
      lex = LEXOTHER

   return
   end
#-h- litral           341  asc  25-mar-82 08:23:31  v1.1 (sw-tools v1.1)
# litral - process literal Fortran line

   subroutine litral

   include COMMON_BLOCKS

   ext_func character ngetch
   ext_subr outdon

   # Finish off any left-over characters
   if (outp > 0)
      call outdon

   for (outp = 1; ngetch (outbuf (outp)) != '@n'; outp = outp + 1)
      ;
   outp = outp - 1
   call outdon
   return
   end
#-h- lndict           784  asc  25-mar-82 08:23:32  v1.1 (sw-tools v1.1)
# lndict - output long-name dictionary as a debugging aid

  ifdef (DO_LONGNAME)
   subroutine lndict

   include COMMON_BLOCKS

   character sym (MAXTOK)
   integer i
   pointer posn, locn

   ext_func character cupper
   ext_func integer sctabl
   ext_subr outch, outtab, outstr, outdon

   posn = 0
   while (sctabl (namtbl, sym, locn, posn) != EOF) {

     ifdef (UPPERC)
      call outch('C')
     elsedef
      call outch('c')
     enddef

      call outtab
      for (i = cvt_to_cptr(locn); cmem (i) != EOS; i = i + 1) {

        ifdef (UPPERC)
         call outch(cupper(cmem(i)))
        elsedef
         call outch(cmem(i))
        enddef

         }
      call outch (' ')
      call outch (' ')
      call outstr (sym)
      call outdon
      }

   return
   end
  enddef
#-h- lodsym           765  asc  25-mar-82 08:23:33  v1.1 (sw-tools v1.1)
 # lodsym - load standard definitions file
 
ifnotdef (DO_BOOTSTRAP)
 subroutine lodsym(fbuf)
 
 include COMMON_BLOCKS
 
 character fbuf(FILENAMESIZE)

 ext_func integer open, loccom
 ext_subr impath, remark, parse, close
 
 string defns STDEFNS		# name of standard definitions file
 string suffix NO_SUFFIX
 
 if (defns(1) != EOS)
   {
   call impath(fnames)		# get standard search path :~home:~usr:~bin
   if (loccom(defns, fnames, suffix, fbuf) == ASCII)
     {
     infile(1) = open(fbuf, READ)
     if (infile(1) == ERR)
       call remark("cannot open standard definitions file.")
     else
       {
       call parse
       call close(infile(1))
       }
     }
   else
     call remark("cannot locate standard definitions file.")
   }
 
 return
 end
enddef
#-h- ngetch           370  asc  25-mar-82 08:23:35  v1.1 (sw-tools v1.1)
# ngetch - get a (possibly pushed back) character

   character function ngetch (c)
   character c

   include COMMON_BLOCKS

   ext_func character getch

   if (bp > 0)
      {
      c = buf(bp)
      bp = bp - 1
      }
   else
      {
      c = getch(c, infile (level) )
      if (c == '@n')
         linect (level) = linect (level) + 1
      }

   return (c)
   end
#-h- otherc           368  asc  25-mar-82 08:23:36  v1.1 (sw-tools v1.1)
# otherc - output ordinary Fortran statement

   subroutine otherc (lexstr)
   character lexstr (ARB)

   include COMMON_BLOCKS

   ext_subr outtab, squash, outstr, eatup, outdon

   xfer = NO
   call outtab

  ifdef (DO_LONGNAME)
   if (IS_LETTER(lexstr (1)))
      call squash (lexstr)
  enddef

   call outstr (lexstr)
   call eatup
   call outdon
   return
   end
#-h- outch            374  asc  25-mar-82 08:23:37  v1.1 (sw-tools v1.1)
# outch - put one character into output buffer

   subroutine outch (c)
   character c

   include COMMON_BLOCKS

   integer i

   ext_subr outdon

   if (outp >= 72) {   # continuation card
      call outdon
      for (i = 1; i < 6; i = i + 1)
         outbuf (i) = ' '
      outbuf (6) = '*'
      outp = 6
      }
   outp = outp + 1
   outbuf (outp) = c
   return
   end
#-h- outcon           376  asc  25-mar-82 08:23:38  v1.1 (sw-tools v1.1)
# outcon - output "n   continue"

   subroutine outcon (n)
   integer n

   include COMMON_BLOCKS

   ext_subr outnum, outtab, outstr, outdon

   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           222  asc  25-mar-82 08:23:38  v1.1 (sw-tools v1.1)
# outdon - finish off an output line

   subroutine outdon

   include COMMON_BLOCKS

   ext_subr putlin

   outbuf (outp + 1) = '@n'
   outbuf (outp + 2) = EOS
   call putlin (outbuf, STDOUT)
   outp = 0
   return
   end
#-h- outgo            283  asc  25-mar-82 08:23:39  v1.1 (sw-tools v1.1)
# outgo - output "goto  n"

   subroutine outgo (n)
   integer n

   include COMMON_BLOCKS

   ext_subr outtab, outstr, outnum, outdon

   string sgoto "goto "

   if (xfer == YES)
      return
   call outtab
   call outstr (sgoto)
   call outnum (n)
   call outdon
   return
   end
#-h- outnum           396  asc  25-mar-82 08:23:39  v1.1 (sw-tools v1.1)
# outnum - output decimal number

   subroutine outnum (n)
   integer n

   character chars (MAXCHARS)
   integer i, m

   ext_subr outch

   m = iabs (n)
   i = 0
   repeat {
      i = i + 1
      chars (i) = mod (m, 10) + '0'
      m = m / 10
      } until (m == 0 | i >= MAXCHARS)
   if (n < 0)
      call outch ('-')
   for ( ; i > 0; i = i - 1)
      call outch (chars (i))
   return
   end
%%D 6
#-h- outstr           985  asc  25-mar-82 08:23:40  v1.1 (sw-tools v1.1)
%%E 6
%%I 6
%%D 10
#-h- outstr          1013  asc  19-oct-82 17:16:10  sventek (joseph sventek)
%%E 10
%%E 6
%%I 10
#-h- outstr          1347  asc  16-dec-81 22:59:16  sventek (joseph sventek)
%%E 10
# outstr - output string; handles quoted literals

   subroutine outstr (str)
   character str (ARB)

   character c
   integer i, j, n

   ext_func character cupper
   ext_func integer length
   ext_subr outch, outnum

%%D 6
   if (str(1) != '"')	# not a quoted string
%%E 6
%%I 6
   if (str(1) != '"' & str(1) != '@'')	# not a quoted string
%%E 6
      for (i=1; str(i) != EOS; i=i+1)
         {
         c = str(i)

         ifdef (UPPERC)
            call outch (cupper(c))
         elsedef
            call outch(c)
         enddef

         }
%%I 10
ifdef(F77_CHARACTER_STRINGS)
   else if (str(1) == '@'')		# dump F77 character string
      {
      call outch('@'')			# output leading '@''
      if (str(2) == '!')		# skip escape
         i = 3
      else
         i = 2
      while (str(i) != EOS)
         {
         call outch(str(i))
         i = i + 1
         }
      }
enddef
%%E 10
   else
      {
      j = length(str)
%%I 6
      c = str(1)
%%E 6
      for ([i=2; n=0]; i < j; i=i+1)
%%D 6
         if (str(i) == '"')
%%E 6
%%I 6
         if (str(i) == c)
%%E 6
            break
         else if (str(i) == '@@')
            {
%%D 6
            if (str(i+1) == '"')
%%E 6
%%I 6
            if (str(i+1) == c)
%%E 6
               i = i + 1
            n = n + 1
            }
         else
            n = n + 1
      call outnum (n)
      call outch('H')
      for (i=2; i < j; i = i + 1)
         {
%%D 6
         if (str(i) == '@@' & str(i+1) == '"')
%%E 6
%%I 6
         if (str(i) == '@@' & str(i+1) == c)
%%E 6
            i = i + 1
         call outch(str(i))
         }
      }
   return
   end
#-h- outtab           157  asc  25-mar-82 08:23:41  v1.1 (sw-tools v1.1)
# outtab - get past column 6

   subroutine outtab

   include COMMON_BLOCKS

   ext_subr outch

   while (outp < 6)
      call outch (' ')
   return
   end
#-h- parse           3035  asc  25-mar-82 08:23:42  v1.1 (sw-tools v1.1)
# parse - parse Ratfor source program

   subroutine parse

   include COMMON_BLOCKS

   character lexstr (MAXTOK)
   integer lab, labval (MAXSTACK), lextyp (MAXSTACK), sp, token, i

   ext_func integer lex
%%D 5
   ext_subr finit, ifcode, docode, whilec, forcod, repcod, selcod, synerr
   ext_subr cascod, labelc, elseif, litral, baderr, selend, otherc, brknxt
%%E 5
%%I 5
   ext_subr finit, ifcode, docode, whilec, forcod, repcod, swcode, synerr
   ext_subr cascod, labelc, elseif, litral, baderr, swend , otherc, brknxt
%%E 5
   ext_subr retcod, strdcl, pbstr, unstak

   call finit
   sp = 1
   lextyp (1) = EOF
   for (token = lex (lexstr); token != EOF; token = lex (lexstr)) {
      if (token == LEXIF)
         call ifcode (lab)
      else if (token == LEXDO)
         call docode (lab)
      else if (token == LEXWHILE)
         call whilec (lab)
      else if (token == LEXFOR)
         call forcod (lab)
      else if (token == LEXREPEAT)
         call repcod (lab)

%%D 5
     ifdef (DO_SELECT)
      else if (token == LEXSELECT)
         call selcod (lab)
%%E 5
%%I 5
     ifdef (DO_SWITCH)
      else if (token == LEXSWITCH)
         call swcode (lab)
%%E 5
      else if (token == LEXCASE | token == LEXDEFAULT) {
%%D 5
         for (i = sp; i > 0; i = i - 1)   # find for most recent select
            if (lextyp (i) == LEXSELECT)
%%E 5
%%I 5
         for (i = sp; i > 0; i = i - 1)   # find for most recent switch
            if (lextyp (i) == LEXSWITCH)
%%E 5
               break
         if (i == 0)
            call synerr ("illegal case or default.")
         else
            call cascod (labval (i), token)
         }
     enddef

      else if (token == LEXDIGITS)
         call labelc (lexstr)
      else if (token == LEXELSE) {
         if (lextyp (sp) == LEXIF)
            call elseif (labval (sp))
         else
            call synerr ("illegal else.")
         }
      else if (token == LEXLITERAL)
         call litral

      if (token == LEXIF | token == LEXELSE | token == LEXWHILE
        | token == LEXFOR | token == LEXREPEAT

%%D 5
       ifdef (DO_SELECT)
        | token == LEXSELECT
%%E 5
%%I 5
       ifdef (DO_SWITCH)
        | token == LEXSWITCH
%%E 5
       enddef

        | token == LEXDO | token == LEXDIGITS | token == '{') {
         sp = sp + 1         # beginning of statement
         if (sp > MAXSTACK)
            call baderr ("stack overflow in parser.")
         lextyp (sp) = token      # stack type and value
         labval (sp) = lab
         }
      else if (token != LEXCASE & token != LEXDEFAULT) {
         if (token == '}') {
            if (lextyp (sp) == '{')
               sp = sp - 1

%%D 5
           ifdef (DO_SELECT)
            else if (lextyp (sp) == LEXSELECT) {
               call selend (labval (sp))
%%E 5
%%I 5
           ifdef (DO_SWITCH)
            else if (lextyp (sp) == LEXSWITCH) {
               call swend  (labval (sp))
%%E 5
               sp = sp - 1
               }
           enddef

            else
               call synerr ("illegal right brace.")
            }
         else if (token == LEXOTHER)
            call otherc (lexstr)
         else if (token == LEXBREAK | token == LEXNEXT)
            call brknxt (sp, lextyp, labval, token)
         else if (token == LEXRETURN)
            call retcod
         else if (token == LEXSTRING)
            call strdcl
         token = lex (lexstr)      # peek at next token
         call pbstr (lexstr)
         call unstak (sp, lextyp, labval, token)
         }
      }

   if (sp != 1)
      call synerr ("unexpected EOF.")
   if (csp > 0)
      call synerr("conditional processing still active at EOF.")

   return
   end
#-h- pbnum            351  asc  25-mar-82 08:23:43  v1.1 (sw-tools v1.1)
# pbnum - convert number to string, push back on input

   subroutine pbnum (n)
   integer n

   integer m, num

   ext_subr putbak

   string digits "0123456789"

   num = abs(n)
   repeat {
      m = mod (num, 10)
      call putbak (digits (m + 1))
      num = num / 10
      } until (num == 0)
   if (n < 0)
      call putbak('-')
   return
   end
#-h- pbstr            236  asc  25-mar-82 08:23:44  v1.1 (sw-tools v1.1)
# pbstr - push string back onto input

   subroutine pbstr (in)
   character in (ARB)

   integer i

   ext_func integer length
   ext_subr putbak

   for (i = length (in); i > 0; i = i - 1)
      call putbak (in (i))

   return
   end
#-h- push             269  asc  25-mar-82 08:23:44  v1.1 (sw-tools v1.1)
# push - push ep onto argstk, return new pointer ap

   integer function push (ep, argstk, ap)
   integer ap, argstk (ARGSIZE), ep

   ext_subr baderr

   if (ap > ARGSIZE)
      call baderr ("arg stack overflow.")
   argstk (ap) = ep
   push = ap + 1
   return
   end
#-h- putbak           280  asc  25-mar-82 08:23:44  v1.1 (sw-tools v1.1)
# putbak - push character back onto input

   subroutine putbak (c)
   character c

   include COMMON_BLOCKS

   ext_subr baderr

   if (bp >= BUFSIZE)
      call baderr ("too many characters pushed back.")
   else {
      bp = bp + 1
      buf (bp) = c
      }

   return
   end
#-h- putchr           253  asc  25-mar-82 08:23:45  v1.1 (sw-tools v1.1)
# putchr - put single char into eval stack

   subroutine putchr (c)
   character c

   include COMMON_BLOCKS

   ext_subr baderr

   if (ep > EVALSIZE)
      call baderr ("evaluation stack overflow.")
   evalst (ep) = c
   ep = ep + 1
   return
   end
#-h- puttok           219  asc  25-mar-82 08:23:45  v1.1 (sw-tools v1.1)
# puttok-put token into eval stack

    subroutine puttok (str)
    character str (MAXTOK)

    integer i

    ext_subr putchr

    for (i = 1; str (i) != EOS; i = i + 1)
       call putchr (str (i))
    return
    end
#-h- relate          1261  asc  25-mar-82 08:23:46  v1.1 (sw-tools v1.1)
# relate - convert relational shorthands into long form

   subroutine relate (token, last)
   character token (ARB)
   integer last

   ext_func character ngetch
   ext_func integer length
   ext_subr putbak

   if (ngetch (token (2)) != '=') {
      call putbak (token (2))
      token (3) = 't'
      }
   else
      token (3) = 'e'
   token (4) = '.'
   token (5) = EOS
   token (6) = EOS # for .not. and .and.
   if (token (1) == '>')
      token (2) = 'g'
   else if (token (1) == '<')
      token (2) = 'l'
   else if (token (1) == NOT | token(1) == '!' |
            token(1) == '~' | token(1) == '^') {
      if (token (2) != '=') {
         token (3) = 'o'
         token (4) = 't'
         token (5) = '.'
         }
      token (2) = 'n'
      }
   else if (token (1) == '=') {
      if (token (2) != '=') {
         token (2) = EOS
         last = 1
         return
         }
      token (2) = 'e'
      token (3) = 'q'
      }
   else if (token (1) == AND) {
      token (2) = 'a'
      token (3) = 'n'
      token (4) = 'd'
      token (5) = '.'
      }
   else if (token (1) == OR) {
      token (2) = 'o'
      token (3) = 'r'
      }
   else   # can't happen
      token (2) = EOS
   token (1) = '.'
   last = length (token)
   return
   end
#-h- repcod           290  asc  25-mar-82 08:23:47  v1.1 (sw-tools v1.1)
# repcod - generate code for beginning of repeat

   subroutine repcod (lab)
   integer lab

   ext_func integer labgen
   ext_subr outcon

   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           674  asc  25-mar-82 08:23:47  v1.1 (sw-tools v1.1)
# retcod - generate code for return

   subroutine retcod

   include COMMON_BLOCKS

   character t

   ext_func character gnbtok
   ext_subr pbstr, outtab, scopy, squash, outstr, outch, eatup, outdon

   string sret "return"

   t = gnbtok (scrtok, MAXTOK)
   if (t != '@n' & t != ';' & t != '}') {
      call pbstr (scrtok)
      call outtab
      call scopy (fcname, 1, scrtok, 1)

     ifdef (DO_LONGNAME)
      call squash (scrtok)
     enddef

      call outstr (scrtok)
      call outch ('=')
      call eatup
      call outdon
      }
   else if (t == '}')
      call pbstr (scrtok)
   call outtab
   call outstr (sret)
   call outdon
   xfer = YES
   return
   end
%%D 5
#-h- selcod           839  asc  25-mar-82 08:23:48  v1.1 (sw-tools v1.1)
# selcod - generate code for beginning of select statement

  ifdef (DO_SELECT)
   subroutine selcod (lab)
   integer lab

   include COMMON_BLOCKS


   ext_func integer labgen, gnbtok
   ext_subr baderr, outtab, selvar, outch, balpar, outdon, outgo, synerr, pbstr

   lab = labgen (2)
   if (selast + 3 > MAXSELECT)
      call baderr ("select table overflow.")
   sestak (selast) = setop
   sestak (selast + 1) = 0
   sestak (selast + 2) = 0
   setop = selast
   selast = selast + 3
   xfer = NO
   call outtab  # Innn=(e)
   call selvar (lab)
   call outch ('=')
   call balpar
   call outdon
   call outgo (lab) # goto L
   xfer = YES
   while (gnbtok (scrtok, MAXTOK) == '@n')
      ;
   if (scrtok (1) != '{') {
      call synerr ("missing left brace in select statement.")
      call pbstr (scrtok)
      }
   return
   end
  enddef
#-h- selend          2799  asc  25-mar-82 08:23:49  v1.1 (sw-tools v1.1)
# selend - finish off select statement; generate dispatch code

  ifdef (DO_SELECT)
   subroutine selend (lab)
   integer lab

   include COMMON_BLOCKS

   integer lb, ub, n, i, j

   ext_subr outgo, outcon, outtab, selvar, outch, outnum, outdon

   string sif "if ("
   string slt ".lt.1.or."
   string sgt ".gt."
   string sgoto "goto ("
   string seq ".eq."
   string sge ".ge."
   string sle ".le."
   string sand ".and."

   lb = sestak (setop + 3)
   ub = sestak (selast - 2)
   n = sestak (setop + 1)
   call outgo (lab + 1) # terminate last case
   if (sestak (setop + 2) == 0)
      sestak (setop + 2) = lab + 1  # default default label
   xfer = NO
   call outcon (lab)  # L   continue
   if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table
      if (lb != 1) {  # L  Innn=Innn-lb+1
         call outtab
         call selvar (lab)
         call outch ('=')
         call selvar (lab)
         if (lb < 1)
            call outch ('+')
         call outnum (-lb + 1)
         call outdon
         }
      call outtab  #  if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default
      call outstr (sif)
      call selvar (lab)
      call outstr (slt)
      call selvar (lab)
      call outstr (sgt)
      call outnum (ub - lb + 1)
      call outch (')')
      call outgo (sestak (setop + 2))
      call outtab  #  goto (....),Innn
      call outstr (sgoto)
      j = lb
      for (i = setop + 3; i < selast; i = i + 3) {
         for ( ; j < sestak (i); j = j + 1) { # fill in vacancies
            call outnum (sestak (setop + 2))
            call outch (',')
            }
         for (j = sestak (i + 1) - sestak (i); j >= 0; j = j - 1)
            call outnum (sestak (i + 2)) # fill in range
         j = sestak (i + 1) + 1
         if (i < selast - 3)
            call outch (',')
         }
      call outch (')')
      call outch (',')
      call selvar (lab)
      call outdon
      }
   else if (n > 0) {  # output linear search form
      for (i = setop + 3; i < selast; i = i + 3) {
         call outtab  # if (Innn
         call outstr (sif)
         call selvar (lab)
         if (sestak (i) == sestak (i+1)) {
            call outstr (seq) #   .eq....
            call outnum (sestak (i))
            }
         else {
            call outstr (sge) #   .ge.lb.and.Innn.le.ub
            call outnum (sestak (i))
            call outstr (sand)
            call selvar (lab)
            call outstr (sle)
            call outnum (sestak (i + 1))
            }
         call outch (')') #    ) goto ...
         call outgo (sestak (i + 2))
         }
      if (lab + 1 != sestak (setop + 2))
         call outgo (sestak (setop + 2))
      }
   call outcon (lab + 1)   # L+1  continue
   selast = setop # pop select stack
   setop = sestak (setop)
   return
   end
  enddef
#-h- selvar           214  asc  25-mar-82 08:23:52  v1.1 (sw-tools v1.1)
# selvar - output select variable Innn, where nnn = lab

  ifdef (DO_SELECT)
   subroutine selvar (lab)
   integer lab

   ext_subr outch, outnum

   call outch ('I')
   call outnum (lab)
   return
   end
  enddef
%%E 5
#-h- skpblk           275  asc  25-mar-82 08:23:53  v1.1 (sw-tools v1.1)
# skpblk - skip blanks and tabs in current input file

   subroutine skpblk

   include COMMON_BLOCKS

   character c

   ext_func character ngetch
   ext_subr putbak

   for (c = ngetch (c); c == ' ' | c == '@t'; c = ngetch (c))
      ;

   call putbak (c)
   return
   end
#-h- squash          1589  asc  25-mar-82 08:23:55  v1.1 (sw-tools v1.1)
# squash - convert a long or special identifier into a Fortran variable

  ifdef (DO_LONGNAME)
   subroutine squash (id)
   character id (MAXTOK)

   include COMMON_BLOCKS

   integer junk, i, j
   character newid (MAXTOK), recdid (MAXTOK)

   ext_func integer lookup
   ext_subr scopy, uniqid, entdef

   j = 1
   for (i = 1; id (i) != EOS; i = i + 1)
      if (IS_LETTER(id (i)) | IS_DIGIT(id (i))) {
         newid (j) = id (i)
         j = j + 1
         }
   newid (j) = EOS

   if (i - 1 < MAXIDLENGTH & i == j)
      return      # an ordinary (short) Fortran variable
   if (i - 1 == MAXIDLENGTH & i == j)
      if (id (MAXIDLENGTH) != FILLCHAR)
         return   # a 6-character variable, but no possible conflict

   # Otherwise, the identifier (1) is longer than Fortran allows,
   #  (2) contains special characters (_ or .), or (3) is exactly
   #  MAXIDLENGTH characters long and ends with the "fill character."
   #  The first two cases obviously call for name conversion; the last
   #  case requires conversion to avoid accidental conflicts with
   #  automatically generated names.

   if (lookup (id, junk, fkwtbl) == YES)  # Fortran key word?
      return                              # (must be treated as reserved)

   if (ludef (id, recdid, namtbl) == YES) {   # have we seen this before?
      call scopy (recdid, 1, id, 1)
      return
      }

   call uniqid (newid)  # get an identifier never before seen
   call entdef (id, newid, namtbl)  # record it for posterity
   call scopy (newid, 1, id, 1)  # and substitute it for the old one

   return
   end
  enddef
%%D 6
#-h- strdcl          2711  asc  25-mar-82 08:23:59  v1.1 (sw-tools v1.1)
%%E 6
%%I 6
#-h- strdcl          2712  asc  19-oct-82 17:20:08  sventek (joseph sventek)
%%E 6
# strdcl - generate code for string declaration

   subroutine strdcl

   include COMMON_BLOCKS

   character t, dchar (MAXTOK)
   integer i, j, k, n, len

   ext_func character gnbtok, esc
   ext_func integer length, ctoi, lex, elenth
   ext_subr synerr, squash, outtab, pbstr, outstr, outch, addstr, addchr
   ext_subr outnum, outdon

   string char "character/"
   string dat "data "
   string eoss "EOS/"

   t = gnbtok (scrtok, MAXTOK)
   if (t != ALPHA)
%%D 6
      call synerr ("missing string scrtok.")
%%E 6
%%I 6
      call synerr ("missing string token.")
%%E 6

  ifdef (DO_LONGNAME)
   call squash (scrtok)
  enddef

   call outtab
   call pbstr (char) # use defined meaning of "character"
   repeat {
      t = gnbtok (dchar, MAXTOK)
      if (t == '/')
         break
      call outstr (dchar)
      }
   call outch (' ')  # separator in declaration
   call outstr (scrtok)
   call addstr (scrtok, sbuf, sbp, SBUFSIZE)  # save for later
   call addchr (EOS, sbuf, sbp, SBUFSIZE)
   if (gnbtok (scrtok, MAXTOK) != '(') {  # make size same as initial value
      len = elenth (scrtok) + 1
%%D 6
      if (scrtok (1) == ''' | scrtok (1) == '"')
%%E 6
%%I 6
      if (scrtok (1) == '@'' | scrtok (1) == '"')
%%E 6
         len = len - 2
      }
   else { # form is string name (size) init
      t = gnbtok (scrtok, MAXTOK)
      i = 1
      len = ctoi (scrtok, i)
      if (scrtok (i) != EOS)
         call synerr ("invalid string size.")
      if (gnbtok (scrtok, MAXTOK) != ')')
         call synerr ("missing right paren.")
      else
         t = gnbtok (scrtok, MAXTOK)
      }
   call outch ('(')
   call outnum (len)
   call outch (')')
   call outdon
%%D 6
   if (scrtok (1) == ''' | scrtok (1) == '"') {
%%E 6
%%I 6
   if (scrtok (1) == '@'' | scrtok (1) == '"') {
%%E 6
      len = length (scrtok)
      scrtok (len) = EOS
      call addstr (scrtok (2), sbuf, sbp, SBUFSIZE)
      }
   else
      call addstr (scrtok, sbuf, sbp, SBUFSIZE)
   call addchr (EOS, sbuf, sbp, SBUFSIZE)
   t = lex (scrtok)   # peek at next scrtok
   call pbstr (scrtok)
   if (t != LEXSTRING) {   # dump accumulated data statements
      for (i = 1; i < sbp; i = j + 1) {
         call outtab
         call outstr (dat)
         k = 1
         for (j = i + length (sbuf (i)) + 1; ; j = j + 1) {
            if (k > 1)
               call outch (',')
            call outstr (sbuf (i))
            call outch ('(')
            call outnum (k)
            call outch (')')
            call outch ('/')
            if (sbuf (j) == EOS)
               break
            n = esc (sbuf, j)
            call outnum (n)
            call outch ('/')
            k = k + 1
            }
         call pbstr (eoss) # use defined meaning of EOS
         repeat {
            t = gnbtok (scrtok, MAXTOK)
            call outstr (scrtok)
            } until (t == '/')
         call outdon
         }
      sbp = 1
      }

   return
   end
%%I 5
#-h- swcode           839  asc  25-mar-82 08:23:48  v1.1 (sw-tools v1.1)
# swcode - generate code for beginning of switch statement

  ifdef (DO_SWITCH)
   subroutine swcode (lab)
   integer lab

   include COMMON_BLOCKS


   ext_func integer labgen, gnbtok
   ext_subr baderr, outtab, swvar , outch, balpar, outdon, outgo, synerr, pbstr

   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 ('=')
   call balpar
   call outdon
   call outgo (lab) # goto L
   xfer = YES
   while (gnbtok (scrtok, MAXTOK) == '@n')
      ;
   if (scrtok (1) != '{') {
      call synerr ("missing left brace in switch statement.")
      call pbstr (scrtok)
      }
   return
   end
  enddef
#-h- swend           2799  asc  25-mar-82 08:23:49  v1.1 (sw-tools v1.1)
# swend  - finish off switch statement; generate dispatch code

  ifdef (DO_SWITCH)
   subroutine swend  (lab)
   integer lab

   include COMMON_BLOCKS

   integer lb, ub, n, i, j

   ext_subr outgo, outcon, outtab, swvar , outch, outnum, outdon

   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 ('=')
         call swvar  (lab)
         if (lb < 1)
            call outch ('+')
         call outnum (-lb + 1)
         call outdon
         }
      call outtab  #  if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default
      call outstr (sif)
      call swvar  (lab)
      call outstr (slt)
      call swvar  (lab)
      call outstr (sgt)
      call outnum (ub - lb + 1)
      call outch (')')
      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 (',')
            }
         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 (',')
         }
      call outch (')')
      call outch (',')
      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 (')') #    ) 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
  enddef
#-h- swvar            214  asc  25-mar-82 08:23:52  v1.1 (sw-tools v1.1)
# swvar  - output switch variable Innn, where nnn = lab

  ifdef (DO_SWITCH)
   subroutine swvar  (lab)
   integer lab

   ext_subr outch, outnum

   call outch ('I')
   call outnum (lab)
   return
   end
  enddef
%%E 5
#-h- synerr           742  asc  25-mar-82 08:24:02  v1.1 (sw-tools v1.1)
# synerr --- report non-fatal error

   subroutine synerr (msg)
   character msg (ARB)

   include COMMON_BLOCKS

   character lc (MAXCHARS)
   integer i, junk

   ext_func integer itoc
   ext_subr putlin, putch, remark

   string in " in "
   string errmsg "error at line "

   call putlin (errmsg, ERROUT)
   if (level >= 1)
      i = level
   else
      i = 1 # for EOF errors
   junk = itoc (linect (i), lc, MAXCHARS)
   call putlin (lc, ERROUT)
   for (i = fnamp - 1; i > 1; i = i - 1)
      if (fnames (i - 1) == EOS) {  # print file name
         call putlin (in, ERROUT)
         call putlin (fnames (i), ERROUT)
         break
         }

   call putch (':', ERROUT)
   call putch (' ', ERROUT)
   call remark (msg)
   return
   end
#-h- ulstal           295  asc  25-mar-82 08:24:03  v1.1 (sw-tools v1.1)
# ulstal - install lower and upper case versions of symbol

   subroutine ulstal (name, defn)
   character name (ARB), defn (ARB)

   include COMMON_BLOCKS

   ext_subr entdef, upper

   call entdef (name, defn, deftbl)
   call upper (name)
   call entdef (name, defn, deftbl)

   return
   end
#-h- uniqid          1971  asc  25-mar-82 08:24:05  v1.1 (sw-tools v1.1)
# uniqid - convert an identifier to one never before seen

  ifdef (DO_LONGNAME)
   subroutine uniqid (id)
   character id (MAXTOK)

   include COMMON_BLOCKS

   integer i, j, junk, idchl, carry
   character start (MAXIDLENGTH)

   ext_func integer lookup, index, length, enter
   ext_subr baderr, synerr

   string idch "0123456789abcdefghijklmnopqrstuvwxyz" # legal id characters

   # Pad the identifer out to length 6 with FILLCHARs:
   for (i = 1; id (i) != EOS; i = i + 1)
      ;
   for (; i <= MAXIDLENGTH; i = i + 1)
      id (i) = FILLCHAR
   i = MAXIDLENGTH + 1
   id (i) = EOS
   id (i - 1) = FILLCHAR

   # Look it up in the table of generated names.  If it's not there,
   #  it's unique.  If it is there, it has been generated previously;
   #  modify it and try again.  Assume this procedure always succeeds,
   #  since to fail implies there are very, very many identifiers in
   #  the symbol table.
   #  Note that we must preserve the first and last characters of the
   #  id, so as not to disturb implicit typing and to provide a flag
   #  to catch potentially conflicting user-defined identifiers without
   #  a lookup.

   if (lookup (id, junk, gentbl) == YES) {   # (not very likely)
      idchl = length (idch)
      for (i = 2; i < MAXIDLENGTH; i = i + 1)
         start (i) = id (i)
      repeat {    # until we get a unique id
         for (i = arith(MAXIDLENGTH,-,1); i > 1; i = i - 1) {
            j = mod (index (idch, id (i)), idchl) + 1
            id (i) = idch (j)
            if (id (i) != start (i))
               break
            }
         if (i == 1)
            call baderr ("cannot make identifier unique.")
         } until (lookup (id, junk, gentbl) == NO)
      }

   # At this point, 'id' contains a unique identifier, not previously
   #  seen in this compilation.  Save it for future reference.
   if (enter (id, 0, gentbl) == ERR)
      call synerr("No room for generated variable name.")

   return
   end
  enddef
#-h- unstak           963  asc  25-mar-82 08:24:08  v1.1 (sw-tools v1.1)
# unstak - unstack at end of statement

   subroutine unstak (sp, lextyp, labval, token)

   integer labval (MAXSTACK), lextyp (MAXSTACK), sp, token

   ext_subr outcon, dostat, whiles, fors, untils

   for ( ; sp > 1; sp = sp - 1) {
      if (lextyp (sp) == '{')
         break

%%D 5
     ifdef (DO_SELECT)
      if (lextyp (sp) == LEXSELECT)
%%E 5
%%I 5
     ifdef (DO_SWITCH)
      if (lextyp (sp) == LEXSWITCH)
%%E 5
         break
     enddef

      if (lextyp (sp) == LEXIF & token == LEXELSE)
         break
      if (lextyp (sp) == LEXIF)
         call outcon (labval (sp))
      else if (lextyp (sp) == LEXELSE) {
         if (sp > 2)
            sp = sp - 1
         call outcon (labval (sp) + 1)
         }
      else if (lextyp (sp) == LEXDO)
         call dostat (labval (sp))
      else if (lextyp (sp) == LEXWHILE)
         call whiles (labval (sp))
      else if (lextyp (sp) == LEXFOR)
         call fors (labval (sp))
      else if (lextyp (sp) == LEXREPEAT)
         call untils (labval (sp), token)
      }

   return
   end
#-h- untils           446  asc  25-mar-82 08:24:09  v1.1 (sw-tools v1.1)
# untils - generate code for until or end of repeat

   subroutine untils (lab, token)
   integer lab, token

   include COMMON_BLOCKS

   character ptoken (MAXTOK)
   integer junk

   ext_func integer lex
   ext_subr outnum, ifgo, outgo, outcon

   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           304  asc  25-mar-82 08:24:10  v1.1 (sw-tools v1.1)
# whilec - generate code for beginning of while

   subroutine whilec (lab)
   integer lab

   ext_func integer labgen
   ext_subr outcon, outnum, ifgo

   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           175  asc  25-mar-82 08:24:12  v1.1 (sw-tools v1.1)
# whiles - generate code for end of while

   subroutine whiles (lab)
   integer lab

   ext_subr outgo, outcon

   call outgo (lab)
   call outcon (lab + 1)
   return
   end
%%D 5
#-h- ratfor.fmt     17177  asc  25-mar-82 08:27:52  v1.1 (sw-tools v1.1)
%%E 5
%%I 5
%%D 8
#-h- ratfor.fmt     17193  asc  18-oct-82 13:13:28  sventek (joseph sventek)
%%E 8
%%E 5
%%I 8
%%D 10
#-h- ratfor.fmt     17379  asc  14-dec-82 16:01:01  sventek (joseph sventek)
%%E 10
%%E 8
%%I 10
#-h- ratarg           454  asc  17-dec-81 00:10:24  sventek (joseph sventek)
# ratarg - routine to crack command line flags to ratfor
subroutine ratarg

integer i
ext_func integer getarg

include COMMON_BLOCKS

dosym = YES					# load "symbols" by default
for (i = 1; getarg(i, scrtok, MAXTOK) != EOF; i = i + 1)
  if (scrtok(1) == '-' & scrtok(2) != EOS)	# found a flag
    {
    select (scrtok(2))
      {
      case 'n', 'N':	dosym = NO		# user does not want symbols
      default:		;			# ignore others
      }
    }

return
end
#-h- ratfor.fmt     17425  asc  17-dec-81 00:27:41  sventek (joseph sventek)
%%E 10
.so ~bin/manhdr
.hd Ratfor (1) 21-Dec-81
RatFor preprocessor
.sy
%%D 10
ratfor [file] ... >outfile
%%E 10
%%I 10
ratfor [-n] [file] ... >outfile
%%E 10
.ds
Ratfor translates the ratfor programs in the named files into Fortran.
If no input files are given, or the filename '-' appears, the
standard input will be read.

%%D 10
A file containing general purpose software tools definitions
%%E 10
%%I 10
Unless the '-n' flag has been specified, a file containing
general purpose software tools definitions
%%E 10
(e.g. EOF, EOS, etc.) will be automatically opened and
processed before any of the files specified are read.
.sp 2
Syntax:

Ratfor has the following syntax:
.nf
           prog:   stmt
                   prog stmt
           stmt:   if (expr) stmt
                   if (expr) stmt else stmt
                   while (expr) stmt
                   repeat (expr) stmt
                   repeat stmt until (expr)
                   for (init clause; test expr; incr clause) stmt
                   do expr stmt
                   do n expr stmt
                   break
                   break n
                   next
                   next n
                   return (expr)
%%D 5
                   select (expr)
%%E 5
%%I 5
                   switch (expr) | select (expr)
%%E 5
                   {
                     case expr: stmt
                     ...
                     default: stmt
                   }
                   digits stmt
                   { prog }  or  [ prog ]
                   other
           other:  anything unrecognizable (i.e. fortran)
           clause: other
                   {mother} or [mother]
           mother: other
                   other; mother

.fi
where 'stmt' is any Fortran or Ratfor statement.
A statement is terminated by an end-of-line or a semicolon.
.sp
.ne 13
Character Translation:
.sp
The following character translations are performed:
.in +5
.nf
<       .lt.
<=      .le.
==      .eq.
!=      .ne.         ^=      .ne.         ~=      .ne.
>=      .ge.
>       .gt.
|       .or.
&       .and.
!       .not.        ^       .not.        ~       .not.
.in -5
.fi
.sp 2
Included files:

.fi
The statement

.in +15
.nf
include file        or
include "file"
.in -15

.fi
will insert the contents of the specified file into the ratfor input
in place of the 'include' statement.
Quotes must surround the file name if it contains characters other
than alphanumerics or underscores.
.sp 2
Macro Definitions:

The statement

.ti +15
define(name,replacement text)

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

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

will cause the source line

.ti +15
bump(i)

to be expanded into

.ti +15
i = i + 1

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

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

(For compatibility, an "mdefine" macro call has been included
which interprets definitions before stacking them, as does the
macro tool.
When using this version, use "$(" and "$)" to indicate deferred
evaluation, rather than the "[" and "]" used by the macro tool.)

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

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

Note: the statement

.ti +15
define name text

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


.ne 9
Conditional Preprocessing:

The statements

.in +10
.nf
ifdef(macro)                      ifnotdef(macro)
.in +6
.cc *
.                                   .
.                                   .
.                                   .
*ti -6
elsedef                           elsedef
.                                   .
.                                   .
.                                   .
*cc .
.in -6
enddef                            enddef
.in -10
.fi

conditionalize the preprocessing upon whether the macro has been previously
defined or not.
The `elsedef' portions of the conditionals may be omitted, if desired.
The conditional bodies may be nested, up to 10 levels deep.
.br


String Data Types:

The statements

.in +10
string name "character string"          or
.br
string name(size) "character string"

.in -10
declare 'name' to be a character array long enough to accomodate
the ascii codes for the given character string, one per array
element.
The array is then filled by data statements.
The last word of 'name' is initialized to the symbolic parameter
EOS, and indicates the end of a string.
EOS must be defined either in the standard definitions file or
by the user.
If a size is given, name is declared to be a character array
of 'size' elements.
If several string declarations appear consecutively, the
generated declarations for the arrays will precede the data
statements that initialize them.
The normal escape sequences are supported in strings; in addition, to
embed a quote (") in the 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
         (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.
If a quote (") is to be embedded in an hollerith string, one must type,
for example, "@"" ==> 1h".
.sp 2
Character Literals:

Character constants of the form 'c' are converted to the decimal
integer representation of that character in the ASCII character
set.  For example:

.in +5
.nf
call putc('!')

.ti -5
would become

call putc(33)
.in -5
.fi
.sp
The normal escape characters are supported as character constants.
For example
.sp
.ti +5
'@n'
.sp
is a NEWLINE (10).
%%I 8
.sp
For compatibility with previous releases of the pre-processor, apostrophes
may also be used to delimit string literals, as described above, if they
are longer than one character.
%%E 8
.sp 2
Integer Constants:

Integer constants in bases other than decimal may be specified
as n%dddd... where 'n' is a decimal number indicating
the base and 'dddd...' are digits in that base.
For bases > 10, letters are used for digits above 9.
Examples include:  8%77 (=63), 16%2ff (=767), 2%0010011 (=19).
The number is converted to the equivalent decimal value using
multiplication; this may cause sign problems if the number has
too many digits.
.sp 2
Lines and Continuation:

.fi
Input is free-format; that is, statements may appear anywhere
on a line,
and the end of the line is generally considered the end of the statement.
However,
lines ending in special characters such as comma, +, -,
and * are assumed to be continued on the next line.
An exception to this rule is within a condition; the line
is assumed to be continued if the condition does not fit on one line.
Explicit continuation is indicated by ending a line with an
underline character (_).
The underline character is not copied to the output file.
.sp 2
Comments:

Comments are preceded by '#' signs and may appear anywhere in
the code.
.sp 2
Literal (unprocessed) Lines:

Lines can be passed through ratfor without being processed by
putting a percent "%" as the first character on the line.
The percent will be removed and the line shifted one position to the
left, but otherwise will be output without change.
Macro invocations, long names, etc., appearing in the line will not
be processed.
.sp 4
.ne 4
.ti -4
CHANGES
.br
This ratfor preprocessor differs from the original (as released
by Kernighan and Plauger) in the following ways:

The code has been rewritten and reorganized.

Hash tables have been added for increased efficiency in searching
for macro definitions and Ratfor keywords.

The 'string' declaration has been included.

The define processor has been augmented to support macros with arguments.

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

Many extraneous gotos have been avoided.

Blanks have been included in the output for increased readability.

Multi-level 'break' and 'next' statements have been included.

The Fortran 'DO' is allowed, as well as the ratfor one.

The capability of specifying integer constants in bases other than
decimal has been added.

Underscores have been allowed in names.

The 'define' syntax has been expanded to include the form:
define name value

The 'return(value)' feature has been added.

Quoted file names following 'include' statements have been added
to allow for special characters in file names.

A method for allowing lines to pass through un-processed has been added.

Continuation lines have been implemented.

Brackets have been allowed to replace braces
(but NOT $( and $) )

Character constants are now supported.

Groups of FORTRAN statements are permitted in the init and re-init
clauses of the for statement.

.fl
A generalized definition file (e.g. 'symbols') is automatically
opened and read.
.sa
.nf
Kernighan and Plauger's "Software Tools"
Kernighan's "RATFOR - A Preprocessor for a Rational Fortran"
The Unix command rc in the Unix Manual
The tools 'incl' and 'macro'
.fi
.di
(The errors marked with asterisk '*' are fatal; all others are simply
warning messages.)
.sp 1
.in +5
.ti -5
* arg stack overflow
.br
The argument stack for the macro processor has been exceeded.  The size of the
stack is determined by the symbol ARGSIZE in the source definitions file.
.br
.ti -5
* buffer overflow
.br
One of the preprocessor's internal buffers overflowed,
possibly, but not necessarily, because the string buffers
were exceeded.
The definition SBUFSIZE in the preprocessor symbols file
determines the size
of the string buffers.
.br
.ti -5
* call stack overflow
.br
The call stack (used to store call frames) in the macro processor has
been exceeded.
The definition CALLSIZE in the source definition file determines the
size of this stack.
.br
.ti -5
can't open standard definitions file
.br
The special file containing general purpose ratfor definitions
could not be opened, possibly because it did not exist or the
user did not have access to the directory on which it resides.
.br
.ti -5
can't open include
.br
File to be included could not be located,
the user did not have privilege to access it,
or the file could not be opened due to some problem in the
local primitives.
.br
.ti -5
* definition too long
.br
The number of characters in the name to be defined exceeded
Ratfor's internal array size.
The size is defined by the MAXTOK definition in the preprocessor
symbols file.
.br
.ti -5
* EOF in string
.br
The macro processor detected an EOF in the current input file while
evaluating a macro.
.ti -5
* evaluation stack overflow
.br
The evaluation stack for the macro processor has been exceeded.
This stack's size is determined by the symbol EVALSIZE in the
source definition file.
.br
.ti -5
* for clause too long
.br
The internal buffer used to hold the clauses for the 'for'
statement was exceeded.
Size of this buffer is determined by the MAXFORSTK definition
in the preprocessor symbols file.
.br
.ti -5
* getdef is confused
.br
There were horrendous problems when attempting to access
the definition table
.br
.ti -5
illegal break
.br
Break did not occur inside a valid "while", "for", or "repeat" loop
.br
.ti -5
illegal else
.br
Else clause probably did not follow an "if" clause
.br
.ti -5
illegal next
.br
"Next" did not occur inside a valid "for", "while", or "repeat" loop
.br
.ti -5
illegal right brace
.br
A right brace was found without a matching left brace
.br
.ti -5
* in dsget:  out of dynamic storage space
.br
There is insufficient memory for macro definitions,
etc.
Increase the MEMSIZE definition in the preprocessor.
.br
.ti -5
includes nested too deeply
.br
There is a limit to the level of nesting of included files.
It is dependent upon the maximum number of opened files allowed
at a time,
and is set by the
NFILES definition in the preprocessor symbols file.
.br
.ti -5
invalid for clause
.br
The "for" clause did not contain a valid init, condition, and/or
increment section
.ti -5
invalid string size
.br
The string format 'string name(size) "..."' was used, but the
size was given improperly.
.br
.ti -5
* missing comma in define
.br
Definitions of the form 'define(name,defn)' must include the
comma as a separator.
.br
.br
.ti -5
missing function name
.br
There was an error in declaring a function
.br
.ti -5
missing left paren
.br
A parenthesis was expected, probably in an "if" statement, but
not found
.br
.ti -5
missing parenthesis in condition
.br
A right parenthesis was expected, probably in an "if" statement,
but not found
.br
.ti -5
missing quote
.br
A quoted string was not terminated by a quote
.br
.ti -5
missing right paren
.br
A right parenthesis was expected in a Fortran (as opposed to
Ratfor) statement but not found
.br
.ti -5
missing string token
.br
No array name was given when declaring a string variable
.br
.ti -5
* non-alphanumeric name
.br
Definitions may contain only alphanumeric characters
and underscores.
.br
.ti -5
* stack overflow in parser
.br
Statements were nested at too deep a level.
The stack depth is set by the MAXSTACK definition in the
preprocessor symbols file.
.br
.ti -5
token too long
.br
A token (word) in the source code was too long to fit into one
of Ratfor's internal arrays.
The maximum size is set by the MAXTOK definition in the
preprocessor symbols file.
.br
.ti -5
* too many characters pushed back
.br
The source code has illegally specified a Ratfor command, or has
used a Ratfor keyword in an illegal manner, and the parser has
attempted but failed to make sense out of it.
The size of the push-back buffer is set by BUFSIZE in the
preprocessor symbols file.
.br
.ti -5
unbalanced parentheses
.br
Unbalanced parentheses detected in a Fortran (as opposed
to Ratfor) statement
.br
.ti -5
unexpected brace or EOF
.br
A brace occurred after a Fortran (but not Ratfor) statement
or an end-of-file was reached before the end of a statement
.br
.ti -5
unexpected EOF
.br
An end-of-file was reached before all braces had been
accounted for.  This is usually caused by unmatched braces
somewhere deep in the source code.
.br
.ti -5
warning:  possible label conflict
.br
This message is printed when the user has labeled a statement
with a label in the 23000-23999 range.  Ratfor statements are
assigned in this range and a user-defined one may conflict
with a Ratfor-generated one.
.br
.ne 3
.ti -5
"file":  cannot open
.br
Ratfor could not open an input file specified by the user
on the command line.
.br
.in -5
.au
Original by B. Kernighan and P. J. Plauger, with rewrites and
enhancements by David Hanson and friends (U. of Arizona),
Joe Sventek and Debbie Scherrer (Lawrence Berkeley Laboratory),
and Allen Akin (Georgia Institute of Technology).
.bu
Missing parentheses or braces may cause erratic behavior.
Eventually  Ratfor should be taught
to terminate parenthesis/brace checking at the end of each subroutine.
.sp
Although one bug was fixed which caused line numbers in error
messages to be incorrect, they still aren't quite right.
(newlines in macro text are difficult to handle properly).
Use them only as a general area in which to look for errors.
.sp
Extraneous 'continue' statements are generated within Fortran
'do' statements.
The 'next' statement does not work properly when used within Fortran
'do' statements.
.sp
There is no way to explicitly cause a statement to begin in column 6
(i.e. a Fortran continued statement),
although implicit continuation is performed.
.sp
Ratfor is very slow, principally in the lexical analysis,
character input, and macro processing routines (in that order).
Attempts to speed it up should concentrate on the routines 'gtok',
'ngetch', and 'deftok'.
An even better approach would be to re-work the lexical analyzer and
parser completely.
%%E 1