%%s 1/27/4507
%%d D 1.17 02-Aug-83 22:16:47 tools 17 16
%%c Removed routine alldig, since it is in the library.
%%s 35/28/4499
%%d D 1.16 28-Jul-83 21:23:35 tools 16 15
%%c Changed routine names from addstr/addchr to insstr/inschr to avoid collision
%%c with standard routines in library.  Also fixed up domac to reflect the
%%c conditional nature of IS_LETTER.
%%s 28/28/4499
%%d D 1.15 21-Jul-83 17:47:39 sventek 15 14
%%c Modified insdcl, gtok, outstr and strdcl to fix a problem with finding
%%c the appropriate delimiter before dumping the declaration.
%%c 
%%c Also placed a check in domac to see if the first character of the
%%c first parameter to mdefine is a letter.  While not an absolute check
%%c for the ALPHA-ness of the token, it should catch those situations
%%c reported by RTSG in their testing.
%%s 107/107/4420
%%d D 1.14 15-Jun-83 17:02:54 sventek 14 13
%%c Removed trailing periods from quoted strings, as they are no longer needed.
%%s 821/231/3706
%%d D 1.13 13-May-83 15:54:58 sventek 13 12
%%c Final modifications resulting in beta test distribution of processor.
%%c 
%%c 1. hollerith builtin was removed.  Dumb to suggest it anyway.
%%c 
%%c 2. Bill Meine's suggestion for forcing literal character sequences was
%%c    implemented - i.e. %(Literal to the output%) is sent directly to the
%%c    output with no other processing.
%%c 
%%c 3. The dynamic determination of F77_... was eliminated.  Conditionals
%%c    were provided so that rat77 and ratfor could be built in addition to
%%c    the default ratp1.
%%c 
%%c 'Nuff Said.
%%s 330/269/3607
%%d D 1.12 15-Mar-83 23:07:02 sventek 12 11
%%c The following changes have been made along the road to the new "standard"
%%c ratfor preprocessor:
%%c 
%%c 1. An additional built-in macro is provided
%%c 
%%c    hollerith(string)
%%c 
%%c    to force the output of an hollerith string for non-portable applications.
%%c    Since this is evaluated as a macro, any defined symbols inside of `string'
%%c    must be escaped via $( ... $) digraphs, as in
%%c 
%%c    hollerith($(hollerith$) string)  ==>  16Hhollerith string
%%c 
%%c 2. Hollerith strings (nh...) are treated as single tokens, in part to implement
%%c    1 above.
%%c 
%%c 3. Defined symbols can be undefined via
%%c 
%%c    undefine(symbol)
%%c 
%%c    Nothing is done if the symbol is not already defined.
%%c 
%%c 4. For those sites which choose to enable the long variable name generation,
%%c    an additional directive is available to bind long variable names to
%%c    external routines in a library
%%c 
%%c    linkage long_variable_name external_name
%%c 
%%c    The pair of names is entered into the table of known long variable names
%%c    and the external name is entered into the table of generated variable names;
%%c    this latter step prevents any generated names from colliding with the
%%c    external name.  It is incumbent upon the programmer to provide accurate
%%c    information via this statement to permit access to routines with
%%c    "long variable names" across compilations.
%%c 
%%c    For sites which do not enable the long name code, linkage is synonymous
%%c    with define.
%%c 
%%c 5. Extraneous subroutines called only by `gctok' during conditional processing
%%c    have been expanded inline in said routine.
%%c 
%%c 6. `deftok' no longer folds ALPHA tokens, thus fixing a bug with defined names
%%c    appearing at the beginning of a line.
%%c 
%%c 7. Syntax errors encountered while skipping unprocessed conditional code are
%%c    no longer reported, since the processing by `gtok' which generates the
%%c    error messages is not operating in the proper context.
%%c 
%%c 8. In order to be as much of a jack-of-all-trades as possible in the
%%c    Great Quoted String Deba[te/cle], the processor does the following:
%%c 
%%c    a. the code for ratfor is no longer conditionalized upon
%%c       F77_CHARACTER_STRINGS
%%c 
%%c    b. the output format of quoted strings ("...") is dependent at runtime
%%c       upon the definition of F77_CHARACTER_STRINGS.  If it is defined,
%%c       "..." ==> '...'; if not, "..." ==> nH...
%%c 
%%c    As a result of these changes, a programmer wishing to generate F77 style
%%c    strings, but still wishing to partake of the other features provided by
%%c    ratfor (character literals, ...) need only
%%c 
%%c    define(F77_CHARACTER_STRINGS,)
%%c 
%%c    at the beginning of his/her code.
%%s 174/145/3702
%%d D 1.11 13-Jan-83 14:01:30 sventek 11 10
%%c After the 10 January 1983 meeting of the Software Tools Implementors, it
%%c was decided that apostrophe-delimited strings WOULD be illegal, and that
%%c the pre-processor should flag them as such.  In addition, there was some
%%c reluctance to accept the multiple-FORTRAN statement syntax for the clauses
%%c of the for statement.  As a result of that meeting, the following actions
%%c were taken on the ratfor pre-processor:
%%c 
%%c 1. `gtok' was modified to generate a diagnostic if an apostrophe-delimited
%%c    character string is detected.  In addition, the string is replaced by
%%c    the value of the character constant generated from the first one or
%%c    two characters.  Note that if F77_CHARACTER_STRINGS is defined, the
%%c    diagnostic is not generated, and the apostrophe-delimited string is
%%c    output unmodified, except for the ! escape for single character F77
%%c    strings.
%%c 2. The multi-statement clauses in the for statement are retained, but using
%%c    the same syntax as C - i.e.
%%c 
%%c    for (i-1, i-2, ..., i-n; condition; r-1, r-2, ..., r-m)
%%c       statement
%%c 
%%c    This entailed modifications to the routines `dother', `fclaus',
%%c    `forcod' and `fors'.
%%c 3. The routines `cndlu' and `outstr' were modified to reflect the change
%%c    in 2 above.
%%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
%%D 13
#-h- common          2689  asc  17-dec-81 00:26:51  sventek (joseph sventek)
%%E 13
%%E 10
%%I 13
#-h- common          2961  asc  13-may-83 07:47:30  sventek (joseph sventek)
%%E 13
# 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
%%I 13
ifdef(DO_PASS1)
   common / cpass1 / strcnt ifdef(DO_CHAR_DECL) , chrcnt enddef
     integer strcnt       # counter for generated string variables - init = 1
ifdef(DO_CHAR_DECL)
     integer chrcnt       # counter for generated character variables - init=1
enddef
enddef

%%E 13
 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
%%D 11
#-h- ratfor.r       78590  asc  17-dec-81 00:27:06  sventek (joseph sventek)
%%E 11
%%I 11
%%D 12
#-h- ratfor.r       76899  asc  13-jan-83 13:23:59  sventek (joseph sventek)
%%E 12
%%E 11
%%D 12
#-h- defns           4870  asc  16-dec-81 23:22:24  sventek (joseph sventek)
%%E 12
%%E 10
%%I 12
%%D 13
#-h- ratfor.r       78424  asc  15-mar-83 22:14:52  sventek (joseph sventek)
#-h- defns           4515  asc  15-mar-83 12:15:09  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
%%D 14
#-h- ratfor.r       88931  asc  13-may-83 11:53:10  sventek (joseph sventek)
#-h- defns           6954  asc  13-may-83 08:31:55  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
%%D 15
#-h- ratfor.r       88920  asc  15-jun-83 15:53:08  sventek (joseph sventek)
%%E 15
%%I 15
%%D 16
#-h- ratfor.r       88940  asc  21-jul-83 16:38:31  sventek (joseph sventek)
%%E 16
%%E 15
%%I 16
%%D 17
#-h- ratfor.r       89068  asc  26-jul-83 12:46:49  sventek (joseph sventek)
%%E 17
%%E 16
%%I 17
#-h- ratfor.r       88570  asc  02-aug-83 22:13:24  tools (lblh csam sventek)
%%E 17
#-h- defns           6950  asc  15-jun-83 15:49:21  sventek (joseph sventek)
%%E 14
# 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
%%D 13
# automatically open this file, set STDENFS to "".
%%E 13
%%I 13
# automatically open this file, set STDEFNS to "".
# The suggested name for this file is `ratdef'.
%%E 13
#
#---------------------------------------------------------------
#    If you want the preprocessor to output upper case only,
#    set the following definition:
#
#              define (UPPERC,)
#
%%I 13
#    This is defined by default
%%E 13
#---------------------------------------------------------------
#    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 13
#    This is defined by default
%%E 13
#---------------------------------------------------------------
%%I 10
%%D 12
#    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 12
%%E 10
%%I 13
#    Quoted string handling
#
#    One of the major changes to the pre-processor with this release
#    is to permit pre-processors to be built which handle
#    quoted strings differently.
#
#    This action is determined by one of three defined symbols:
#
#    DO_PASS1 - all quoted strings encountered will have a character
#               variable name generated for them, with the appropriate
#               data statements expanded inline with the declaration.
#               As a result, all quoted strings are legal character
#               variables, and may be used anywhere a character array
#               could be used before.   For example
#
#               call putlin("Hello world.@n", STDOUT)
#
#               is now legal.  This is at the expense of requiring that
#               the output of the pre-processor must be run through the
#               second pass of the processor, RATP2.  In addition, the
#               variable generated by the switch statement is declared
#               to be of type INTEGER.
#
#    DO_F77_STRINGS - all quoted strings are output as F77 style strings.
#                     it is expected that sites who wish to use ratfor
#                     to pre-process into F77 will define this symbol
#                     instead of DO_PASS1 and probably will define
#                     STDEFNS to be "".  Such a version of the pre-processor
#                     should probably be called RAT77
#
#    DO_HOLLERITH - this outputs hollerith strings as before.
#
#    The default is DO_PASS1.
#---------------------------------------------------------------
%%E 13
#    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
%%D 13
define (STDEFNS,"symbols")	# name of file containing standard defns
%%E 13
%%I 10
%%I 13
ifnotdef (STDEFNS)
   define(STDEFNS,"ratdef")
enddef
%%E 13
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
%%I 13
#
# Pick only ONE of the following pairs !!!!!
#
#define (DO_PASS1,)		# output char decl and data statements for "...."
%%D 14
#define (USE_STRING,"usage:  ratp1 [-n] [file] ... >outfile.")
%%E 14
%%I 14
#define (USE_STRING,"usage:  ratp1 [-n] [file] ... >outfile")
%%E 14
#define (DO_F77_STRINGS,)	# output F77 strings for "...."
%%D 14
#define (USE_STRING,"usage:  rat77 [-n] [file] ... >outfile.")
%%E 14
%%I 14
#define (USE_STRING,"usage:  rat77 [-n] [file] ... >outfile")
%%E 14
#define (DO_HOLLERITH,)		# output hollerith strings for "...."
%%D 14
#define (USE_STRING,"usage:  ratfor [-n] [file] ... >outfile.")
%%E 14
%%E 13
%%I 14
#define (USE_STRING,"usage:  ratfor [-n] [file] ... >outfile")
%%E 14

%%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
%%I 13
#
# apply defaults
#
ifnotdef(USE_STRING)
   define(DO_PASS1,)
%%D 14
   define(USE_STRING,"usage:  ratp1 [-n] [file] ... >outfile.")
%%E 14
%%I 14
   define(USE_STRING,"usage:  ratp1 [-n] [file] ... >outfile")
%%E 14
enddef

%%E 13
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)
%%I 13
define (LITQUOTEC,-12)
%%E 13


# 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)
%%I 12
%%D 13
define (HOLLERITHTYPE,-20)
%%E 13
define (UNDEFTYPE,-21)
define (LINKTYPE,-22)
%%E 12
%%I 13
define (LENTOKTYPE,-23)
%%E 13


# 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
%%D 13
  define(A_S_X,4)
%%E 13
%%E 9
%%I 13
  define(A_S_X,5)
%%E 13
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
%%D 13
#-h- main            1163  asc  16-dec-81 23:58:15  sventek (joseph sventek)
%%E 13
%%E 10
%%I 13

ifnotdef(DO_PASS1)
   undefine(DO_CHAR_DECL)
enddef
ifdef(DO_BOOTSTRAP)
   undefine(DO_SWITCH)			# bootstrap does not need switch
enddef
#-h- main            1131  asc  13-may-83 08:16:29  sventek (joseph sventek)
%%E 13
   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
%%D 13
   call query ("usage:  ratfor [-n] [file] ... >outfile.")
%%E 13
%%E 10
%%I 13
   call query (USE_STRING)
%%E 13
  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
%%D 14
#-h- addchr           268  asc  25-mar-82 08:22:21  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
%%D 16
#-h- addchr           267  asc  15-jun-83 15:49:24  sventek (joseph sventek)
%%E 16
%%E 14
%%D 16
# addchr - put c in buf(bp) if it fits, increment bp
   subroutine addchr(c, buf, bp, maxsiz)
%%E 16
%%I 16
#-h- inschr           267  asc  15-jun-83 15:49:24  sventek (joseph sventek)
# inschr - put c in buf(bp) if it fits, increment bp
   subroutine inschr(c, buf, bp, maxsiz)
%%E 16
   integer bp, maxsiz
   character c, buf(ARB)

   ext_subr baderr
 
   if (bp > maxsiz)
%%D 14
      call baderr("buffer overflow.")
%%E 14
%%I 14
      call baderr("buffer overflow")
%%E 14
   buf(bp) = c
   bp = bp + 1
   return
   end
%%D 16
#-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)
%%E 16
%%I 16
#-h- insstr           276  asc  25-mar-82 08:22:21  v1.1 (sw-tools v1.1)
# insstr - put s in buf(bp) by repeated calls to inschr
   subroutine insstr(s, buf, bp, maxsiz)
%%E 16
   character s(ARB), buf(ARB)
   integer bp, maxsiz
   integer i

%%D 16
   ext_subr addchr
%%E 16
%%I 16
   ext_subr inschr
%%E 16

   for (i = 1; s(i) != EOS; i=i+1)
%%D 16
      call addchr(s(i), buf, bp, maxsiz)
%%E 16
%%I 16
      call inschr(s(i), buf, bp, maxsiz)
%%E 16
   return
   end
%%D 13
#-h- alldig           306  asc  25-mar-82 08:22:22  v1.1 (sw-tools v1.1)
%%E 13
%%I 13
%%D 17
#-h- alldig           421  asc  03-may-83 09:50:33  sventek (joseph sventek)
%%E 17
%%E 13
%%D 17
# alldig - return YES if str is all digits

   integer function alldig (str)
   character str (ARB)

%%E 17
%%D 13
   character type
%%E 13
%%I 13
%%D 17
ifnotdef(IS_DIGIT)
   ext_func character type
enddef
%%E 17
%%E 13
%%D 17

   integer i

   alldig = NO
   if (str (1) == EOS)
      return
   for (i = 1; str (i) != EOS; i = i + 1)
%%E 17
%%I 13
%%D 17
ifdef(IS_DIGIT)
%%E 17
%%E 13
%%D 17
      if (!IS_DIGIT(str (i)))
         return
%%E 17
%%I 13
%%D 17
elsedef
      if (type(str(i)) != DIGIT)
         return
enddef
%%E 17
%%E 13
%%D 17
   alldig = YES
   return
   end
%%E 17
#-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
%%D 14
#-h- balpar           920  asc  25-mar-82 08:22:24  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- balpar           918  asc  15-jun-83 15:49:25  sventek (joseph sventek)
%%E 14
# 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) != '(') {
%%D 14
      call synerr ("missing left paren.")
%%E 14
%%I 14
      call synerr ("missing left paren")
%%E 14
      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)
%%D 14
      call synerr ("missing parenthesis in condition.")
%%E 14
%%I 14
      call synerr ("missing parenthesis in condition")
%%E 14

   return
   end
%%D 14
#-h- brknxt          1107  asc  25-mar-82 08:22:26  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- brknxt          1105  asc  15-jun-83 15:49:26  sventek (joseph sventek)
%%E 14
# 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)
%%D 14
      call synerr ("illegal break.")
%%E 14
%%I 14
      call synerr ("illegal break")
%%E 14
   else
%%D 14
      call synerr ("illegal next.")
%%E 14
%%I 14
      call synerr ("illegal next")
%%E 14

   return
   end
%%D 14
#-h- cascod          1948  asc  25-mar-82 08:22:28  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- cascod          1939  asc  15-jun-83 15:49:27  sventek (joseph sventek)
%%E 14
# 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
%%D 14
      call synerr ("illegal case or default.")
%%E 14
%%I 14
      call synerr ("illegal case or default")
%%E 14
      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) {
%%D 14
            call synerr ("illegal range in case label.")
%%E 14
%%I 14
            call synerr ("illegal range in case label")
%%E 14
            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)
%%D 14
            call baderr ("switch table overflow.")
%%E 14
%%I 14
            call baderr ("switch table overflow")
%%E 14
         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
%%D 14
               call synerr ("duplicate case label.")
%%E 14
%%D 5
         if (i < selast & ub >= sestak (i))
%%E 5
%%I 5
%%I 14
               call synerr ("duplicate case label")
%%E 14
         if (i < swlast & ub >= swstak (i))
%%E 5
%%D 14
            call synerr ("duplicate case label.")
%%E 14
%%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
%%I 14
            call synerr ("duplicate case label")
%%E 14
         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 != ',')
%%D 14
            call synerr ("illegal case syntax.")
%%E 14
%%I 14
            call synerr ("illegal case syntax")
%%E 14
         }
      }
   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)
%%D 14
         call baderr ("multiple defaults in switch statement.")
%%E 14
%%E 5
%%I 14
         call baderr ("multiple defaults in switch statement")
%%E 14
      else
%%D 5
         sestak (setop + 2) = l
%%E 5
%%I 5
         swstak (swtop + 2) = l
%%E 5
      }

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

   xfer = NO
   call outcon (l)
   return
   end
  enddef
%%D 14
#-h- caslab           691  asc  25-mar-82 08:22:30  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- caslab           690  asc  15-jun-83 15:49:28  sventek (joseph sventek)
%%E 14
# 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) {
%%D 14
      call synerr ("invalid case label.")
%%E 14
%%I 14
      call synerr ("invalid case label")
%%E 14
      n = 0
      }
   else {
      i = 1
      n = s * ctoi (tok, i)
      }
   t = gnbtok (tok, MAXTOK)
   while (t == '@n')
      t = gnbtok (tok, MAXTOK)

   return
   end
  enddef
%%D 12
#-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
%%E 12
%%D 11
#-h- cndlu            952  asc  25-mar-82 08:22:33  v1.1 (sw-tools v1.1)
%%E 11
%%I 11
%%D 12
#-h- cndlu            950  asc  13-jan-83 11:39:53  sventek (joseph sventek)
%%E 12
%%E 11
%%D 12
# 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)
         {
%%E 12
%%D 11
         for (j=1; cndtbl(i) != '/'; [i=i+1; j=j+1])
%%E 11
%%I 11
%%D 12
         for (j=1; cndtbl(i) != '/'; i=i+1, j=j+1)
%%E 12
%%E 11
%%D 12
            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)
%%E 12
%%I 12
%%D 14
#-h- deftok          4453  asc  15-mar-83 21:54:55  sventek (joseph sventek)
%%E 14
%%E 12
%%I 14
#-h- deftok          4450  asc  15-jun-83 15:49:30  sventek (joseph sventek)
%%E 14
# 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

%%D 12
   ext_func integer ludef, push, ifparm
%%E 12
%%I 12
   ext_func integer ludef, push, ifparm, enter
%%E 12
   ext_func character gctok
   ext_subr puttok, getdef, entdef, baderr, putchr, pbstr, putbak, evalr, fold

   string balp "()"

   cp = 0
   ap = 1
   ep = 1
%%D 12
   for (t = gctok (token, toksiz); t != EOF; t = gctok (token, toksiz)) {
%%E 12
%%I 12
   repeat {
      t = gctok (token, toksiz)
      if (t == EOF)
         break
%%E 12
      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)
            }
%%I 12
         else if (defn (1) == UNDEFTYPE) {	  # undefine the token
            call getund (token)                   # get name to undefine
            call rmdef (token, deftbl)
            }
         ifdef(DO_LONGNAME)
         else if (defn (1) == LINKTYPE) {	  # process linkage statement
            call getdef (token, toksiz, defn, MAXDEF)
            call fold(token)
            call fold(defn)
            call entdef (token, defn, namtbl)
            if (enter(defn, 0, gentbl) == ERR)
%%D 14
               call synerr("No room for linkage external name.")
%%E 14
%%I 14
               call synerr("No room for linkage external name")
%%E 14
            }
         enddef
%%E 12
         else {
            cp = cp +  1
            if (cp > CALLSIZE)
%%D 14
               call baderr ("call stack overflow.")
%%E 14
%%I 14
               call baderr ("call stack overflow")
%%E 14
            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)
%%D 14
            call baderr ("EOF in string.")
%%E 14
%%I 14
            call baderr ("EOF in string")
%%E 14
            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
%%D 12
   if (t == ALPHA)
      call fold (token)
%%E 12
%%I 12
#   if (t == ALPHA)
#      call fold (token)
%%E 12

   return
   end
%%I 13
%%D 15
#-h- dmpdcl          1748  asc  10-may-83 07:53:22  sventek (joseph sventek)
%%E 15
%%I 15
#-h- dmpdcl          1756  asc  21-jul-83 15:58:16  sventek (joseph sventek)
%%E 15
ifdef(DO_PASS1)
# dmpdcl - dump accumulated declarations
subroutine dmpdcl(token)

character token(ARB)

integer i, j, n
character c

ext_func integer index
ext_func character esc

include COMMON_BLOCKS

string char "character"
string comstr "c     "
string dats "data "
string eoss "EOS"

if (sbp > 1)				# something to do
   {
   for (i = 1; i < sbp; i = i + 1)
      {
      call outtab
      call outdef(char, token)
      call outch(' ')
      c = sbuf(i)
      j = 1
      for (i = i + 1; sbuf(i) != EOS; i = i + 1)
         {
         token(j) = sbuf(i)
         j = j + 1
         }
      token(j) = EOS
      i = i + 1
      call outstr(token)
      call outdon
%%D 15
      call outstr(comstr)
      call outstr(token)
      call outch(' ')
      call outch(c)
      for (j = i; sbuf(j) != EOS; j = j + 1)
         call outch(sbuf(j))
      call outch(c)
      call outdon
%%E 15
%%I 15
#      call outstr(comstr)
#      call outstr(token)
#      call outch(' ')
#      call outch(c)
#      for (j = i; sbuf(j) != EOS; j = j + 1)
#         call outch(sbuf(j))
#      call outch(c)
#      call outdon
%%E 15
      j = index(token, '(')
      if (j > 0)
         token(j) = EOS
      j = 1
      repeat
         {
         if (sbuf(i) == EOS & c == '@'')
            break
         if (j == 1)
            {
            call outtab
            call outstr(dats)
            }
         else
            call outch(',')
         call outstr(token)
         if (c == '"')
            {
            call outch('(')
            call outnum(j)
            call outch(')')
            }
         call outch('/')
         if (sbuf(i) == EOS)
            {
            call outdef(eoss, token)
            call outch('/')
            break
            }
         else
            {
            n = esc(sbuf, i)
            call outnum(n)
            call outch('/')
            }
         j = j + 1
         i = i + 1
         }
      call outdon
      }
   sbp = 1
   }

return
end
enddef
%%E 13
%%D 14
#-h- doarth           873  asc  25-mar-82 08:22:40  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- doarth           872  asc  15-jun-83 15:49:33  sventek (joseph sventek)
%%E 14
# 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
%%D 14
      call synerr ("arith error.")
%%E 14
%%I 14
      call synerr ("arith error")
%%E 14

   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
%%I 12
%%D 13
#-h- doholl           333  asc  02-feb-83 09:29:53  sventek (joseph sventek)
# doholl - output hollerith string

   subroutine doholl (argstk, i, j)

   integer argstk (ARGSIZE), i, j

   include COMMON_BLOCKS

   integer k

   ext_func integer length
   ext_subr pbstr, putbak, pbnum

   k = argstk (i + 2)
   call pbstr (evalst (k))
   call putbak ('H')
   call pbnum (length (evalst (k)))

   return
   end
%%E 13
%%E 12
#-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
%%I 13
#-h- dolent           238  asc  17-mar-83 23:55:41  sventek (joseph sventek)
# dolent - push back length of argument
subroutine dolent(argstk, i, j)

integer argstk(ARGSIZE), i, j

include COMMON_BLOCKS

integer k

ext_func integer length
ext_subr pbnum

k = argstk(i + 2)
call pbnum(length(evalst(k)))

return
end
%%E 13
%%D 15
#-h- domac            346  asc  25-mar-82 08:22:45  v1.1 (sw-tools v1.1)
%%E 15
%%I 15
%%D 16
#-h- domac            453  asc  21-jul-83 16:21:17  sventek (joseph sventek)
%%E 16
%%E 15
%%I 16
#-h- domac            581  asc  26-jul-83 11:53:11  sventek (joseph sventek)
%%E 16
# 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
%%I 16
ifnotdef(IS_LETTER)
   ext_func character type
enddef
%%E 16

   if (j - i > 2) {
      a2 = argstk (i + 2)
      a3 = argstk (i + 3)
%%D 15
      call entdef (evalst (a2), evalst (a3), deftbl)     # subarrays
%%E 15
%%I 15
%%I 16
ifnotdef (IS_LETTER)
      if (type(evalst(a2)) != LETTER)
elsedef
%%E 16
      if (! IS_LETTER(evalst(a2)))
%%I 16
enddef
%%E 16
         call synerr("Illegal first argument to mdefine")
      else
         call entdef (evalst (a2), evalst (a3), deftbl)     # subarrays
%%E 15
      }
   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
%%D 11
#-h- dother           510  asc  25-mar-82 08:22:49  v1.1 (sw-tools v1.1)
%%E 11
%%I 11
%%D 14
#-h- dother           630  asc  13-jan-83 12:07:13  sventek (joseph sventek)
%%E 14
%%E 11
%%I 14
#-h- dother           629  asc  15-jun-83 15:49:35  sventek (joseph sventek)
%%E 14
# process one other string in for clause

character function dother(token)

character token(MAXTOK), t
%%I 11
integer nlpar
%%E 11

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

call outtab
%%I 11
nlpar = 0
%%E 11
repeat
  {
  t = gettok(token, MAXTOK)
%%D 11
  if (t == ';' | t == '}')
%%E 11
%%I 11
  if (t == '(')
    nlpar = nlpar + 1
  else if (t == ')')
    nlpar = nlpar - 1
  if (t == ';' | (t == ',' & nlpar == 0))
%%E 11
    break
  if (t == EOF)
    {
%%D 14
    call synerr("unexpected EOF.")
%%E 14
%%I 14
    call synerr("unexpected EOF")
%%E 14
    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
%%D 14
#-h- eatup           1111  asc  25-mar-82 08:22:50  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- eatup           1109  asc  15-jun-83 15:49:36  sventek (joseph sventek)
%%E 14
# 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) {
%%D 14
         call synerr ("unexpected EOF.")
%%E 14
%%I 14
         call synerr ("unexpected EOF")
%%E 14
         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)
%%D 14
      call synerr ("unbalanced parentheses.")
%%E 14
%%I 14
      call synerr ("unbalanced parentheses")
%%E 14

   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
%%D 12
#-h- entdkw           757  asc  25-mar-82 08:22:55  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
%%D 13
#-h- entdkw           728  asc  15-mar-83 12:15:20  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
#-h- entdkw           721  asc  12-apr-83 16:41:08  sventek (joseph sventek)
%%E 13
# entdkw --- install macro processor keywords

   subroutine entdkw

%%D 12
   character deft (2), inct (2), subt (2), ift (2), art (2), mact (2)

%%E 12
   ext_subr ulstal

   string defnam "define"
   string macnam "mdefine"
   string incnam "incr"
   string subnam "substr"
   string ifnam "ifelse"
   string arnam "arith"
%%I 12
%%D 13
   string holnam "hollerith"
%%E 13
   string undefn "undefine"
   string linknm "linkage"
%%E 12
%%I 13
   string lentnm "lentok"
%%E 13

%%D 12
   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/
%%E 12
%%I 12
   call ulstal (defnam, DEFTYPE)
   call ulstal (macnam, MACTYPE)
   call ulstal (incnam, INCTYPE)
   call ulstal (subnam, SUBTYPE)
   call ulstal (ifnam, IFTYPE)
   call ulstal (arnam, ARITHTYPE)
%%D 13
   call ulstal (holnam, HOLLERITHTYPE)
%%E 13
   call ulstal (undefn, UNDEFTYPE)
   ifdef (DO_LONGNAME)
     call ulstal(linknm, LINKTYPE)
   elsedef
     call ulstal(linknm, DEFTYPE)
   enddef
%%E 12
%%I 13
   call ulstal(lentnm, LENTOKTYPE)
%%E 13

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

%%E 12
   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
%%D 13
#-h- entrkw          1203  asc  18-oct-82 13:09:58  sventek (joseph sventek)
%%E 13
%%E 5
%%I 13
#-h- entrkw          1133  asc  28-apr-83 10:39:05  sventek (joseph sventek)
%%E 13
# 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
%%D 13
   string sselct "select"
%%E 13
   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)
%%D 13
   junk = enter (sselct, LEXSWITCH, rkwtbl)
%%E 13
%%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
%%D 12
#-h- evalr           1382  asc  04-may-82 11:18:43  j (sventek j)
%%E 12
%%E 3
%%I 12
%%D 13
#-h- evalr           1448  asc  02-feb-83 09:29:34  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
#-h- evalr           1445  asc  12-apr-83 16:41:10  sventek (joseph sventek)
%%E 13
# 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)
%%I 12
%%D 13
   else if (td == HOLLERITHTYPE)
      call doholl (argstk, i, j)
%%E 13
%%E 12
%%I 13
   else if (td == LENTOKTYPE)
      call dolent (argstk, i, j)
%%E 13
   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
%%D 11
#-h- fclaus           550  asc  25-mar-82 08:23:02  v1.1 (sw-tools v1.1)
%%E 11
%%I 11
#-h- fclaus           328  asc  13-jan-83 12:07:16  sventek (joseph sventek)
%%E 11
# process for init or re-init clause

subroutine fclaus

character token(MAXTOK), t
%%D 11
integer brace
%%E 11

ext_func character gnbtok, dother
ext_subr pbstr, synerr

%%D 11
if (gnbtok(token, MAXTOK) == '{')	# { mother }
  brace = YES
else
%%E 11
%%I 11
repeat
%%E 11
  {
%%D 11
  call pbstr(token)			# other
  brace = NO
%%E 11
%%I 11
  t = gnbtok(token, MAXTOK)		# get rid of leading blanks
  call pbstr(token)			# ...
  t = dother(token)			# process single other
%%E 11
  }
%%D 11
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.")
  }
%%E 11
%%I 11
until (t == ';' | t == EOF)
%%E 11

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
%%D 11
#-h- forcod          2718  asc  25-mar-82 08:23:05  v1.1 (sw-tools v1.1)
%%E 11
%%I 11
%%D 14
#-h- forcod          2497  asc  13-jan-83 12:07:18  sventek (joseph sventek)
%%E 14
%%E 11
%%I 14
#-h- forcod          2494  asc  15-jun-83 15:49:40  sventek (joseph sventek)
%%E 14
# 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) != '(') {
%%D 14
      call synerr ("missing left paren.")
%%E 14
%%I 14
      call synerr ("missing left paren")
%%E 14
      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)
%%D 14
         call synerr ("invalid for clause.")
%%E 14
%%I 14
         call synerr ("invalid for clause")
%%E 14
      }
   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)
%%D 14
            call baderr ("for clause too long.")
%%E 14
%%I 14
            call baderr ("for clause too long")
%%E 14
         call scopy (scrtok, 1, forstk, j)
         j = j + length (scrtok)
         len = len + length (scrtok)
         }
%%D 11
      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.")
         }
%%E 11
      }
   lab = lab + 1   # label for next's
   return
   end
%%D 11
#-h- fors             544  asc  25-mar-82 08:23:08  v1.1 (sw-tools v1.1)
%%E 11
%%I 11
#-h- fors             597  asc  13-jan-83 12:07:19  sventek (joseph sventek)
%%E 11
# 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) {
%%I 11
      call putbak (';')			# push back trailing colon
%%E 11
      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
%%D 12
#-h- gctok            975  asc  25-mar-82 08:23:10  v1.1 (sw-tools v1.1)
# gctok - get next token subject to conditionals
%%E 12
%%I 12
%%D 14
#-h- gctok           2342  asc  17-feb-83 12:03:02  sventek (joseph sventek)
%%E 14
%%I 14
#-h- gctok           2337  asc  15-jun-83 15:49:42  sventek (joseph sventek)
%%E 14
# gctok - get next token, subject to conditionals
character function gctok(token, toksiz)
%%E 12

%%D 12
   character function gctok(token, toksiz)
%%E 12
%%I 12
character token(MAXTOK)
integer toksiz
%%E 12

%%D 12
   character token(MAXTOK)
   integer toksiz
%%E 12
%%I 12
include COMMON_BLOCKS
%%E 12

%%D 12
   include COMMON_BLOCKS
%%E 12
%%I 12
character temp(9)
integer ctype, i, n, j, cndval(4), newcnd, value
%%E 12

%%D 12
   character c
   integer newcnd
%%E 12
%%I 12
ext_func character gtok
ext_func integer equal, lookup
ext_subr upper, baderr, skpblk
%%E 12

%%D 12
   ext_func character gtok, cndlu
   ext_func integer cndget
   ext_subr baderr
%%E 12
%%I 12
string letts  "eEiI"
string cndtbl "ifdef/ifnotdef/elsedef/enddef/"
%%E 12

%%D 12
   for (gctok=gtok(token,toksiz); gctok != EOF; gctok=gtok(token,toksiz))
      {
      c = cndlu (token)
      if (c == NOTDEFTYPE)
         {
         if (curcnd == C_TRUE)
%%E 12
%%I 12
data cndval(1)/IFDEFTYPE/, cndval(2)/IFNOTDEFTYPE/,
     cndval(3)/ELSEDEFTYPE/, cndval(4)/ENDDEFTYPE/

repeat {
   gctok = gtok (token, toksiz)
   if (gctok == EOF)
      break
   ctype = NOTDEFTYPE				# assume not conditional
   for (i = 1; letts(i) != EOS; i = i + 1)	# see if correct first char
      if (letts(i) == token(1))
         break
   if (letts(i) != EOS) {			# YES, check further
      n = 1					# index into cndval
      for (i = 1; cndtbl(i) != EOS; i = i + 1) {
         for (j = 1; cndtbl(i) != '/'; j = j + 1) {
            temp(j) = cndtbl(i)
            i = i + 1
            }
         temp(j) = EOS
         j = equal(token, temp)
         if (j == NO) {
            call upper(temp)
            j = equal(token, temp)
            }
         if (j == YES) {
            ctype = cndval(n)
%%E 12
            break
%%I 12
            }
         n = n + 1
%%E 12
         }
%%D 12
      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)
%%E 12
%%I 12
      }
   if (ctype == NOTDEFTYPE) {
      if (curcnd == C_TRUE)
         break
      }
   else if (ctype == ENDDEFTYPE) {
      if (csp <= 0)
%%D 14
         call baderr("Illegal enddef encountered.")
%%E 14
%%I 14
         call baderr("Illegal enddef encountered")
%%E 14
      curcnd = cndstk(csp)
      csp = csp - 1
      }
   else {
      if (ctype == ELSEDEFTYPE)
         newcnd = - curcnd
      else {
         if (csp >= COND_STACK_DEPTH)
%%D 14
            call baderr("Conditionals nested too deeply.")
%%E 14
%%I 14
            call baderr("Conditionals nested too deeply")
%%E 14
         csp = csp + 1
         cndstk(csp) = curcnd
         call skpblk
         if (gtok(temp, 9) != '(')
%%D 14
            call baderr("missing `(' in conditional.")
%%E 14
%%I 14
            call baderr("missing `(' in conditional")
%%E 14
         call skpblk
         if (gtok(token, toksiz) != ALPHA)
%%D 14
            call baderr("invalid conditional token.")
%%E 14
%%I 14
            call baderr("invalid conditional token")
%%E 14
         call skpblk
         if (gtok(temp, 9) != ')')
%%D 14
            call baderr("missing `)' in conditional.")
%%E 14
%%I 14
            call baderr("missing `)' in conditional")
%%E 14
         if (lookup(token, value, deftbl) == YES)
            newcnd = C_TRUE
%%E 12
         else
%%D 12
            newcnd = - curcnd
         curcnd = min (newcnd, cndstk (csp) )
%%E 12
%%I 12
            newcnd = - C_TRUE
         if (ctype == IFNOTDEFTYPE)
            newcnd = - newcnd
%%E 12
         }
%%I 12
      curcnd = min (newcnd, cndstk (csp) )
%%E 12
      }
%%I 12
   }
%%E 12

%%D 12
   return
   end
%%E 12
%%I 12
return
end
%%E 12
%%I 13
#-h- gennam           711  asc  03-may-83 08:25:56  sventek (joseph sventek)
ifdef(DO_PASS1)
# gennam - generate name for string and character variables
integer function gennam(root, countr, buf)

character root(ARB), buf(incr(MAXIDLENGTH)), temp(4)
integer countr, x, i, d, j

string digits "0123456789abcdefghijklmnopqrst"

x = countr
countr = countr + 1
if (countr > arith(30,**,3))
   countr = 1
for (i = 1; x > 0; i = i + 1)
   {
   d = mod(x, 30) + 1
   temp(i) = digits(d)
   x = x / 30
   }
temp(i) = EOS
j = 1
%%D 16
call addstr(root, buf, j, MAXIDLENGTH)
%%E 16
%%I 16
call insstr(root, buf, j, MAXIDLENGTH)
%%E 16
for (x = 4 - i; x > 0; x = x - 1)
%%D 16
   call addchr('0', buf, j, MAXIDLENGTH)
%%E 16
%%I 16
   call inschr('0', buf, j, MAXIDLENGTH)
%%E 16
for (i = i - 1; i > 0; i = i - 1)
%%D 16
   call addchr(temp(i), buf, j, MAXIDLENGTH)
call addchr('z', buf, j, MAXIDLENGTH)
%%E 16
%%I 16
   call inschr(temp(i), buf, j, MAXIDLENGTH)
call inschr('z', buf, j, MAXIDLENGTH)
%%E 16
buf(j) = EOS

return (j-1)
end
enddef
%%E 13
%%D 14
#-h- getdef          1661  asc  25-mar-82 08:23:11  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- getdef          1655  asc  15-jun-83 15:49:44  sventek (joseph sventek)
%%E 14
# 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)
%%D 14
      call baderr ("non-alphanumeric name.")
%%E 14
%%I 14
      call baderr ("non-alphanumeric name")
%%E 14
   call skpblk
   c = gctok (ptoken, MAXTOK)
   if (t == ' ') {         # define name defn
      call pbstr (ptoken)
      i = 1
      repeat {
         c = ngetch (c)
         if (i > defsiz)
%%D 14
            call baderr ("definition too long.")
%%E 14
%%I 14
            call baderr ("definition too long")
%%E 14
         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 != ',')
%%D 14
         call baderr ("missing comma in define.")
%%E 14
%%I 14
         call baderr ("missing comma in define")
%%E 14
      # else got (name,
      nlpar = 0
      for (i = 1; nlpar >= 0; i = i + 1)
         if (i > defsiz)
%%D 14
            call baderr ("definition too long.")
%%E 14
%%I 14
            call baderr ("definition too long")
%%E 14
         else if (ngetch (defn (i)) == EOF)
%%D 14
            call baderr ("missing right paren.")
%%E 14
%%I 14
            call baderr ("missing right paren")
%%E 14
         else if (defn (i) == '(')
            nlpar = nlpar + 1
         else if (defn (i) == ')')
            nlpar = nlpar - 1
         # else normal character in defn (i)
      }
   else
%%D 14
      call baderr ("getdef is confused.")
%%E 14
%%I 14
      call baderr ("getdef is confused")
%%E 14
   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
%%D 12
#-h- gettok          2321  asc  19-oct-82 17:16:01  sventek (joseph sventek)
%%E 12
%%E 6
%%I 12
%%D 14
#-h- gettok          2609  asc  02-feb-83 10:49:32  sventek (joseph sventek)
%%E 14
%%E 12
%%I 14
#-h- gettok          2606  asc  15-jun-83 15:49:46  sventek (joseph sventek)
%%E 14
# 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
%%D 12
   character name (MAXNAME), t
%%E 12
%%I 12
   character name (MAXNAME), t, tbuf(9)
%%E 12

   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

%%D 12
      for (gettok = deftok (token, toksiz); gettok != EOF;
       gettok = deftok (token, toksiz)) {
         if (equal (token, fncn) == YES) {
%%E 12
%%I 12
      repeat {
         gettok = deftok(token, toksiz)
         if (gettok == EOF)
            break
         else if (gettok != ALPHA)
            return
         for (i = 1; i <= 9; i = i + 1)
            {
            t = token(i)
            tbuf(i) = t
            if (t == EOS)
               break
            }
         if (i < 8 | t != EOS)
            return
         call fold(tbuf)
         if (equal (tbuf, fncn) == YES) {
%%E 12
            call skpblk
            t = deftok (fcname, MAXNAME)
            call pbstr (fcname)
            if (t != ALPHA)
%%D 14
               call synerr ("missing function name.")
%%E 14
%%I 14
               call synerr ("missing function name")
%%E 14
            call putbak (' ')
            return
            }
%%D 12
         else if (equal (token, incl) == NO)
%%E 12
%%I 12
         else if (equal (tbuf, incl) == NO)
%%E 12
            return
         # process 'include' statements:
         call skpblk
         t = deftok (name, MAXNAME)
%%D 6
         if (t == ''' | t == '"') {
%%E 6
%%I 6
%%D 12
         if (t == '@'' | t == '"') {
%%E 12
%%E 6
%%I 12
         if (t == '"') {
%%E 12
            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)
%%D 14
            call synerr ("includes nested too deeply.")
%%E 14
%%I 14
            call synerr ("includes nested too deeply")
%%E 14
         else {
            infile (level + 1) = open (name, READ)
            linect (level + 1) = 1
            if (infile (level + 1) == ERR)
        enddef

%%D 14
               call synerr ("can't open include.")
%%E 14
%%I 14
               call synerr ("can't open include")
%%E 14

        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
%%I 12
%%D 13
#-h- getund           400  asc  17-feb-83 09:06:38  sventek (joseph sventek)
%%E 13
%%I 13
%%D 14
#-h- getund           400  asc  09-may-83 09:18:04  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
#-h- getund           397  asc  15-jun-83 15:49:48  sventek (joseph sventek)
%%E 14
# getund - get name for undefine statement

subroutine getund(token)

character token(MAXTOK), temp(4)

ext_func character gctok

call skpblk
if (gctok(token, MAXTOK) != '(')
%%D 13
   call baderr("missing '(' in undefine.")
%%E 13
%%I 13
%%D 14
   call baderr("missing `(' in undefine.")
%%E 14
%%E 13
%%I 14
   call baderr("missing `(' in undefine")
%%E 14
call skpblk
if (gctok(token, MAXTOK) != ALPHA)
%%D 14
   call baderr("non-alphanumeric name.")
%%E 14
%%I 14
   call baderr("non-alphanumeric name")
%%E 14
call skpblk
if (gctok(temp, 4) != ')')
%%D 13
   call baderr("missing ')' in undefine.")
%%E 13
%%I 13
%%D 14
   call baderr("missing `)' in undefine.")
%%E 14
%%E 13
%%I 14
   call baderr("missing `)' in undefine")
%%E 14

return
end
%%E 12
#-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
%%D 11
#-h- gtok            6114  asc  16-dec-81 23:22:41  sventek (joseph sventek)
%%E 11
%%E 10
%%I 11
%%D 12
#-h- gtok            4789  asc  13-jan-83 11:40:02  sventek (joseph sventek)
%%E 12
%%E 11
%%I 12
%%D 13
#-h- gtok            4869  asc  17-feb-83 07:58:33  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
%%D 14
#-h- gtok            6590  asc  05-may-83 13:30:38  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
%%D 15
#-h- gtok            6586  asc  15-jun-83 15:49:50  sventek (joseph sventek)
%%E 15
%%E 14
%%I 15
#-h- gtok            6592  asc  21-jul-83 15:30:25  sventek (joseph sventek)
%%E 15
# gtok - get token for Ratfor

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

   include COMMON_BLOCKS

   character c
%%I 13
ifdef(DO_CHAR_DECL)
   character temp(10)
enddef
%%E 13
   integer i, b, n, d

%%D 13
   ext_func character ngetch, type, clower, esc
%%E 13
%%D 6
   ext_func integer itoc, index
%%E 6
%%I 6
%%I 13
   ext_func character ngetch, clower, esc
%%E 13
   ext_func integer itoc, index, ctoi
%%E 6
%%I 13
ifdef(DO_CHAR_DECL)
   ext_func integer gennam
enddef
%%E 13
   ext_subr putbak, synerr, relate

%%I 13
ifnotdef(IS_LETTER)
   character ctype
   ext_func character type
enddef

%%E 13
   string digits "0123456789abcdefghijklmnopqrstuvwxyz"
%%I 10
   string alfchr ALPHA_CHARACTERS
%%E 10
%%I 13
ifdef(DO_CHAR_DECL)
   string chroot "ch"
enddef
%%E 13

   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
%%I 13
ifdef(IS_LETTER)
%%E 13
   if (IS_LETTER(c)) {    # alpha
%%I 13
elsedef
   if (type(c) == LETTER) {	# alpha
enddef
%%E 13
      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
%%I 13
ifdef(IS_LETTER)
%%E 13
         if (!IS_LETTER(c) & !IS_DIGIT(c) & index(alfchr, c) == 0)
%%E 10
%%I 13
elsedef
         ctype = type(c)
         if (ctype != LETTER & ctype != DIGIT & index(alfchr, c) == 0)
enddef
%%E 13
            break
         }
      call putbak (c)
      gtok = ALPHA
      }

%%I 13
ifdef(IS_DIGIT)
%%E 13
   else if (IS_DIGIT(c)) {   # digits
%%D 6
      b = c - '0' # in case alternate base number
%%E 6
%%I 13
elsedef
   else if (type(c) == DIGIT) {	# digits
enddef
%%E 13
      for (i = 1; i < toksiz - 2; i = i + 1) {
         c = ngetch (lexstr (i + 1))
%%D 6
         if (!IS_DIGIT(c))
%%E 6
%%I 6
%%D 12
         if (c == '_')				# permit embedded underscores
            i = i - 1
         else if (!IS_DIGIT(c))
%%E 12
%%E 6
%%I 12
%%I 13
ifdef(IS_DIGIT)
%%E 13
         if (!IS_DIGIT(c))
%%E 12
%%I 13
elsedef
         if (type(c) != DIGIT)
enddef
%%E 13
            break
%%D 6
         b = 10 * b + c - '0'
%%E 6
         }
%%I 6
%%D 12
      if (c == RADIX) {                      # possibly n%ddd
%%E 12
%%I 12
%%D 13
      if (c == RADIX | c == 'h' | c == 'H') {# n%ddd or nh... (nH...)
%%E 13
%%E 12
%%I 13
      if (c == RADIX) {                      # n%ddd
%%E 13
         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
%%D 12
            if (c == '_')
               next
            else if (d < 0)
%%E 12
%%E 6
%%I 12
            if (d < 0)
%%E 12
               break
            n = b * n + d
            }
         call putbak (c)
         i = itoc (n, lexstr, toksiz)
         }
%%I 12
%%D 13
      else if (c == 'h' | c == 'H')		# handle hollerith
         {
         i = i + 1
         lexstr(i) = c
         while (b > 0)
            {
            if (ngetch(c) == EOF)
               {
               call putbak(c)
               break
               }
            i = i + 1
            lexstr(i) = c
            b = b - 1
            }
         }
%%E 13
%%E 12
      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
%%D 11
#   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
#            }
#         }
#      }
%%E 11
   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
%%D 14
            call synerr ("missing quote.")
%%E 14
%%D 6
            lexstr (i) = lexstr (1)
            call putbak ('@n')
%%E 6
%%I 6
%%I 14
            call synerr ("missing quote")
%%E 14
            lexstr(i) = lexstr(1)
            call putbak('@n')
%%E 6
            break
            }
         }
%%I 6
%%D 11
      if (lexstr(1) == '@'') {			# see if character constant
%%E 11
%%I 11
      if (lexstr(1) == '@'') {			# character constant
%%E 11
         n = 2
         c = esc(lexstr, n)
%%D 11
         if (lexstr(n + 1) == '@'') {		# YES, convert it
%%E 11
%%I 11
%%D 12
ifdef(F77_CHARACTER_STRINGS)
         if (lexstr(n + 1) == '@'') {		# character constant
elsedef
%%E 12
         if (lexstr(n + 1) != '@'')		# flag old style string literal
%%D 14
            call synerr("missing apostrophe in character literal.")
%%E 14
%%D 12
enddef
%%E 12
%%E 11
%%D 13
            n = c
            i = itoc(n, lexstr, toksiz)		# convert to characters
            gtok = DIGIT
%%E 13
%%I 11
%%D 12
ifdef(F77_CHARACTER_STRINGS)
%%E 12
%%E 11
%%D 12
            }
%%E 12
%%I 11
%%D 12
enddef
%%E 12
%%E 11
%%I 13
%%I 14
            call synerr("missing apostrophe in character literal")
%%E 14
ifdef(DO_CHAR_DECL)
         lexstr(n+2) = EOS
         call scopy(lexstr, 1, temp, 1)
         i = gennam(chroot, chrcnt, lexstr)
%%D 15
         call insdcl(lexstr, temp)
%%E 15
%%I 15
         call insdcl(lexstr, temp, '@'')
%%E 15
         gtok = ALPHA
elsedef
         n = c
         i = itoc(n, lexstr, toksiz)		# convert to characters
         gtok = DIGIT
enddef
%%E 13
         }
%%E 6
      }

%%I 13
   else if (c == '%') {   # possible literal quote
      if (ngetch(lexstr(2)) != '(') {          # not literal quote
         call putbak(lexstr(2))
         gtok = '%'
         }
      else {
         gtok = '"'
         lexstr(1) = LITQUOTEC
         for (i = 2; ngetch(c) != EOF; i = i + 1) {
            lexstr(i) = c
            if (c == '_') {                   # possible continuation
               if (ngetch(c) == '@n') {       # YES it is
                  while (c == '@n' | c == ' ' | c == '@t')
                     c = ngetch(c)
                  lexstr(i) = c
                  }
               else
                  call putbak(c)
               c = lexstr(i)
               }
            if (c == '%')                     # are we done?
               if (ngetch(c) == ')') {        # YES
                  lexstr(i) = LITQUOTEC
                  break
                  }
               else
                  call putbak(c)
            if (lexstr(i) == '@n' | i >= toksiz - 1) {
%%D 14
               call synerr("missing literal quote.")
%%E 14
%%I 14
               call synerr("missing literal quote")
%%E 14
               lexstr(i) = LITQUOTEC
               call putbak('@n')
               break
               }
            }
         }
      }

   else if (c == LITQUOTEC) {			# pushed back literal quote
      gtok = '"'
      for (i = 2; ngetch(lexstr(i)) != LITQUOTEC; i = i + 1)
         ;
      }

%%E 13
   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)
%%D 14
      call synerr ("token too long.")
%%E 14
%%I 14
      call synerr ("token too long")
%%E 14
   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
%%D 14
#-h- ifgo             394  asc  25-mar-82 08:23:23  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- ifgo             394  asc  15-jun-83 15:49:54  sventek (joseph sventek)
%%E 14
# 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
%%D 12
#-h- ifparm           729  asc  25-mar-82 08:23:25  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
%%D 13
#-h- ifparm           750  asc  02-feb-83 09:44:14  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
#-h- ifparm           747  asc  12-apr-83 16:41:21  sventek (joseph sventek)
%%E 13
# 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 |
%%D 12
    c == MACTYPE)
%%E 12
%%I 12
%%D 13
    c == MACTYPE | c == HOLLERITHTYPE)
%%E 13
%%E 12
%%I 13
    c == MACTYPE | c == LENTOKTYPE)
%%E 13
      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
%%D 13
#-h- initkw           777  asc  25-mar-82 08:23:26  v1.1 (sw-tools v1.1)
%%E 13
%%I 13
#-h- initkw           856  asc  22-mar-83 11:49:39  sventek (joseph sventek)
%%E 13
# 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

%%I 13
ifdef(DO_PASS1)
   strcnt = 1
ifdef(DO_CHAR_DECL)
   chrcnt = 1
enddef
enddef

%%E 13
   return
   end
%%I 13
%%D 15
#-h- insdcl          1352  asc  22-mar-83 13:38:53  sventek (joseph sventek)
%%E 15
%%I 15
#-h- insdcl          1237  asc  21-jul-83 15:30:29  sventek (joseph sventek)
%%E 15
ifdef(DO_PASS1)
# insdcl - insert declaration information - will be dumped by dmpdcl
%%D 15
subroutine insdcl(name, value)
%%E 15
%%I 15
subroutine insdcl(name, value, c)
%%E 15

%%D 15
character name(ARB), value(ARB)
%%E 15
%%I 15
character name(ARB), value(ARB), c
%%E 15

%%D 15
character c, temp(10)
%%E 15
%%I 15
character temp(10)
%%E 15
integer strip, dosize, len, junk, first, last, i

ext_func integer index, elenth, itoc, length

include COMMON_BLOCKS

%%D 15
c = '"'				# assume "..." string
strip = NO			# assume no leading and trailing " in value
if (value(1) == '"' | value(1) == '@'')
   {
   c = value(1)
%%E 15
%%I 15
if (value(1) == c)
%%E 15
   strip = YES
%%D 15
   }
%%E 15
%%I 15
else
   strip = NO
%%E 15
dosize = YES			# must calculate size
if (index(name, '(') > 0 | c == '@'')	# size specified by user or char litral
   dosize = NO
%%D 16
call addchr(c, sbuf, sbp, SBUFSIZE)	# store type of declaration
call addstr(name, sbuf, sbp, SBUFSIZE)	# variable name
%%E 16
%%I 16
call inschr(c, sbuf, sbp, SBUFSIZE)	# store type of declaration
call insstr(name, sbuf, sbp, SBUFSIZE)	# variable name
%%E 16
if (dosize == YES)			# insert (len)
   {
   len = elenth(value)
   if (strip == YES)
      len = len - 2			# do not count delimiter
   if (c == '"')			# need location for EOS
      len = len + 1
%%D 16
   call addchr('(', sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
   call inschr('(', sbuf, sbp, SBUFSIZE)
%%E 16
   junk = itoc(len, temp, 10)
%%D 16
   call addstr(temp, sbuf, sbp, SBUFSIZE)
   call addchr(')', sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
   call insstr(temp, sbuf, sbp, SBUFSIZE)
   call inschr(')', sbuf, sbp, SBUFSIZE)
%%E 16
   }
%%D 16
call addchr(EOS, sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
call inschr(EOS, sbuf, sbp, SBUFSIZE)
%%E 16
first = 1
last = length(value)
if (strip == YES)
   {
   first = first + 1
   last = last -1
   }
for (i = first; i <= last; i = i + 1)
   {
%%D 16
   call addchr(value(i), sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
   call inschr(value(i), sbuf, sbp, SBUFSIZE)
%%E 16
   }
%%D 16
call addchr(EOS, sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
call inschr(EOS, sbuf, sbp, SBUFSIZE)
%%E 16

return
end
enddef
%%E 13
%%D 14
#-h- labelc           446  asc  25-mar-82 08:23:28  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- labelc           445  asc  15-jun-83 15:49:56  sventek (joseph sventek)
%%E 14
# 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')
%%D 14
         call synerr ("warning: possible label conflict.")
%%E 14
%%I 14
         call synerr ("warning: possible label conflict")
%%E 14
   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
%%D 12
#-h- lex              547  asc  25-mar-82 08:23:30  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
%%D 13
#-h- lex              605  asc  02-feb-83 12:00:22  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
#-h- lex              610  asc  05-may-83 13:30:42  sventek (joseph sventek)
%%E 13
# lex - return lexical type of token

   integer function lex (lexstr)
   character lexstr (MAXTOK)

   include COMMON_BLOCKS

   ext_func character gnbtok
   ext_func integer lookup

%%D 12
   for (lex = gnbtok (lexstr, MAXTOK); lex == '@n';
    lex = gnbtok (lexstr, MAXTOK))
      ;
%%E 12
%%I 12
   repeat {
      lex = gnbtok (lexstr, MAXTOK)
      if (lex != '@n')
        break
      }
%%E 12
   if (lex == EOF | lex == ';' | lex == '{' | lex == '}')
      return
   if (lex == DIGIT)
      lex = LEXDIGITS
   else if (lex == TOGGLE)
      lex = LEXLITERAL
%%D 12
   else if (lookup (lexstr, lex, rkwtbl) == YES)
      ;
   else
      lex = LEXOTHER
%%E 12
%%I 12
   else {
%%D 13
      call strcpy(lexstr, scrtok)
%%E 13
%%I 13
      call scopy(lexstr, 1, scrtok, 1)
%%E 13
      call fold(scrtok)
      if (lookup (scrtok, lex, rkwtbl) == NO)
         lex = LEXOTHER
      }
%%E 12

   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
%%D 13
#-h- lodsym           765  asc  25-mar-82 08:23:33  v1.1 (sw-tools v1.1)
%%E 13
%%I 13
%%D 14
#-h- lodsym           502  asc  13-may-83 08:13:11  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
#-h- lodsym           501  asc  15-jun-83 15:49:57  sventek (joseph sventek)
%%E 14
 # lodsym - load standard definitions file
 
ifnotdef (DO_BOOTSTRAP)
 subroutine lodsym(fbuf)
 
 include COMMON_BLOCKS
 
 character fbuf(FILENAMESIZE)

%%D 13
 ext_func integer open, loccom
 ext_subr impath, remark, parse, close
%%E 13
%%I 13
 ext_func integer open
 ext_subr remark, parse, close
%%E 13
 
%%D 13
 string defns STDEFNS		# name of standard definitions file
 string suffix NO_SUFFIX
 
 if (defns(1) != EOS)
%%E 13
%%I 13
 call locsym(fbuf)		# locate file with standard definitions
 if (fbuf(1) != EOS)
%%E 13
   {
%%D 13
   call impath(fnames)		# get standard search path :~home:~usr:~bin
   if (loccom(defns, fnames, suffix, fbuf) == ASCII)
%%E 13
%%I 13
   infile(1) = open(fbuf, READ)
   if (infile(1) == ERR)
%%D 14
     call remark("cannot open standard definitions file.")
%%E 14
%%I 14
     call remark("cannot open standard definitions file")
%%E 14
   else
%%E 13
     {
%%D 13
     infile(1) = open(fbuf, READ)
     if (infile(1) == ERR)
       call remark("cannot open standard definitions file.")
     else
       {
       call parse
       call close(infile(1))
       }
%%E 13
%%I 13
     call parse
     call close(infile(1))
%%E 13
     }
%%D 13
   else
     call remark("cannot locate standard definitions file.")
%%E 13
   }
 
 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
%%D 13
#-h- otherc           368  asc  25-mar-82 08:23:36  v1.1 (sw-tools v1.1)
%%E 13
%%I 13
#-h- otherc           515  asc  03-may-83 09:50:58  sventek (joseph sventek)
%%E 13
# otherc - output ordinary Fortran statement

   subroutine otherc (lexstr)
   character lexstr (ARB)

   include COMMON_BLOCKS

   ext_subr outtab, squash, outstr, eatup, outdon

%%I 13
ifnotdef(IS_LETTER)
   ext_func character type
enddef

%%E 13
   xfer = NO
   call outtab

%%D 13
  ifdef (DO_LONGNAME)
%%E 13
%%I 13
ifdef (DO_LONGNAME)
ifdef (IS_LETTER)
%%E 13
   if (IS_LETTER(lexstr (1)))
%%I 13
elsedef
   if (type (lexstr(1)) == LETTER)
enddef		# IS_LETTER
%%E 13
      call squash (lexstr)
%%D 13
  enddef
%%E 13
%%I 13
enddef		# DO_LONGNAME
%%E 13

   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
%%I 12
#-h- outdef           306  asc  01-feb-83 10:57:47  sventek (joseph sventek)
# output defined value of string `str'
subroutine outdef(str, tok)

character str(ARB), tok(MAXTOK), t

ext_func character gnbtok

call putbak('/')		# push back delimiter
call pbstr(str)			# push back string
repeat
  {
  t = gnbtok(tok, MAXTOK)
  if (t == '/')
    break
  call outstr(tok)
  }

return
end
%%E 12
#-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
%%D 11
#-h- outstr          1347  asc  16-dec-81 22:59:16  sventek (joseph sventek)
%%E 11
%%E 10
%%I 11
%%D 12
#-h- outstr          1233  asc  13-jan-83 11:40:08  sventek (joseph sventek)
%%E 12
%%E 11
%%I 12
%%D 13
#-h- outstr          1201  asc  17-feb-83 09:19:39  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
%%D 15
#-h- outstr          1108  asc  28-apr-83 09:41:32  sventek (joseph sventek)
%%E 15
%%E 13
%%I 15
#-h- outstr          1113  asc  21-jul-83 15:30:32  sventek (joseph sventek)
%%E 15
# outstr - output string; handles quoted literals

   subroutine outstr (str)
   character str (ARB)

%%D 13
   character c
%%E 13
%%D 12
   integer i, j, n
%%E 12
%%I 12
%%D 13
   integer i, j, n, f77out
   pointer value
%%E 13
%%E 12
%%I 13
ifdef(DO_PASS1)
   character varbuf(incr(MAXIDLENGTH))
enddef
   integer i, n
%%E 13

%%I 12
   include COMMON_BLOCKS

%%E 12
%%D 13
   ext_func character cupper
%%E 13
%%D 12
   ext_func integer length
%%E 12
%%I 12
%%D 13
   ext_func integer length, lookup
%%E 13
%%E 12
%%D 13
   ext_subr outch, outnum
%%E 13
%%I 13
   ext_func integer qstfix
ifdef(DO_PASS1)
   ext_func integer gennam
enddef
   ext_subr outch, outnum, strout
%%E 13

%%D 6
   if (str(1) != '"')	# not a quoted string
%%E 6
%%I 6
%%D 12
   if (str(1) != '"' & str(1) != '@'')	# not a quoted string
%%E 12
%%E 6
%%I 12
%%D 13
   string f77sym "F77_CHARACTER_STRINGS"
%%E 13
%%I 13
ifdef(DO_PASS1)
   string stroot "st"
enddef
%%E 13

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

         ifdef (UPPERC)
%%E 13
%%D 12
            call outch (cupper(c))
         elsedef
            call outch(c)
%%E 12
%%I 12
%%D 13
            if (!IS_DIGIT(str(1)))
               c = cupper(c)
%%E 13
%%E 12
%%D 13
         enddef

%%E 13
%%I 12
%%D 13
         call outch(c)
%%E 13
%%E 12
%%D 13
         }
%%E 13
%%I 10
%%D 12
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 12
%%E 10
%%I 13
   if (str(1) == LITQUOTEC)             # literal quoted string
      for (i = 2; str(i) != LITQUOTEC; i = i + 1)
         call outch(str(i))
   else if (str(1) != '"')		# not a quoted string
      call strout(str, YES)		# output string, uppercase if defined
%%E 13
   else
      {
%%D 13
      j = length(str)
%%E 13
%%I 6
%%D 12
      c = str(1)
%%E 12
%%E 6
%%D 11
      for ([i=2; n=0]; i < j; i=i+1)
%%E 11
%%D 6
         if (str(i) == '"')
%%E 6
%%I 6
%%D 11
         if (str(i) == c)
%%E 11
%%E 6
%%D 11
            break
         else if (str(i) == '@@')
            {
%%E 11
%%D 6
            if (str(i+1) == '"')
%%E 6
%%I 6
%%D 11
            if (str(i+1) == c)
%%E 11
%%E 6
%%D 11
               i = i + 1
            n = n + 1
            }
         else
            n = n + 1
%%E 11
%%I 11
%%D 12
      for (i=2, n=0; i < j; i=i+1)
%%E 12
%%I 12
%%D 13
      n = 0
      for (i=2; i < j; i=i+1)
%%E 13
%%E 12
%%D 13
         {
%%E 13
%%D 12
         if (str(i) == '@@' & str(i+1) == c)
%%E 12
%%I 12
%%D 13
         if (str(i) == '@@' & str(i+1) == '"')
%%E 13
%%E 12
%%D 13
            i = i + 1
         n = n + 1
         }
%%E 13
%%E 11
%%D 12
      call outnum (n)
      call outch('H')
%%E 12
%%I 12
%%D 13
      f77out = lookup(f77sym, value, deftbl)	# see if wants f77 strings
      if (f77out == YES)
         call outch('@'')
      else
         {
         call outnum (n)
         call outch('H')
         }
%%E 13
%%E 12
%%D 13
      for (i=2; i < j; i = i + 1)
         {
%%E 13
%%D 6
         if (str(i) == '@@' & str(i+1) == '"')
%%E 6
%%I 6
%%D 12
         if (str(i) == '@@' & str(i+1) == c)
%%E 12
%%E 6
%%I 12
%%D 13
         if (str(i) == '@@' & str(i+1) == '"')
%%E 13
%%E 12
%%D 13
            i = i + 1
         call outch(str(i))
         }
%%E 13
%%I 12
%%D 13
      if (f77out == YES)
         call outch('@'')
%%E 13
%%E 12
%%I 13
      n = qstfix(str)

ifdef (DO_PASS1)			# output declaration and data stmts
      i = gennam(stroot, strcnt, varbuf)
%%D 15
      call insdcl(varbuf, str)
%%E 15
%%I 15
      call insdcl(varbuf, str, '"')
%%E 15
      call strout(varbuf, YES)
enddef

ifdef (DO_F77_STRINGS)			# output F77 string
      call outch('@'')
      call strout(str, NO)
      call outch('@'')
enddef

ifdef (DO_HOLLERITH)			# output Hollerith string
      call outnum(n)
      call outch('H')
      call strout(str, NO)
enddef

%%E 13
      }
%%I 13

%%E 13
   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
%%D 12
#-h- parse           3035  asc  25-mar-82 08:23:42  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
%%D 13
#-h- parse           3045  asc  17-feb-83 09:30:45  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
%%D 14
#-h- parse           3161  asc  18-mar-83 16:16:49  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
#-h- parse           3155  asc  15-jun-83 15:50:03  sventek (joseph sventek)
%%E 14
# 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
%%D 12
   for (token = lex (lexstr); token != EOF; token = lex (lexstr)) {
%%E 12
%%I 12
   repeat {
%%I 13
ifdef(DO_PASS1)
      if (sbp > 1)			# accumulated declarations?
         call dmpdcl(lexstr)		# output them
enddef
%%E 13
      token = lex (lexstr)
      if (token == EOF)
         break
%%E 12
      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)
%%D 14
            call synerr ("illegal case or default.")
%%E 14
%%I 14
            call synerr ("illegal case or default")
%%E 14
         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
%%D 14
            call synerr ("illegal else.")
%%E 14
%%I 14
            call synerr ("illegal else")
%%E 14
         }
      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)
%%D 14
            call baderr ("stack overflow in parser.")
%%E 14
%%I 14
            call baderr ("stack overflow in parser")
%%E 14
         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
%%D 14
               call synerr ("illegal right brace.")
%%E 14
%%I 14
               call synerr ("illegal right brace")
%%E 14
            }
         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)
%%D 14
      call synerr ("unexpected EOF.")
%%E 14
%%I 14
      call synerr ("unexpected EOF")
%%E 14
   if (csp > 0)
%%D 14
      call synerr("conditional processing still active at EOF.")
%%E 14
%%I 14
      call synerr("conditional processing still active at EOF")
%%E 14

   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
%%D 14
#-h- push             269  asc  25-mar-82 08:23:44  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- push             268  asc  15-jun-83 15:50:05  sventek (joseph sventek)
%%E 14
# 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)
%%D 14
      call baderr ("arg stack overflow.")
%%E 14
%%I 14
      call baderr ("arg stack overflow")
%%E 14
   argstk (ap) = ep
   push = ap + 1
   return
   end
%%D 14
#-h- putbak           280  asc  25-mar-82 08:23:44  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- putbak           279  asc  15-jun-83 15:50:06  sventek (joseph sventek)
%%E 14
# putbak - push character back onto input

   subroutine putbak (c)
   character c

   include COMMON_BLOCKS

   ext_subr baderr

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

   return
   end
%%D 14
#-h- putchr           253  asc  25-mar-82 08:23:45  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- putchr           252  asc  15-jun-83 15:50:06  sventek (joseph sventek)
%%E 14
# putchr - put single char into eval stack

   subroutine putchr (c)
   character c

   include COMMON_BLOCKS

   ext_subr baderr

   if (ep > EVALSIZE)
%%D 14
      call baderr ("evaluation stack overflow.")
%%E 14
%%I 14
      call baderr ("evaluation stack overflow")
%%E 14
   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
%%I 12
%%D 13
#-h- ratarg           454  asc  17-dec-81 00:10:24  sventek (joseph sventek)
%%E 13
%%I 13
#-h- qstfix           508  asc  17-mar-83 23:37:56  sventek (joseph sventek)
# qstfix - fix quoted string
# collapses quoted string in the same array, removing first and last quotes
# and converting intermediate @" ==> "
# returns the length of the string as its value
integer function qstfix(str)

character str(ARB)
integer last, n, i
integer length

last = length(str)
n = 1
for (i = 2; i < last; i = i + 1)
  {
  if (str(i) == '@@')
    if (str(i+1) == '"')		# found intermediate @"
      i = i + 1
  str(n) = str(i)			# copy character
  n = n + 1
  }
str(n) = EOS
return(n-1)
end
#-h- ratarg           425  asc  06-may-83 16:54:37  sventek (joseph sventek)
%%E 13
# ratarg - routine to crack command line flags to ratfor
%%I 13
ifnotdef(DO_BOOTSTRAP)
%%E 13
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
%%D 13
    {
    select (scrtok(2))
      {
      case 'n', 'N':	dosym = NO		# user does not want symbols
      default:		;			# ignore others
      }
    }
%%E 13
%%I 13
    if (scrtok(2) == 'n' | scrtok(2) == 'N')	# user does not want ratdef
      dosym = NO
%%E 13

return
end
%%E 12
%%I 13
enddef
%%E 13
#-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
%%D 12
#-h- skpblk           275  asc  25-mar-82 08:23:53  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
#-h- skpblk           268  asc  17-feb-83 09:30:49  sventek (joseph sventek)
%%E 12
# skpblk - skip blanks and tabs in current input file

   subroutine skpblk

   include COMMON_BLOCKS

   character c

   ext_func character ngetch
   ext_subr putbak

%%D 12
   for (c = ngetch (c); c == ' ' | c == '@t'; c = ngetch (c))
      ;
%%E 12
%%I 12
   repeat
      c = ngetch (c)
   until (c != ' ' & c != '@t')
%%E 12

   call putbak (c)
   return
   end
%%D 12
#-h- squash          1589  asc  25-mar-82 08:23:55  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
%%D 13
#-h- squash          1760  asc  15-mar-83 12:15:35  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
%%D 14
#-h- squash          1948  asc  05-may-83 13:30:48  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
#-h- squash          1948  asc  15-jun-83 15:50:09  sventek (joseph sventek)
%%E 14
# 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
%%D 12
   character newid (MAXTOK), recdid (MAXTOK)
%%E 12
%%I 12
   character newid (MAXTOK), lowcid (MAXTOK), recdid(incr(MAXIDLENGTH))
%%E 12

   ext_func integer lookup
   ext_subr scopy, uniqid, entdef

%%I 13
ifnotdef(IS_LETTER)
   character ctype
   ext_func character type
enddef

%%E 13
   j = 1
%%D 12
   for (i = 1; id (i) != EOS; i = i + 1)
%%E 12
%%I 12
   for (i = 1; id (i) != EOS; i = i + 1) {
      lowcid(i) = id(i)
%%E 12
%%I 13
ifdef(IS_LETTER)
%%E 13
      if (IS_LETTER(id (i)) | IS_DIGIT(id (i))) {
%%I 13
elsedef
      ctype = type(id(i))
      if (ctype == LETTER | ctype == DIGIT) {
enddef
%%E 13
         newid (j) = id (i)
         j = j + 1
         }
%%I 12
      }
   lowcid(i) = EOS
%%E 12
   newid (j) = EOS

%%D 12
   if (i - 1 < MAXIDLENGTH & i == j)
%%E 12
%%I 12
   if (i < incr(MAXIDLENGTH) & i == j)
%%E 12
      return      # an ordinary (short) Fortran variable
%%D 12
   if (i - 1 == MAXIDLENGTH & i == j)
%%E 12
%%I 12
   if (i == incr(MAXIDLENGTH) & i == j)
%%E 12
      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.

%%D 12
   if (lookup (id, junk, fkwtbl) == YES)  # Fortran key word?
%%E 12
%%I 12
   call fold(lowcid)			  # convert to lower case
   if (lookup (lowcid, junk, fkwtbl) == YES)  # Fortran key word?
%%E 12
      return                              # (must be treated as reserved)

%%D 12
   if (ludef (id, recdid, namtbl) == YES) {   # have we seen this before?
      call scopy (recdid, 1, id, 1)
%%E 12
%%I 12
   if (ludef (lowcid, recdid, namtbl) == YES) {   # have we seen this before?
%%D 13
      call strcpy(recdid, id)
%%E 13
%%E 12
%%I 13
      call scopy(recdid, 1, id, 1)
%%E 13
      return
      }

%%I 12
   call fold (newid)	# all lower case
%%E 12
   call uniqid (newid)  # get an identifier never before seen
%%D 12
   call entdef (id, newid, namtbl)  # record it for posterity
   call scopy (newid, 1, id, 1)  # and substitute it for the old one
%%E 12
%%I 12
   call entdef (lowcid, newid, namtbl)  # record it for posterity
%%D 13
   call strcpy(newid, id)		# and substitute it for the old one
%%E 13
%%E 12
%%I 13
   call scopy(newid, 1, id, 1)		# and substitute it for the old one
%%E 13

   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
%%D 12
#-h- strdcl          2712  asc  19-oct-82 17:20:08  sventek (joseph sventek)
%%E 12
%%E 6
%%I 12
%%D 13
#-h- strdcl          2477  asc  01-feb-83 10:57:42  sventek (joseph sventek)
%%E 13
%%E 12
%%I 13
%%D 14
#-h- strdcl          2940  asc  18-mar-83 16:16:53  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
%%D 15
#-h- strdcl          2935  asc  15-jun-83 15:50:11  sventek (joseph sventek)
%%E 15
%%E 14
%%I 15
#-h- strdcl          2940  asc  21-jul-83 15:30:37  sventek (joseph sventek)
%%E 15
# 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
%%D 16
   ext_subr synerr, squash, outtab, pbstr, outstr, outch, addstr, addchr
%%E 16
%%I 16
   ext_subr synerr, squash, outtab, pbstr, outstr, outch, insstr, inschr
%%E 16
   ext_subr outnum, outdon

%%D 12
   string char "character/"
%%E 12
%%I 12
   string char "character"
%%E 12
   string dat "data "
%%D 12
   string eoss "EOS/"
%%E 12
%%I 12
   string eoss "EOS"
%%E 12

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

  ifdef (DO_LONGNAME)
   call squash (scrtok)
  enddef

%%I 13
ifdef(DO_PASS1)
   if (gnbtok(dchar, MAXTOK) == '(')	# user-specified size
      {
      call concat(scrtok, dchar, scrtok)
      if (gnbtok(dchar, MAXTOK) != DIGIT)
%%D 14
         call synerr("invalid string size.")
%%E 14
%%I 14
         call synerr("invalid string size")
%%E 14
      call concat(scrtok, dchar, scrtok)
      if (gnbtok(dchar, MAXTOK) != ')')
%%D 14
         call synerr("missing right paren.")
%%E 14
%%I 14
         call synerr("missing right paren")
%%E 14
      call concat(scrtok, dchar, scrtok)
      t = gnbtok(dchar, MAXTOK)
      }
%%D 15
   call insdcl(scrtok, dchar)
%%E 15
%%I 15
   call insdcl(scrtok, dchar, '"')
%%E 15
elsedef
%%E 13
   call outtab
%%D 12
   call pbstr (char) # use defined meaning of "character"
   repeat {
      t = gnbtok (dchar, MAXTOK)
      if (t == '/')
         break
      call outstr (dchar)
      }
%%E 12
%%I 12
   call outdef(char, dchar)	# output defined meaning of "character"
%%E 12
   call outch (' ')  # separator in declaration
   call outstr (scrtok)
%%D 16
   call addstr (scrtok, sbuf, sbp, SBUFSIZE)  # save for later
   call addchr (EOS, sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
   call insstr (scrtok, sbuf, sbp, SBUFSIZE)  # save for later
   call inschr (EOS, sbuf, sbp, SBUFSIZE)
%%E 16
   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
%%D 12
      if (scrtok (1) == '@'' | scrtok (1) == '"')
%%E 12
%%E 6
%%I 12
      if (scrtok (1) == '"')
%%E 12
         len = len - 2
      }
   else { # form is string name (size) init
      t = gnbtok (scrtok, MAXTOK)
      i = 1
      len = ctoi (scrtok, i)
      if (scrtok (i) != EOS)
%%D 14
         call synerr ("invalid string size.")
%%E 14
%%I 14
         call synerr ("invalid string size")
%%E 14
      if (gnbtok (scrtok, MAXTOK) != ')')
%%D 14
         call synerr ("missing right paren.")
%%E 14
%%I 14
         call synerr ("missing right paren")
%%E 14
      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
%%D 12
   if (scrtok (1) == '@'' | scrtok (1) == '"') {
%%E 12
%%E 6
%%I 12
   if (scrtok (1) == '"') {
%%E 12
      len = length (scrtok)
      scrtok (len) = EOS
%%D 16
      call addstr (scrtok (2), sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
      call insstr (scrtok (2), sbuf, sbp, SBUFSIZE)
%%E 16
      }
   else
%%D 16
      call addstr (scrtok, sbuf, sbp, SBUFSIZE)
   call addchr (EOS, sbuf, sbp, SBUFSIZE)
%%E 16
%%I 16
      call insstr (scrtok, sbuf, sbp, SBUFSIZE)
   call inschr (EOS, sbuf, sbp, SBUFSIZE)
%%E 16
   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
            }
%%D 12
         call pbstr (eoss) # use defined meaning of EOS
         repeat {
            t = gnbtok (scrtok, MAXTOK)
            call outstr (scrtok)
            } until (t == '/')
%%E 12
%%I 12
         call outdef(eoss, scrtok)	# use defined meaning of "EOS"
         call outch('/')
%%E 12
         call outdon
         }
      sbp = 1
      }
%%I 13
enddef
%%E 13

   return
   end
%%I 5
%%D 13
#-h- swcode           839  asc  25-mar-82 08:23:48  v1.1 (sw-tools v1.1)
%%E 13
%%I 13
#-h- strout           319  asc  28-apr-83 09:41:44  sventek (joseph sventek)
# strout - output character array, upper-casing if desired
subroutine strout(str, ifup)

character str(ARB), c
integer ifup, i

ext_func character cupper

for (i = 1; str(i) != EOS; i = i + 1)
   {
   c = str(i)

ifdef (UPPERC)
   if (ifup == YES)
      c = cupper(c)
enddef	# UPPERC

   call outch(c)
   }

return
end
%%D 14
#-h- swcode          1026  asc  28-apr-83 09:41:38  sventek (joseph sventek)
%%E 14
%%E 13
%%I 14
#-h- swcode          1024  asc  15-jun-83 15:50:13  sventek (joseph sventek)
%%E 14
# 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

%%I 13
ifdef (DO_PASS1)
   string intstr "integer"
enddef

%%E 13
   lab = labgen (2)
   if (swlast + 3 > MAXSWITCH)
%%D 14
      call baderr ("switch table overflow.")
%%E 14
%%I 14
      call baderr ("switch table overflow")
%%E 14
   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
%%I 13

ifdef (DO_PASS1)
   call outtab	# Integer Innn
   call outstr (intstr)
   call outch (' ')
   call swvar (lab)
   call outdon
enddef

%%E 13
   call outgo (lab) # goto L
   xfer = YES
   while (gnbtok (scrtok, MAXTOK) == '@n')
      ;
   if (scrtok (1) != '{') {
%%D 14
      call synerr ("missing left brace in switch statement.")
%%E 14
%%I 14
      call synerr ("missing left brace in switch statement")
%%E 14
      call pbstr (scrtok)
      }
   return
   end
  enddef
%%D 14
#-h- swend           2799  asc  25-mar-82 08:23:49  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- swend           2799  asc  15-jun-83 15:50:15  sventek (joseph sventek)
%%E 14
# 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
%%D 12
#-h- synerr           742  asc  25-mar-82 08:24:02  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
#-h- synerr           828  asc  22-feb-83 15:39:51  sventek (joseph sventek)
%%E 12
# 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 "

%%I 12
   if (curcnd != C_TRUE)	# avoid error messages in non-preprocessed code
      return
%%E 12
   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
%%D 12
#-h- ulstal           295  asc  25-mar-82 08:24:03  v1.1 (sw-tools v1.1)
%%E 12
%%I 12
#-h- ulstal           333  asc  15-mar-83 12:15:39  sventek (joseph sventek)
%%E 12
# ulstal - install lower and upper case versions of symbol

%%D 12
   subroutine ulstal (name, defn)
   character name (ARB), defn (ARB)
%%E 12
%%I 12
   subroutine ulstal (name, val)
   character name (ARB), defn (2), val
%%E 12

   include COMMON_BLOCKS

   ext_subr entdef, upper

%%I 12
   defn (1) = val
   defn (2) = EOS
%%E 12
   call entdef (name, defn, deftbl)
   call upper (name)
   call entdef (name, defn, deftbl)

   return
   end
%%D 14
#-h- uniqid          1971  asc  25-mar-82 08:24:05  v1.1 (sw-tools v1.1)
%%E 14
%%I 14
#-h- uniqid          1969  asc  15-jun-83 15:50:17  sventek (joseph sventek)
%%E 14
# 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)
%%D 14
            call baderr ("cannot make identifier unique.")
%%E 14
%%I 14
            call baderr ("cannot make identifier unique")
%%E 14
         } 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)
%%D 14
      call synerr("No room for generated variable name.")
%%E 14
%%I 14
      call synerr("No room for generated variable name")
%%E 14

   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
%%D 12
#-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
%%E 12
%%D 11
#-h- ratfor.fmt     17425  asc  17-dec-81 00:27:41  sventek (joseph sventek)
%%E 11
%%E 10
%%I 11
%%D 13
#-h- ratfor.fmt     19775  asc  13-jan-83 13:24:33  sventek (joseph sventek)
%%E 13
%%E 11
%%I 13
%%D 14
#-h- locsym           522  asc  13-may-83 09:02:23  sventek (joseph sventek)
%%E 14
%%I 14
#-h- locsym           521  asc  15-jun-83 15:50:20  sventek (joseph sventek)
%%E 14
# locsym - locate standard definitions file

ifnotdef(DO_BOOTSTRAP)

subroutine locsym(file)

character file(FILENAMESIZE)

ifdef(NO_SUFFIX)

integer loccom

string path   STD_PATH
string suffix NO_SUFFIX

enddef	# NO_SUFFIX

string defns STDEFNS

call scopy(defns, 1, file, 1)

ifdef(NO_SUFFIX)

if (defns(1) != EOS)
   if (loccom(defns, path, suffix, file) != ASCII)
      {
      file(1) = EOS
%%D 14
      call synerr("Cannot locate standard definitions file.")
%%E 14
%%I 14
      call synerr("Cannot locate standard definitions file")
%%E 14
      }

enddef	# NO_SUFFIX

return
end

enddef	# DO_BOOTSTRAP
#-h- ratfor.fmt     24595  asc  13-may-83 07:48:30  sventek (joseph sventek)
%%E 13
.so ~bin/manhdr
.hd Ratfor (1) 21-Dec-81
RatFor preprocessor
.sy
%%D 10
ratfor [file] ... >outfile
%%E 10
%%I 10
%%I 13
ratp1 [-n] [file] ... | ratp2 >outfile
.sp
%%E 13
ratfor [-n] [file] ... >outfile
%%E 10
%%I 13
.sp
rat77 [-n] [file] ... >outfile
%%E 13
.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
%%D 11
                   repeat (expr) stmt
%%E 11
%%I 11
                   repeat stmt
%%E 11
                   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
%%D 11
                   switch (expr) | select (expr)
%%E 11
%%E 5
%%D 11
                   {
%%E 11
%%I 11
                   switch (expr) {
%%E 11
                     case expr: stmt
                     ...
                     default: stmt
%%D 11
                   }
%%E 11
%%I 11
                     }
%%E 11
                   digits stmt
                   { prog }  or  [ prog ]
                   other
           other:  anything unrecognizable (i.e. fortran)
           clause: other
%%D 11
                   {mother} or [mother]
           mother: other
                   other; mother
%%E 11
%%I 11
                   clause, other
%%E 11

.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.)

%%D 13
In addition to define, four other built-in macros are provided:
%%E 13
%%I 13
In addition to define, several other built-in macros are provided:
%%E 13

.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.
%%I 13
.ti -16
lentok(str)     pushes the length of the argument (# of characters) onto
the input as a character string.
.ti -16
undefine(sym)   removes the definition for the symbol `sym', if it is
defined.
%%E 13
.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


%%D 13
String Data Types:
%%E 13
%%I 13
String Declarations:
%%E 13

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.
%%D 13
If several string declarations appear consecutively, the
generated declarations for the arrays will precede the data
statements that initialize them.
%%E 13
The normal escape sequences are supported in strings; in addition, to
embed a quote (") in the string, one must type @".
%%I 13
.ne 5
%%E 13
.sp 2
String Literals:

%%D 13
Conversion of in-line quoted strings to hollerith constants is performed
in the following manner:

.in +5
%%E 13
%%I 13
The processing of in-line quoted strings ("..." appearing outside of the
scope of a `string' declaration) is dependent upon which version of the
processor you are using:
%%E 13
%%D 13
.nf
%%E 13
%%I 13
.sp
%%E 13
%%D 13
"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.
%%E 13
%%I 13
.in +7
.ti -7
ratfor "str" is converted to 3Hstr.  This action is identical to previous
versions of the pre-processor.
.sp
.ti -6
ratp1 "str" is converted to an appropriate declaration for a `character'
array, and the appropriate data statements are output.
The variable name will be of the form STNNNZ, where NNN is replaced by
a rotating sequence number.
The array will be declared long enough to place the value of EOS in the
last element, just as for the `string' declaration.
Since these declarations are output immediately, the resulting FORTRAN
code must be run through the program `ratp2', which will reorder the
code to be ANSI-66 compliant.
.sp
.ti -6
rat77 "str" is converted to the FORTRAN-77 constant 'str'.
It is expected that this version of the preprocessor will NOT automatically
load the standard symbols file, thus permitting the use of `rat77' to
preprocess F77 code.
.sp
.in -7
Regardless of the version used, string literals can be continued across line
boundaries by
ending the line to be continued with an underline.
%%E 13
The underline is not included as part of the literal.
Leading blanks and tabs on the next line are ignored.
%%D 13
If a quote (") is to be embedded in an hollerith string, one must type,
for example, "@"" ==> 1h".
%%E 13
%%I 13
If a quote (") is to be embedded in the string, it must be escaped, as in
.sp
.ce
"a quote (@") in a string"
.sp
In addition, the normal escape sequences are supported in the `ratp1' version.
%%E 13
.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
%%D 11
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 11
%%E 8
%%I 11
Note that this capability pre-empts the use of apostrophes for
delimiting string literals.
Attempts to pre-process programs utilitizing apostrophes for
string literals will generate syntax errors of the form:
.sp
.ce
missing apostrophe in character literal
.sp
An utility `ratfix' is available for quickly correcting such code.
%%E 11
.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.
%%I 13
.sp 2
Literal (unprocessed) Character Sequences:

Sequences of characters can be passed through the processor, thus avoiding
processing, by surrounding then with the tokens %(...%).
The surrounding %[()] tokens will be removed and the character sequence
will be output without change.
Macro invocations, long names, etc. appearing in the character sequence
will NOT be processed.
.sp 2
Long Variable Name Processing:
.sp
An optional capability available in the pre-processor, which may be enabled
by your local tools support individual, is the capability of converting
long variable names (those consisting of more than 6 alpha-numerics,
embedded underscores, or both) to 6 character ANSI-66 compliant variable
names.
If this option is available, and has been used in a pre-processing run,
a sequence of FORTRAN comment statements are output at the end of the
generated FORTRAN code, with the mapping of long names to generated
names.
.sp
It should be noted that this mapping is not deterministic across separate
compilations; as such, if `get_next_input' is compiled and placed in
a library, source invocations of `get_next_input' would not map into
the identical 6-character name.
To permit users to preload the long name table with the names of external
routines, the `linkage' statement may be used:
.sp
.ce
linkage long_name external_name
.sp
The pair of names is entered into the table of known long variable
names, preventing any generated names for local long variables from
colliding with the external name.
The programmer must provide accurate information via this statement to
permit access to routines with "long variable names" across
compilations.
.sp
If long variable name processing has not been enabled for your site,
linkage is synonymous with define.
.sp
NOTE: since long variable name processing is optional, its use will
generate code that is inherently non-portable to sites not desiring
this capability.
Users wishing to write portable code should avoid long variable names.
%%E 13
.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.

%%I 11
The 'switch' control statement has been included.

%%E 11
Continuation lines have been implemented.

Brackets have been allowed to replace braces
%%D 11
(but NOT $( and $) )
%%E 11
%%I 11
(but NOT '$(' and '$)' )
%%E 11

Character constants are now supported.

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

%%I 13
A method for allowing character sequences to pass through
un-processed has been added.

An `undefine' command has been added to permit removal of symbol
definitions.

Three types of literal character string processing are now possible.
The default action permanently eliminates the usage of Hollerith
constants in portable tools.

Long variable names processing can now be enabled as a site-dependent
option.

%%E 13
.fl
%%D 11
A generalized definition file (e.g. 'symbols') is automatically
%%E 11
%%I 11
A generalized definition file (e.g. 'ratdef') is automatically
%%E 11
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
%%I 11
%%D 13
.ti -3
arith error
%%E 13
%%I 13
.ti -5
o arith error
%%E 13
.br
An error occurred while evaluating the built-in macro, `arith'.
.br
%%E 11
.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
%%D 11
.ti -5
can't open standard definitions file
%%E 11
%%I 11
%%D 13
.ti -3
cannot open standard definitions file
%%E 13
%%E 11
%%I 13
.ti -5
* cannot make identifier unique
%%E 13
.br
%%I 13
All attempts to generate an unique short variable name for the long
variable name being processed failed.
This message will only be seen if the long variable name processing
has been enabled.
.br
.ti -5
o cannot open standard definitions file
.br
%%E 13
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
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
can't open include
%%E 13
%%I 13
.ti -5
o can't open include
%%E 13
.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
%%I 11
%%D 13
.ti -3
conditional processing still active at EOF
%%E 13
%%I 13
.ti -5
o conditional processing still active at EOF
%%E 13
.br
A sufficient number of "enddef" directives have not been encountered before
detecting EOF on the input file.
.br
%%E 11
.ti -5
%%I 11
* Conditionals nested too deeply
.br
The stack for nested conditionals has overflowed.
The size of the stack is specified by the value of COND_STACK_DEPTH defined
in the preprocessor symbols file.
.br
.ti -5
%%E 11
* 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
%%I 11
%%D 13
.ti -3
duplicate case label
%%E 13
%%I 13
.ti -5
o duplicate case label
%%E 13
.br
Two case labels with identical values were detected.
.br
%%E 11
.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
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
illegal break
%%E 13
%%I 13
.ti -5
o illegal break
%%E 13
.br
Break did not occur inside a valid "while", "for", or "repeat" loop
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
illegal case or default
%%E 13
%%I 13
.ti -5
o illegal case or default
%%E 13
.br
A "case" or "default" statement was detected which was not in the scope of
a "switch" statement.
.br
%%D 13
.ti -3
illegal case syntax
%%E 13
%%I 13
.ti -5
o illegal case syntax
%%E 13
.br
The case label was not of the correct form.
It may consist of comma-separated constants or ranges of constants.
.br
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
illegal else
%%E 13
%%I 13
.ti -5
o illegal else
%%E 13
.br
Else clause probably did not follow an "if" clause
.br
.ti -5
%%I 11
* Illegal enddef encountered
.br
An "enddef" directive was encountered while conditional preprocessing was
inactive.
.br
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
illegal next
%%E 13
%%I 13
.ti -5
o illegal next
%%E 13
.br
"Next" did not occur inside a valid "for", "while", or "repeat" loop
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
illegal range in case label
%%E 13
%%I 13
.ti -5
o illegal range in case label
%%E 13
.br
A case label specifying a range of values (of the form m-n) was detected in
which m > n.
.br
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
illegal right brace
%%E 13
%%I 13
.ti -5
o illegal right brace
%%E 13
.br
A right brace was found without a matching left brace
.br
%%D 11
.ti -5
* in dsget:  out of dynamic storage space
%%E 11
%%I 11
%%D 13
.ti -3
in entdef: no room for new definition
%%E 13
%%E 11
%%I 13
.ti -5
o in entdef: no room for new definition
%%E 13
.br
There is insufficient memory for macro definitions,
etc.
Increase the MEMSIZE definition in the preprocessor.
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
includes nested too deeply
%%E 13
%%I 13
.ti -5
o includes nested too deeply
%%E 13
.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
%%I 11
%%D 13
.ti -3
invalid case label
%%E 13
%%I 13
.ti -5
o invalid case label
%%E 13
.br
The upper limit of a case label specifying a range was non-numeric.
.br
%%E 11
.ti -5
%%I 11
* invalid conditional token
.br
The token given as the argument to an "ifdef" or "ifnotdef" directive was
not alpha-numeric.
.br
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
invalid for clause
%%E 13
%%I 13
.ti -5
o invalid for clause
%%E 13
.br
The "for" clause did not contain a valid init, condition, and/or
increment section
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
invalid string size
%%E 13
%%I 13
.ti -5
o invalid string size
%%E 13
.br
The string format 'string name(size) "..."' was used, but the
size was given improperly.
.br
.ti -5
%%I 11
* missing `(' in conditional
.br
The first non-blank token following an "ifdef" or "ifnotdef" directive was
NOT a left parenthesis.
.br
.ti -5
* missing `)' in conditional
.br
An "ifdef" of "ifnotdef" directive was not properly terminated with a
right parenthesis.
.br
%%D 13
.ti -3
missing apostrophe in character literal
%%E 13
%%I 13
.ti -5
* missing `)' in define
%%E 13
.br
%%I 13
A define(...) was not properly terminated with a right parenthesis.
.br
.ti -5
* missing `(' in undefine
.br
The first non-blank token following an "undefine" was NOT a left
parenthesis.
.br
.ti -5
* missing `)' in undefine
.br
An "undefine" directive was not properly terminated with a right
parenthesis.
.br
.ti -5
o missing apostrophe in character literal
.br
%%E 13
An apostrophe-delimited string NOT of the form 'c' or '@c' was encountered.
.br
.ti -5
* missing colon in case or default label
.br
The list of case labels, or the default label were not followed by a colon.
.br
.ti -5
%%E 11
* missing comma in define
.br
Definitions of the form 'define(name,defn)' must include the
comma as a separator.
.br
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
missing function name
%%E 13
%%I 13
.ti -5
o missing function name
%%E 13
.br
There was an error in declaring a function
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
missing left brace in switch statement
%%E 13
%%I 13
.ti -5
o missing left brace in switch statement
%%E 13
.br
The left brace indicating the start of the block of case labels for the
"switch" statement was not encountered.
.br
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
missing left paren
%%E 13
%%I 13
.ti -5
o missing left paren
%%E 13
.br
A parenthesis was expected, probably in an "if" statement, but
not found
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
missing parenthesis in condition
%%E 13
%%I 13
.ti -5
o missing literal quote
%%E 13
.br
%%I 13
The terminating "%)" to a literally quoted string was not found.
.br
.ti -5
o missing parenthesis in condition
.br
%%E 13
A right parenthesis was expected, probably in an "if" statement,
but not found
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
missing quote
%%E 13
%%I 13
.ti -5
o missing quote
%%E 13
.br
A quoted string was not terminated by a quote
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
missing right paren
%%E 13
%%I 13
.ti -5
o missing right paren
%%E 13
.br
A right parenthesis was expected in a Fortran (as opposed to
Ratfor) statement but not found
.br
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
missing string token
%%E 13
%%I 13
.ti -5
o missing string token
%%E 13
.br
No array name was given when declaring a string variable
.br
.ti -5
%%I 11
* multiple defaults in switch statement
.br
More than one "default" statements were detected in the scope of a single
"switch" statement.
.br
.ti -5
%%E 11
%%I 13
o No room for generated variable name
.br
The table space used for generated long variable names has been exhausted.
Increase the MEMSIZE definition in the preprocessor.
This message cannot appear unless the long variable name processing has
been enabled.
.br
.ti -5
o No room for linkage external name
.br
The table space used for generated external names has been exhausted.
Increase the MEMSIZE definition in the preprocessor.
This message cannot appear unless the long variable name processing has
been enabled.
.br
.ti -5
%%E 13
* 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
%%I 11
* switch table overflow
.br
More case labels were specified than the internal storage can handle.
The size of the internal storage is determined by the value of MAXSWITCH
defined in the preprocessor symbols file.
.br
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
token too long
%%E 13
%%I 13
.ti -5
o token too long
%%E 13
.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
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
unbalanced parentheses
%%E 13
%%I 13
.ti -5
o unbalanced parentheses
%%E 13
.br
Unbalanced parentheses detected in a Fortran (as opposed
to Ratfor) statement
.br
%%D 11
.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
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
unexpected EOF
%%E 13
%%I 13
.ti -5
o unexpected EOF
%%E 13
.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
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
warning:  possible label conflict
%%E 13
%%I 13
.ti -5
o warning:  possible label conflict
%%E 13
.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
%%D 11
.ti -5
%%E 11
%%I 11
%%D 13
.ti -3
%%E 13
%%E 11
%%D 13
"file":  cannot open
%%E 13
%%I 13
.ti -5
* "file":  cannot open
%%E 13
.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.
%%I 13
%%D 14
#-h- ratp1d            81  asc  13-may-83 12:23:29  sventek (joseph sventek)
%%E 14
%%I 14
#-h- ratp1d            80  asc  15-jun-83 15:53:53  sventek (joseph sventek)
%%E 14
define (DO_PASS1,)
%%D 14
define (USE_STRING,"usage:  ratp1 [-n] [file] ... >outfile.")
#-h- rat77d           107  asc  13-may-83 12:23:30  sventek (joseph sventek)
%%E 14
%%I 14
define (USE_STRING,"usage:  ratp1 [-n] [file] ... >outfile")
#-h- rat77d           106  asc  15-jun-83 15:53:53  sventek (joseph sventek)
%%E 14
define (DO_F77_STRINGS,)
%%D 14
define (USE_STRING,"usage:  rat77 [-n] [file] ... >outfile.")
%%E 14
%%I 14
define (USE_STRING,"usage:  rat77 [-n] [file] ... >outfile")
%%E 14
define (STDEFNS,"")
%%D 14
#-h- ratford           86  asc  13-may-83 12:23:31  sventek (joseph sventek)
%%E 14
%%I 14
#-h- ratford           85  asc  15-jun-83 15:53:54  sventek (joseph sventek)
%%E 14
define (DO_HOLLERITH,)
%%D 14
define (USE_STRING,"usage:  ratfor [-n] [file] ... >outfile.")
%%E 14
%%I 14
define (USE_STRING,"usage:  ratfor [-n] [file] ... >outfile")
%%E 14
%%E 13
%%E 1