#-h-  ratfor.doc                17825  local   01/07/81  00:25:55
.bp 1
.in 0
.he 'RATFOR (1)'06/12/80'RATFOR (1)'
.fo ''-#-''
.fi
.in 7
.ti -7
NAME
.br
ratfor - Ratfor preprocessor
.sp 1
.ti -7
SYNOPSIS
.br
ratfor [files...] >outfile
.sp 1
.ti -7
DESCRIPTION
.br
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.

A file containing general purpose software tools definitions
(e.g. EOF, NEWLINE, EOS, etc.) will be automatically opened and
processed before any of the files specified are read.
.sp 2
Syntax:

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

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

.fi
The statement

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

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

The statement

.ti +15
define(name,replacement text)

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

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

will cause the source line

.ti +15
bump(i)

to be expanded into

.ti +15
i = i + 1

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

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

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

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

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

Note: the statement

.ti +15
define name text

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


.ne 9
Conditional Preprocessing:

The statements

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

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


String Data Types:

The statements

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

.in -10
declare 'name' to be a character array long enough to accomodate
the ascii codes for the given character string, one per array
element.
The array is then filled by data statements.
The last word of 'name' is initialized to the symbolic parameter
EOS, and indicates the end of a string.
EOS must be defined either in the standard definitions file or
by the user.
If a size is given, name is declared to be a character array
of 'size' elements.
If several string declarations appear consecutively, the
generated declarations for the arrays will precede the data
statements that initialize them.
.sp 2
String Literals:

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

.in +5
.nf
"str"         nHstr
'str'         nHstr
         (where 'n' is the number of characters in str)
.in -5
.br
.fi
String literals can be continued across line boundaries by ending
the line to be continued with an underline.
The underline is not included as part of the literal.
Leading blanks and tabs on the next line are ignored.
.sp 2
Integer Constants:

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

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

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

Lines can be passed through ratfor without being processed by
putting a percent "%" as the first character on the line.
The percent will be removed and the line shifted one position to the
left, but otherwise will be output without change.
Macro invocations, long names, etc., appearing in the line will not
be processed.
.sp 2
Long Variable Names

Unlike Fortran, Ratfor variable names may be essentially any length,
and may contain underscores as well as letters and digits.
Every character in a variable name is significant;
"very_long_variable_name_1" is different from "very_long_variable_name_2".
.sp
Ratfor converts such exceptional names into legal Fortran names of
six alphanumeric characters, and guarantees that no conflicts will
arise from converting two special names or from user variables that
happen to be the same as a Ratfor-generated name.
.sp
In the unfortunate event that it ever becomes necessary to debug the
Fortran output of Ratfor, Ratfor outputs a "long name dictionary"
as a series of comments at the end of its output code.
This dictionary shows each internal variable name along with its
Fortran equivalent.
.sp 4
.ne 4
.ti -7
CHANGES
.br
This ratfor preprocessor differs from the original (as released
by Kernighan and Plauger) in the following ways:

The code has been rewritten and reorganized.

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.

The 'switch' control statement has been included.

Continuation lines have been implemented.

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

Variable names that are longer than 6 characters or that contain
underscores are automatically converted to legal Fortran variable names.
.sp 3
.ti -7
FILES
.br
A generalized definition file (e.g. 'ratdef') is automatically
opened and read.
.sp 3
.ti -7
SEE ALSO
.br
.nf
Kernighan and Plauger's "Software Tools"
Kernighan's "RATFOR - A Preprocessor for a Rational Fortran"
The Unix command rc in the Unix Manual
The tools 'incl' and 'macro'
.fi
.sp 1
.ti -7
DIAGNOSTICS
.br
(The errors marked with asterisk '*' are fatal; all others are simply
warning messages.)
.sp 1
.in +5
.ti -5
* arg stack overflow
.br
The argument stack for the macro processor has been exceeded.  The size of the
stack is determined by the symbol ARGSIZE in the source definitions file.
.br
.ti -5
* buffer overflow
.br
One of the preprocessor's internal buffers overflowed,
possibly, but not necessarily, because the string buffers
were exceeded.
The definition SBUFSIZE in the preprocessor symbols file
determines the size
of the string buffers.
.br
.ti -5
* call stack overflow
.br
The call stack (used to store call frames) in the macro processor has
been exceeded.
The definition CALLSIZE in the source definition file determines the
size of this stack.
.br
.ti -5
can't open standard definitions file
.br
The special file containing general purpose ratfor definitions
could not be opened, possibly because it did not exist or the
user did not have access to the directory on which it resides.
.br
.ti -5
can't open include
.br
File to be included could not be located,
the user did not have privilege to access it,
or the file could not be opened due to some problem in the
local primitives.
.br
.ti -5
* definition too long
.br
The number of characters in the name to be defined exceeded
Ratfor's internal array size.
The size is defined by the MAXTOK definition in the preprocessor
symbols file.
.br
.ti -5
* EOF in string
.br
The macro processor detected an EOF in the current input file while
evaluating a macro.
.ti -5
* evaluation stack overflow
.br
The evaluation stack for the macro processor has been exceeded.
This stack's size is determined by the symbol EVALSIZE in the
source definition file.
.br
.ti -5
* for clause too long
.br
The internal buffer used to hold the clauses for the 'for'
statement was exceeded.
Size of this buffer is determined by the MAXFORSTK definition
in the preprocessor symbols file.
.br
.ti -5
* getdef is confused
.br
There were horrendous problems when attempting to access
the definition table
.br
.ti -5
illegal break
.br
Break did not occur inside a valid "while", "for", or "repeat" loop
.br
.ti -5
illegal else
.br
Else clause probably did not follow an "if" clause
.br
.ti -5
illegal next
.br
"Next" did not occur inside a valid "for", "while", or "repeat" loop
.br
.ti -5
illegal right brace
.br
A right brace was found without a matching left brace
.br
.ti -5
* in dsget:  out of dynamic storage space
.br
There is insufficient memory for macro definitions, long variable names,
etc.
Increase the MEMSIZE definition in the preprocessor.
.br
.ti -5
includes nested too deeply
.br
There is a limit to the level of nesting of included files.
It is dependent upon the maximum number of opened files allowed
at a time,
and is set by the
NFILES definition in the preprocessor symbols file.
.br
.ti -5
invalid for clause
.br
The "for" clause did not contain a valid init, condition, and/or
increment section
.ti -5
invalid string size
.br
The string format 'string name(size) "..."' was used, but the
size was given improperly.
.br
.ti -5
* missing comma in define
.br
Definitions of the form 'define(name,defn)' must include the
comma as a separator.
.br
.br
.ti -5
missing function name
.br
There was an error in declaring a function
.br
.ti -5
missing left paren
.br
A parenthesis was expected, probably in an "if" statement, but
not found
.br
.ti -5
missing parenthesis in condition
.br
A right parenthesis was expected, probably in an "if" statement,
but not found
.br
.ti -5
missing quote
.br
A quoted string was not terminated by a quote
.br
.ti -5
missing right paren
.br
A right parenthesis was expected in a Fortran (as opposed to
Ratfor) statement but not found
.br
.ti -5
missing string token
.br
No array name was given when declaring a string variable
.br
.ti -5
* non-alphanumeric name
.br
Definitions may contain only alphanumeric characters
and underscores.
.br
.ti -5
* stack overflow in parser
.br
Statements were nested at too deep a level.
The stack depth is set by the MAXSTACK definition in the
preprocessor symbols file.
.br
.ti -5
token too long
.br
A token (word) in the source code was too long to fit into one
of Ratfor's internal arrays.
The maximum size is set by the MAXTOK definition in the
preprocessor symbols file.
.br
.ti -5
* too many characters pushed back
.br
The source code has illegally specified a Ratfor command, or has
used a Ratfor keyword in an illegal manner, and the parser has
attempted but failed to make sense out of it.
The size of the push-back buffer is set by BUFSIZE in the
preprocessor symbols file.
.br
.ti -5
unbalanced parentheses
.br
Unbalanced parentheses detected in a Fortran (as opposed
to Ratfor) statement
.br
.ti -5
unexpected brace or EOF
.br
A brace occurred after a Fortran (but not Ratfor) statement
or an end-of-file was reached before the end of a statement
.br
.ti -5
unexpected EOF
.br
An end-of-file was reached before all braces had been
accounted for.  This is usually caused by unmatched braces
somewhere deep in the source code.
.br
.ti -5
warning:  possible label conflict
.br
This message is printed when the user has labeled a statement
with a label in the 23000-23999 range.  Ratfor statements are
assigned in this range and a user-defined one may conflict
with a Ratfor-generated one.
.br
.ne 3
.ti -5
"file":  cannot open
.br
Ratfor could not open an input file specified by the user
on the command line.
.br
.in -5
.sp 2
.ti -7
AUTHORS
.br
Original by B. Kernighan and P. J. Plauger, with rewrites and
enhancements by David Hanson and friends (U. of Arizona),
Joe Sventek and Debbie Scherrer (Lawrence Berkeley Laboratory),
and Allen Akin (Georgia Institute of Technology).
.sp 1
.ti -7
BUGS/DEFICIENCIES
.br
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
The 'switch' statement generates a variable to be used in a computed
goto.
This variable is undeclared and its type may be incorrect due to a
preceding 'implicit' declaration.
Because of this and other (minor) faults, the 'switch' statement
should be considered experimental and subject to change or deletion
in the future.
Use it with care!
.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.
.sp
Problems arise with the long variable name conversion process if
subprograms or common blocks with long names are compiled separately.
The easiest way to avoid this is to use 6-character or shorter names
(with no underscores and not ending in the character zero) for
external subprograms and common blocks.
In the future, a "linkage" statement will be added to get around this
difficulty.
#-t-  ratfor.doc                17825  local   01/07/81  00:25:55
#-h-  common                     2163  local   12/01/80  15:50:08
# Common blocks used by the Ratfor preprocessor
#     Place on a file called 'common'


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

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

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

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

 common /clabel/ label
   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

 common /cswtch/ swtop, swlast, swstak (MAXSWITCH)
   integer swtop       # current switch entry; init = 0
   integer swlast      # next available position; init = 1
   integer swstak      # switch information

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

 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

 DS_DECL(mem, MEMSIZE)
#-t-  common                     2163  local   12/01/80  15:50:08
#-h-  ratfor.r                  69694  local   12/01/80  15:56:25
#-h-  ratfor                     4496  local   12/01/80  15:53:43
# Ratfor preprocessor


   # include ratdef

#---------------------------------------------------------------
# The definition STDEFNS defines the file which contains the
# standard definitions to be used when preprocessing a file.
# It is opened and read automatically by the ratfor preprocessor.
# Set STDEFNS to the name of the file in which the standard
# definitions reside.  If you don't want the preprocessor to
# automatically open this file, set STDENFS to "".
#
#---------------------------------------------------------------
#    If you want the preprocessor to output upper case only,
#    set the following definition:
#
#              define (UPPERC,)
#
#---------------------------------------------------------------
#  Some of the buffer sizes and other symbols might have to be
#  changed.  Especially check the following:
#
#        MAXDEF         (number of characters in a definition)
#        SBUFSIZE       (nbr string declarations allowed per module)
#        MAXSTRTBL      (size of table to buffer string declarations)
#        MAXSWITCH      (max stack for switch statement)
#
#-----------------------------------------------------------------


define (STDEFNS,"ratdef")  # name of file containing standard defns
define (UPPERC,)           # define if Fortran compiler wants upper case

define (RADIX,PERCENT)     # % indicates alternate radix
define (TOGGLE,PERCENT)    # toggle for literal lines
define (ARGFLAG,DOLLAR)
define (CUTOFF,3)          # min nbr of cases to generate branch table
                           # (for switch statement)
define (DENSITY,2)         # reciprocal of density necessary for
                           # branch table
define (FILLCHAR,DIG0)     # used in long-name uniquing
define (MAXIDLENGTH,6)     # for Fortran 66 and 77


# 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)
define (LEXSWITCH,-24)
define (LEXUNTIL,-18)
define (LEXWHILE,-15)
define (LSTRIPC,-10)
define (RSTRIPC,-11)


# Built-in macro functions:

define (DEFTYPE,-4)
define (MACTYPE,-10)
define (IFTYPE,-11)
define (INCTYPE,-12)
define (SUBTYPE,-13)
define (ARITHTYPE,-14)
define (IFDEFTYPE,-15)
define (IFNOTDEFTYPE,-16)


# Size-limiting definitions:

define (MEMSIZE,10000)     # space allotted to symbol tables and macro text
define (BUFSIZE,400)       # pushback buffer for ngetch and putbak
define (PBPOINT,300)       # point in buffer where pushback begins
define (SBUFSIZE,500)      # buffer for string statements
define (MAXDEF,250)       # max chars in a defn
define (MAXFORSTK,200)     # max space for for reinit clauses
define (MAXFNAMES, arith(NFILES,*,FILENAMESIZE))
define (MAXSTACK,100)      # max stack depth for parser
define (MAXSWITCH,1000)    # max stack for switch statement
define (MAXTOK,100)        # max chars in a token
define (NFILES,5)          # max number of include file nesting
define (MAXNBRSTR,20)      #max nbr string declarations per module
define (CALLSIZE,50)
define (ARGSIZE,100)
define (EVALSIZE,500)


# Where to find the common blocks:

define(COMMON_BLOCKS,"common")


   DRIVER(ratfor)

   include COMMON_BLOCKS

   integer i, n
   integer getarg, open

   character arg (FILENAMESIZE)

   string defns STDEFNS # name of standard definitions file

   call initkw  # initialize variables

   # Read file containing standard definitions
   # If this isn't desired, define (STDEFNS,"")

   if (defns (1) != EOS) {
      infile (1) = open (defns, READ)
      if (infile (1) == ERR)
         call remark ("can't open standard definitions file.")
      else {
         call parse
         call close (infile (1))
         }
      }

   n = 1
   for (i = 1; getarg (i, arg, FILENAMESIZE) != EOF; i = i + 1) {
      n = n + 1
      call query ("usage:  ratfor [files] >outfile.")
      if (arg (1) == MINUS & arg (2) == EOS)
         infile (1) = STDIN
      else {
         infile (1) = open (arg, READ)
         if (infile (1) == ERR)
            call cant (arg)
         }
      call parse
      if (infile (1) != STDIN)
         call close (infile (1))
      }

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

   call lndict

   DRETURN
   end
#-t-  ratfor                     4496  local   12/01/80  15:53:43
#-h-  addchr                      254  local   12/01/80  15:53:44
# addchr - put c in buf (bp) if it fits, increment bp

   subroutine addchr (c, buf, bp, maxsiz)
   integer bp, maxsiz
   character c, buf (ARB)

   if (bp > maxsiz)
      call baderr ("buffer overflow.")
   buf (bp) = c
   bp = bp + 1

   return
   end
#-t-  addchr                      254  local   12/01/80  15:53:44
#-h-  allblk                      486  local   12/01/80  15:53:44
# allblk - determine if line consists of all blanks

# this routine is called by outdon, and is here to fix
# a bug which sometimes occurs if two or more includes precede the
# first line of executable code.  Could not trace down the cause

   integer function allblk (buf)
   character buf (ARB)

   integer i

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

   return
   end
#-t-  allblk                      486  local   12/01/80  15:53:44
#-h-  alldig                      306  local   12/01/80  15:53:45
# alldig - return YES if str is all digits

   integer function alldig (str)
   character str (ARB)

   character type

   integer i

   alldig = NO
   if (str (1) == EOS)
      return
   for (i = 1; str (i) != EOS; i = i + 1)
      if (!IS_DIGIT(str (i)))
         return
   alldig = YES
   return
   end
#-t-  alldig                      306  local   12/01/80  15:53:45
#-h-  baderr                      144  local   12/01/80  15:53:45
# baderr --- report fatal error message, then die

   subroutine baderr (msg)
   character msg (ARB)

   call synerr (msg)
   call endst
   end
#-t-  baderr                      144  local   12/01/80  15:53:45
#-h-  balpar                      854  local   12/01/80  15:53:46
# balpar - copy balanced paren string

   subroutine balpar

   character t, token (MAXTOK)
   character gettok, gnbtok

   integer nlpar

   if (gnbtok (token, MAXTOK) != LPAREN) {
      call synerr ("missing left paren.")
      return
      }
   call outstr (token)
   nlpar = 1
   repeat {
      t = gettok (token, MAXTOK)
      if (t == SEMICOL | t == LBRACE | t == RBRACE | t == EOF) {
         call pbstr (token)
         break
         }
      if (t == NEWLINE)      # delete newlines
         token (1) = EOS
      else if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      if (t == ALPHA)
         call squash (token)
      # else nothing special
      call outstr (token)
      } until (nlpar <= 0)

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

   return
   end
#-t-  balpar                      854  local   12/01/80  15:53:46
#-h-  brknxt                     1077  local   12/01/80  15:53:46
# 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
   integer alldig, ctoi

   character t, ptoken (MAXTOK)
   character gnbtok

   include COMMON_BLOCKS

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

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

   return
   end
#-t-  brknxt                     1077  local   12/01/80  15:53:46
#-h-  cascod                     1876  local   12/01/80  15:53:46
# cascod - generate code for case or default label

   subroutine cascod (lab, token)
   integer lab, token

   include COMMON_BLOCKS

   integer t, l, lb, ub, i, j, junk
   integer caslab, labgen, gnbtok

   character tok (MAXTOK)

   if (swtop <= 0) {
      call synerr ("illegal case or default.")
      return
      }
   call outgo (lab + 1) # terminate previous case
   xfer = YES
   l = labgen (1)
   if (token == LEXCASE) { # case n[,n]... : ...
      while (caslab (lb, t) != EOF) {
         ub = lb
         if (t == MINUS)
            junk = caslab (ub, t)
         if (lb > ub) {
            call synerr ("illegal range in case label.")
            ub = lb
            }
         if (swlast + 3 > MAXSWITCH)
            call baderr ("switch table overflow.")
         for (i = swtop + 3; i < swlast; i = i + 3)
            if (lb <= swstak (i))
               break
            else if (lb <= swstak (i+1))
               call synerr ("duplicate case label.")
         if (i < swlast & ub >= swstak (i))
            call synerr ("duplicate case label.")
         for (j = swlast; j > i; j = j - 1)   # insert new entry
            swstak (j+2) = swstak (j-1)
         swstak (i) = lb
         swstak (i + 1) = ub
         swstak (i + 2) = l
         swstak (swtop + 1) = swstak (swtop + 1)  +  1
         swlast = swlast + 3
         if (t == COLON)
            break
         else if (t != COMMA)
            call synerr ("illegal case syntax.")
         }
      }
   else {   # default : ...
      t = gnbtok (tok, MAXTOK)
      if (swstak (swtop + 2) != 0)
         call error ("multiple defaults in switch statement.")
      else
         swstak (swtop + 2) = l
      }

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

   xfer = NO
   call outcon (l)
   return
   end
#-t-  cascod                     1876  local   12/01/80  15:53:46
#-h-  caslab                      624  local   12/01/80  15:53:47
# caslab - get one case label

   integer function caslab (n, t)
   integer n, t

   character tok (MAXTOK)

   integer i, s
   integer gnbtok, ctoi

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

   return
   end
#-t-  caslab                      624  local   12/01/80  15:53:47
#-h-  deftok                     4116  local   12/01/80  15:53:47
# 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), mdefn (MAXDEF)
   character gtok

   integer ap, argstk (ARGSIZE), callst (CALLSIZE),
      nlb, plev (CALLSIZE), ifl
   integer ludef, push, ifparm

   string balp "()"

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

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

   return
   end
#-t-  deftok                     4116  local   12/01/80  15:53:47
#-h-  doarth                      636  local   12/01/80  15:53:48
# doarth - do arithmetic operation

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

   include COMMON_BLOCKS

   integer k, l
   integer ctoi

   character op

   k = argstk (i + 2)
   l = argstk (i + 4)
   op = evalst (argstk (i + 3))
   if (op == PLUS)
      call pbnum (ctoi (evalst, k) + ctoi (evalst, l))
   else if (op == MINUS)
      call pbnum (ctoi (evalst, k) - ctoi (evalst, l))
   else if (op ==  STAR )
      call pbnum (ctoi (evalst, k) * ctoi (evalst, l))
   else if (op ==  SLASH )
      call pbnum (ctoi (evalst, k) / ctoi (evalst, l))
   else
      call remark ('arith error')

   return
   end
#-t-  doarth                      636  local   12/01/80  15:53:48
#-h-  docode                      522  local   12/01/80  15:53:49
# docode - generate code for beginning of do

   subroutine docode (lab)
   integer lab

   integer labgen

   include COMMON_BLOCKS

   character gnbtok
   character lexstr (MAXTOK)

   string sdo "do"

   xfer = NO
   call outtab
   call outstr (sdo)
   call outch (BLANK)
   lab = labgen (2)
   if (gnbtok (lexstr, MAXTOK) == DIGIT) # check for fortran DO
      call outstr (lexstr)
   else {
      call pbstr (lexstr)
      call outnum (lab)
      }
   call outch (BLANK)
   call eatup
   call outdon
   return
   end
#-t-  docode                      522  local   12/01/80  15:53:49
#-h-  doif                        458  local   12/01/80  15:53:49
# 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
   integer equal

   if (j - i < 5)
      return
   a2 = argstk (i + 2)
   a3 = argstk (i + 3)
   a4 = argstk (i + 4)
   a5 = argstk (i + 5)
   if (equal (evalst (a2), evalst (a3)) == YES)   # subarrays
      call pbstr (evalst (a4))
   else
      call pbstr (evalst (a5))

   return
   end
#-t-  doif                        458  local   12/01/80  15:53:49
#-h-  doincr                      246  local   12/01/80  15:53:49
# doincr - increment macro argument by 1

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

   include COMMON_BLOCKS

   integer k
   integer ctoi

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

   return
   end
#-t-  doincr                      246  local   12/01/80  15:53:49
#-h-  domac                       326  local   12/01/80  15:53:49
# domac - install macro definition in table

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

   include COMMON_BLOCKS

   integer a2, a3

   if (j - i > 2) {
      a2 = argstk (i + 2)
      a3 = argstk (i + 3)
      call entdef (evalst (a2), evalst (a3), deftbl)     # subarrays
      }
   return
   end
#-t-  domac                       326  local   12/01/80  15:53:49
#-h-  dostat                      156  local   12/01/80  15:53:50
# dostat - generate code for end of do statement

   subroutine dostat (lab)
   integer lab

   call outcon (lab)
   call outcon (lab + 1)
   return
   end
#-t-  dostat                      156  local   12/01/80  15:53:50
#-h-  dosub                       709  local   12/01/80  15:53:50
# dosub - select macro substring

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

   include COMMON_BLOCKS

   integer ap, fc, k, nc
   integer ctoi, length

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

    return
    end
#-t-  dosub                       709  local   12/01/80  15:53:50
#-h-  eatup                      1137  local   12/01/80  15:53:50
# eatup - process rest of statement; interpret continuations

   subroutine eatup

   character ptoken (MAXTOK), t, token (MAXTOK)
   character gettok

   integer nlpar

   nlpar = 0
   repeat {
      t = gettok (token, MAXTOK)
      if (t == SEMICOL | t == NEWLINE)
         break
      if (t == RBRACE | t == LBRACE) {
         call pbstr (token)
         break
         }
      if (t == EOF) {
         call synerr ("unexpected EOF.")
         call pbstr (token)
         break
         }
      if (t == COMMA | t == PLUS | t == MINUS | t == STAR |
       t == LPAREN | t == AND | t == BAR | t == BANG | t == TILDE |
       t == NOT | t == CARET | t == EQUALS | t == UNDERLINE) {
         while (gettok (ptoken, MAXTOK) == NEWLINE)
            ;
         call pbstr (ptoken)
         if (t == UNDERLINE)
            token (1) = EOS
         }
      if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      if (t == ALPHA)
         call squash (token)
      call outstr (token)
      } until (nlpar < 0)
   if (nlpar != 0)
      call synerr ("unbalanced parentheses.")

   return
   end
#-t-  eatup                      1137  local   12/01/80  15:53:50
#-h-  elseif                      155  local   12/01/80  15:53:51
# elseif - generate code for end of if before else

   subroutine elseif (lab)
   integer lab

   call outgo (lab+1)
   call outcon (lab)
   return
   end
#-t-  elseif                      155  local   12/01/80  15:53:51
#-h-  entdef                      387  local   12/01/80  15:53:51
# entdef - enter a new symbol definition, discarding any old one

   subroutine entdef (name, defn, table)
   character name (MAXTOK), defn (ARB)
   pointer table

   integer lookup

   pointer text
   pointer sdupl

   if (lookup (name, text, table) == YES)
      call dsfree (text)   # this is how to do UNDEFINE, by the way
   call enter (name, sdupl (defn), table)

   return
   end
#-t-  entdef                      387  local   12/01/80  15:53:51
#-h-  entdkw                      975  local   12/01/80  15:54:05
# entdkw --- install macro processor keywords

   subroutine entdkw

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

   string defnam "define"
   string macnam "mdefine"
   string incnam "incr"
   string subnam "substr"
   string ifnam "ifelse"
   string arnam "arith"
   string ifdfnm "ifdef"
   string ifndnm "ifnotdef"

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

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

   return
   end
#-t-  entdkw                      975  local   12/01/80  15:54:05
#-h-  entfkw                      981  local   12/01/80  15:54:06
# entfkw - place Fortran keywords in symbol table

   subroutine entfkw

   include COMMON_BLOCKS

   # 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"

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

   return
   end
#-t-  entfkw                      981  local   12/01/80  15:54:06
#-h-  entrkw                     1003  local   12/01/80  15:54:06
# entrkw --- install Ratfor keywords in symbol table

   subroutine entrkw

   include COMMON_BLOCKS

   string sif "if"
   string selse "else"
   string swhile "while"
   string sdo "do"
   string sbreak "break"
   string snext "next"
   string sfor "for"
   string srept "repeat"
   string suntil "until"
   string sret "return"
   string sstr "string"
   string sswtch "switch"
   string scase "case"
   string sdeflt "default"

   call enter (sif, LEXIF, rkwtbl)
   call enter (selse, LEXELSE, rkwtbl)
   call enter (swhile, LEXWHILE, rkwtbl)
   call enter (sdo, LEXDO, rkwtbl)
   call enter (sbreak, LEXBREAK, rkwtbl)
   call enter (snext, LEXNEXT, rkwtbl)
   call enter (sfor, LEXFOR, rkwtbl)
   call enter (srept, LEXREPEAT, rkwtbl)
   call enter (suntil, LEXUNTIL, rkwtbl)
   call enter (sret, LEXRETURN, rkwtbl)
   call enter (sstr, LEXSTRING, rkwtbl)
   call enter (sswtch, LEXSWITCH, rkwtbl)
   call enter (scase, LEXCASE, rkwtbl)
   call enter (sdeflt, LEXDEFAULT, rkwtbl)

   return
   end
#-t-  entrkw                     1003  local   12/01/80  15:54:06
#-h-  evalr                      1126  local   12/01/80  15:54:06
# 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
   integer index, length

   string digits '0123456789'

   t = argstk (i)
   td = evalst (t)
   if (td == MACTYPE)
      call domac (argstk, i, j)
   else if (td == INCTYPE)
      call doincr (argstk, i, j)
   else if (td == SUBTYPE)
      call dosub (argstk, i, j)
   else if (td == IFTYPE)
      call doif (argstk, i, j)
   else if (td == ARITHTYPE)
      call doarth (argstk, i, j)
   else {
      for (k = t + length (evalst (t)) - 1; k > t; k = k - 1)
         if (evalst (k - 1) != ARGFLAG)
            call putbak (evalst (k))
         else {
            argno = index (digits, evalst (k))  -  1
            if (argno >= 0 & argno < j - i) {
               n = i + argno + 1
               m = argstk (n)
               call pbstr (evalst (m))
               }
            k = k - 1   # skip over $
            }
      if (k == t)         # do last character
         call putbak (evalst (k))
      }
   return
   end
#-t-  evalr                      1126  local   12/01/80  15:54:06
#-h-  finit                       432  local   12/01/80  15:54:07
# finit - initialize for each input file

   subroutine finit

   include COMMON_BLOCKS

   outp = 0  # output character pointer
   level = 1  # file control
   linect (1) = 0
   sbp  = 1
   fnamp = 2
   fnames (1) = EOS
   bp = PBPOINT
   buf (bp) = EOS    # to force a read on next call to 'ngetch'
   fordep = 0  # for stack
   fcname (1) = EOS # current function name
   swtop = 0  # switch stack
   swlast = 1
   return
   end
#-t-  finit                       432  local   12/01/80  15:54:07
#-h-  forcod                     2259  local   12/01/80  15:54:07
# forcod - beginning of for statement

   subroutine forcod (lab)
   integer lab

   include COMMON_BLOCKS

   character t, token (MAXTOK)
   character gettok, gnbtok

   integer i, j, nlpar
   integer length, labgen

   string ifnot "if (.not."

   lab = labgen (3)
   call outcon (0)
   if (gnbtok (token, MAXTOK) != LPAREN) {
      call synerr ("missing left paren.")
      return
      }
   if (gnbtok (token, MAXTOK) != SEMICOL) {   # real init clause
      call pbstr (token)
      call outtab
      call eatup
      call outdon
      }
   if (gnbtok (token, MAXTOK) == SEMICOL)   # empty condition
      call outcon (lab)
   else {   # non-empty condition
      call pbstr (token)
      call outnum (lab)
      call outtab
      call outstr (ifnot)
      call outch (LPAREN)
      nlpar = 0
      while (nlpar >= 0) {
         t = gettok (token, MAXTOK)
         if (t == SEMICOL)
            break
         if (t == LPAREN)
            nlpar = nlpar + 1
         else if (t == RPAREN)
            nlpar = nlpar - 1
         if (t == EOF) {
            call pbstr (token)
            return
            }
         if (t == ALPHA)
            call squash (token)
         if (t != NEWLINE & t != UNDERLINE)
            call outstr (token)
         }
      call outch (RPAREN)
      call outch (RPAREN)
      call outgo (lab+2)
      if (nlpar < 0)
         call synerr ("invalid for clause.")
      }
   fordep = fordep + 1   # stack reinit clause
   j = 1
   for (i = 1; i < fordep; i = i + 1)   # find end
      j = j + length (forstk (j)) + 1
   forstk (j) = EOS   # null, in case no reinit
   nlpar = 0
   t = gnbtok (token, MAXTOK)
   call pbstr (token)
   while (nlpar >= 0) {
      t = gettok (token, MAXTOK)
      if (t == LPAREN)
         nlpar = nlpar + 1
      else if (t == RPAREN)
         nlpar = nlpar - 1
      if (t == EOF) {
         call pbstr (token)
         break
         }
      if (nlpar >= 0 & t != NEWLINE & t != UNDERLINE) {
         if (t == ALPHA)
            call squash (token)
         if (j + length (token) >= MAXFORSTK)
            call baderr ("for clause too long.")
         call scopy (token, 1, forstk, j)
         j = j + length (token)
         }
      }
   lab = lab + 1   # label for next's
   return
   end
#-t-  forcod                     2259  local   12/01/80  15:54:07
#-h-  fors                        458  local   12/01/80  15:54:08
# fors - process end of for statement

   subroutine fors (lab)
   integer lab

   include COMMON_BLOCKS

   integer i, j
   integer length

   xfer = NO
   call outnum (lab)
   j = 1
   for (i = 1; i < fordep; i = i + 1)
      j = j + length (forstk (j)) + 1
   if (length (forstk (j)) > 0) {
      call outtab
      call outstr (forstk (j))
      call outdon
      }
   call outgo (lab - 1)
   call outcon (lab + 1)
   fordep = fordep - 1
   return
   end
#-t-  fors                        458  local   12/01/80  15:54:08
#-h-  getdef                     1634  local   12/01/80  15:54:08
# 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)
   character gtok, ngetch

   integer i, nlpar

   call skpblk
   c = gtok (ptoken, MAXTOK)
   if (c == LPAREN)
      t = LPAREN             # define (name, defn)
   else {
      t = BLANK              # define name defn
      call pbstr (ptoken)
      }
   call skpblk
   if (gtok (token, toksiz) != ALPHA)
      call baderr ("non-alphanumeric name.")
   call skpblk
   c = gtok (ptoken, MAXTOK)
   if (t == BLANK) {         # define name defn
      call pbstr (ptoken)
      i = 1
      repeat {
         c = ngetch (c)
         if (i > defsiz)
            call baderr ("definition too long.")
         defn (i) = c
         i = i + 1
         } until (c == SHARP | c == NEWLINE | c == EOF)
      if (c == SHARP)
         call putbak (c)
      }
   else if (t == LPAREN) {   # define (name, defn)
      if (c != COMMA)
         call baderr ("missing comma in define.")
      # else got (name,
      nlpar = 0
      for (i = 1; nlpar >= 0; i = i + 1)
         if (i > defsiz)
            call baderr ("definition too long.")
         else if (ngetch (defn (i)) == EOF)
            call baderr ("missing right paren.")
         else if (defn (i) == LPAREN)
            nlpar = nlpar + 1
         else if (defn (i) == RPAREN)
            nlpar = nlpar - 1
         # else normal character in defn (i)
      }
   else
      call baderr ("getdef is confused.")
   defn (i - 1) = EOS
   return
   end
#-t-  getdef                     1634  local   12/01/80  15:54:08
#-h-  gettok                     2076  local   12/01/80  15:54:09
# 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
   integer equal, open, length

   character name (MAXNAME), t
   character deftok

   string fncn "function"
   string incl "include"

   for ( ; level > 0; level = level - 1) {
      for (gettok = deftok (token, toksiz); gettok != EOF;
       gettok = deftok (token, toksiz)) {
         if (equal (token, fncn) == YES) {
            call skpblk
            t = deftok (fcname, MAXNAME)
            call pbstr (fcname)
            if (t != ALPHA)
               call synerr ("missing function name.")
            call putbak (BLANK)
            return
            }
         else if (equal (token, incl) == NO)
            return
         # process 'include' statements:
         call skpblk
         t = deftok (name, MAXNAME)
         if (t == SQUOTE | t == DQUOTE) {
            len = length (name) - 1
            for (i = 1; i < len; i = i + 1)
               name (i) = name (i + 1)
            name (i) = EOS
            }
         i = length (name) + 1
         if (level >= NFILES)
            call synerr ("includes nested too deeply.")
         else {
            infile (level + 1) = open (name, READ)
            linect (level + 1) = 0
            if (infile (level + 1) == ERR)
               call synerr ("can't open include.")
            else {
               level = level + 1
               if (fnamp + i <= MAXFNAMES) {
                  call scopy (name, 1, fnames, fnamp)
                  fnamp = fnamp + i    # push file name stack
                  }
               }
            }
         }
      if (level > 1) {      # close include file pop file name stack
         call close (infile (level))
         for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1)
            if (fnames (fnamp - 1) == EOS)
               break
         }
      }

   token (1) = EOF   # in case called more than once
   token (2) = EOS
   gettok = EOF
   return
   end
#-t-  gettok                     2076  local   12/01/80  15:54:09
#-h-  gnbtok                      237  local   12/01/80  15:54:09
# gnbtok - get nonblank token

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

   include COMMON_BLOCKS

   character gettok

   call skpblk
   gnbtok = gettok (token, toksiz)
   return
   end
#-t-  gnbtok                      237  local   12/01/80  15:54:09
#-h-  gtok                       3278  local   12/01/80  15:54:10
# gtok - get token for Ratfor

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

   include COMMON_BLOCKS

   character c
   character ngetch, type, clower

   integer i, b, n, d
   integer itoc, index

   string digits "0123456789abcdefghijklmnopqrstuvwxyz"

   c = ngetch (lexstr (1))

   if (c == BLANK | c == TAB) {
      lexstr (1) = BLANK
      while (c == BLANK | c == TAB)    # compress many blanks to one
         c = ngetch (c)
      if (c == SHARP)
         while (ngetch (c) != NEWLINE)   # strip comments
            ;
      if (c != NEWLINE)
         call putbak (c)
      else
         lexstr (1) = NEWLINE
      lexstr (2) = EOS
      gtok = lexstr (1)
      return
      }

   i = 1
   if (IS_LETTER(c)) {    # alpha
      for (i = 1; i < toksiz - 2; i = i + 1) {
         c = ngetch (lexstr (i + 1))
         if (!IS_LETTER(c) & !IS_DIGIT(c) & c != UNDERLINE)
            break
         }
      call putbak (c)
      gtok = ALPHA
      }

   else if (IS_DIGIT(c)) {   # digits
      b = c - DIG0 # in case alternate base number
      for (i = 1; i < toksiz - 2; i = i + 1) {
         c = ngetch (lexstr (i + 1))
         if (!IS_DIGIT(c))
            break
         b = 10 * b + c - DIG0
         }
      if (c == RADIX & b >= 2 & b <= 36) {   #n%ddd...
         n = 0
         repeat {
            d = index (digits, clower (ngetch (c))) - 1
            if (d < 0)
               break
            n = b * n + d
            }
         call putbak (c)
         i = itoc (n, lexstr, toksiz)
         }
      else
         call putbak (c)
      gtok = DIGIT
      }

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

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

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

   else if (c == SQUOTE | c == DQUOTE) {
      gtok = c
      for (i = 2; ngetch (lexstr (i)) != lexstr (1); i = i + 1) {
         if (lexstr (i) == UNDERLINE)
            if (ngetch (c) == NEWLINE) {
               while (c == NEWLINE | c == BLANK | c == TAB)
                  c = ngetch (c)
               lexstr (i) = c
               }
            else
               call putbak (c)
         if (lexstr (i) == NEWLINE | i >= toksiz - 1) {
            call synerr ("missing quote.")
            lexstr (i) = lexstr (1)
            call putbak (NEWLINE)
            break
            }
         }
      }

   else if (c == SHARP) {   # strip comments
      while (ngetch (lexstr (1)) != NEWLINE)
         ;
      gtok = NEWLINE
      }

   else if (c == GREATER | c == LESS | c == NOT | c == BANG |
    c == TILDE | c == CARET | c == EQUALS | c == AND | c == OR) {
      call relate (lexstr, i)
      gtok = c
      }

   else
      gtok = c

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

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

   return
   end
#-t-  gtok                       3278  local   12/01/80  15:54:10
#-h-  ifcode                      198  local   12/01/80  15:54:10
# ifcode - generate initial code for if

   subroutine ifcode (lab)
   integer lab

   include COMMON_BLOCKS

   integer labgen

   xfer = NO
   lab = labgen (2)
   call ifgo (lab)
   return
   end
#-t-  ifcode                      198  local   12/01/80  15:54:10
#-h-  ifgo                        347  local   12/01/80  15:54:11
# ifgo - generate "if (.not.(...))goto lab"

   subroutine ifgo (lab)
   integer lab

   string ifnot "if (.not."

   call outtab         # get to column 7
   call outstr (ifnot)      # " if (.not. "
   call balpar         # collect and output condition
   call outch (RPAREN)      # " ) "
   call outgo (lab)      # " goto lab "
   return
   end
#-t-  ifgo                        347  local   12/01/80  15:54:11
#-h-  ifparm                      689  local   12/01/80  15:54:11
# 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, index, type

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

   return
   end
#-t-  ifparm                      689  local   12/01/80  15:54:11
#-h-  initkw                      549  local   12/01/80  15:54:11
# initkw - initialize tables and important global variables

   subroutine initkw

   include COMMON_BLOCKS

   pointer mktabl

   call dsinit (MEMSIZE)
   deftbl = mktabl (1)     # symbol table for definitions
   call entdkw
   rkwtbl = mktabl (1)     # symbol table for Ratfor key words
   call entrkw
   fkwtbl = mktabl (0)     # symbol table for Fortran key words
   call entfkw
   namtbl = mktabl (1)     # symbol table for long identifiers
   gentbl = mktabl (0)     # symbol table for generated identifiers
   label = 23000

   return
   end
#-t-  initkw                      549  local   12/01/80  15:54:11
#-h-  labelc                      404  local   12/01/80  15:54:12
# labelc - output statement number

   subroutine labelc (lexstr)
   character lexstr (ARB)

   include COMMON_BLOCKS

   integer length

   xfer = NO   # can't suppress goto's now
   if (length (lexstr) == 5)   # warn about 23xxx labels
      if (lexstr (1) == DIG2 & lexstr (2) == DIG3)
         call synerr ("warning: possible label conflict.")
   call outstr (lexstr)
   call outtab
   return
   end
#-t-  labelc                      404  local   12/01/80  15:54:12
#-h-  labgen                      189  local   12/01/80  15:54:12
# labgen - generate  n  consecutive labels, return first one

   integer function labgen (n)
   integer n

   include COMMON_BLOCKS

   labgen = label
   label = label + n
   return
   end
#-t-  labgen                      189  local   12/01/80  15:54:12
#-h-  lex                         543  local   12/01/80  15:54:12
# lex - return lexical type of token

   integer function lex (lexstr)
   character lexstr (MAXTOK)

   include COMMON_BLOCKS

   character gnbtok

   integer lookup

   for (lex = gnbtok (lexstr, MAXTOK); lex == NEWLINE;
    lex = gnbtok (lexstr, MAXTOK))
      ;
   if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE)
      return
   if (lex == DIGIT)
      lex = LEXDIGITS
   else if (lex == TOGGLE)
      lex = LEXLITERAL
   else if (lookup (lexstr, lex, rkwtbl) == YES)
      ;
   else
      lex = LEXOTHER

   return
   end
#-t-  lex                         543  local   12/01/80  15:54:12
#-h-  litral                      316  local   12/01/80  15:54:13
# litral - process literal Fortran line

   subroutine litral

   include COMMON_BLOCKS

   character ngetch

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

   for (outp = 1; ngetch (outbuf (outp)) != NEWLINE; outp = outp + 1)
      ;
   outp = outp - 1
   call outdon
   return
   end
#-t-  litral                      316  local   12/01/80  15:54:13
#-h-  lndict                      678  local   12/01/80  15:54:13
# lndict - output long-name dictionary as a debugging aid

   subroutine lndict

   include COMMON_BLOCKS

   character sym (MAXTOK), c
   character cupper

   integer sctabl

   pointer posn, locn

   posn = 0
   while (sctabl (namtbl, sym, locn, posn) != EOF) {
      ifdef (UPPERC, call outch (BIGC))
      ifnotdef (UPPERC, call outch (LETC))
      call outtab
      for (; mem (locn) != EOS; locn = locn + 1) {
         c = mem (locn) # kluge for people with LOGICAL*1 characters
         ifdef (UPPERC, c = cupper (c))
         call outch (c)
         }
      call outch (BLANK)
      call outch (BLANK)
      call outstr (sym)
      call outdon
      }

   return
   end
#-t-  lndict                      678  local   12/01/80  15:54:13
#-h-  ludef                       495  local   12/01/80  15:54:29
# ludef --- look up a defined identifier, return its definition

   integer function ludef (id, defn, table)
   character id (ARB), defn (ARB)
   pointer table

   include COMMON_BLOCKS

   integer i
   integer lookup

   pointer locn

   ludef = lookup (id, locn, table)
   if (ludef == YES) {
      i = 1
      for (; mem (locn) != EOS; locn = locn + 1) {
         defn (i) = mem (locn)
         i = i + 1
         }
      defn (i) = EOS
      }
   else
      defn (1) = EOS

   return
   end
#-t-  ludef                       495  local   12/01/80  15:54:29
#-h-  ngetch                      442  local   12/01/80  15:54:30
# ngetch - get a (possibly pushed back) character

   character function ngetch (c)
   character c

   include COMMON_BLOCKS

   integer getlin

   if (buf (bp) == EOS)
      if (getlin (buf (PBPOINT), infile (level)) == EOF)
         c = EOF
      else {
         c = buf (PBPOINT)
         bp = PBPOINT + 1
         linect (level) = linect (level) + 1
         }
   else {
      c = buf (bp)
      bp = bp + 1
      }

   return (c)
   end
#-t-  ngetch                      442  local   12/01/80  15:54:30
#-h-  otherc                      284  local   12/01/80  15:54:30
# otherc - output ordinary Fortran statement

   subroutine otherc (lexstr)
   character lexstr (ARB)

   include COMMON_BLOCKS

   xfer = NO
   call outtab
   if (IS_LETTER(lexstr (1)))
      call squash (lexstr)
   call outstr (lexstr)
   call eatup
   call outdon
   return
   end
#-t-  otherc                      284  local   12/01/80  15:54:30
#-h-  outch                       357  local   12/01/80  15:54:30
# outch - put one character into output buffer

   subroutine outch (c)
   character c

   include COMMON_BLOCKS

   integer i

   if (outp >= 72) {   # continuation card
      call outdon
      for (i = 1; i < 6; i = i + 1)
         outbuf (i) = BLANK
      outbuf (6) = STAR
      outp = 6
      }
   outp = outp + 1
   outbuf (outp) = c
   return
   end
#-t-  outch                       357  local   12/01/80  15:54:30
#-h-  outcon                      332  local   12/01/80  15:54:31
# outcon - output "n   continue"

   subroutine outcon (n)
   integer n

   include COMMON_BLOCKS

   string contin "continue"

   xfer = NO
   if (n <= 0 & outp == 0)
      return            # don't need unlabeled continues
   if (n > 0)
      call outnum (n)
   call outtab
   call outstr (contin)
   call outdon
   return
   end
#-t-  outcon                      332  local   12/01/80  15:54:31
#-h-  outdon                      257  local   12/01/80  15:54:31
# outdon - finish off an output line

   subroutine outdon

   include COMMON_BLOCKS

   integer allblk

   outbuf (outp + 1) = NEWLINE
   outbuf (outp + 2) = EOS
   if (allblk (outbuf) == NO)
      call putlin (outbuf, STDOUT)
   outp = 0
   return
   end
#-t-  outdon                      257  local   12/01/80  15:54:31
#-h-  outgo                       239  local   12/01/80  15:54:31
# outgo - output "goto  n"

   subroutine outgo (n)
   integer n

   include COMMON_BLOCKS

   string sgoto "goto "

   if (xfer == YES)
      return
   call outtab
   call outstr (sgoto)
   call outnum (n)
   call outdon
   return
   end
#-t-  outgo                       239  local   12/01/80  15:54:31
#-h-  outnum                      381  local   12/01/80  15:54:32
# outnum - output decimal number

   subroutine outnum (n)
   integer n

   character chars (MAXCHARS)

   integer i, m

   m = iabs (n)
   i = 0
   repeat {
      i = i + 1
      chars (i) = mod (m, 10) + DIG0
      m = m / 10
      } until (m == 0 | i >= MAXCHARS)
   if (n < 0)
      call outch (MINUS)
   for ( ; i > 0; i = i - 1)
      call outch (chars (i))
   return
   end
#-t-  outnum                      381  local   12/01/80  15:54:32
#-h-  outstr                      687  local   12/01/80  15:54:32
# outstr - output string; handles quoted literals

   subroutine outstr (str)
   character str (ARB)

   character c
   character cupper

   integer i, j

   for (i = 1; str (i) != EOS; i = i + 1) {
      c = str (i)
      if (c != SQUOTE & c != DQUOTE) {
                         # produce upper case fortran, if desired
         ifdef (UPPERC,
            c = cupper (c)
            )
         call outch (c)
         }
      else {
         i = i + 1
         for (j = i; str (j) != c; j = j + 1)   # find end
            ;
         call outnum (j - i)
         call outch (BIGH)
         for ( ; i < j; i = i + 1)
            call outch (str (i))
         }
      }
   return
   end
#-t-  outstr                      687  local   12/01/80  15:54:32
#-h-  outtab                      140  local   12/01/80  15:54:32
# outtab - get past column 6

   subroutine outtab

   include COMMON_BLOCKS

   while (outp < 6)
      call outch (BLANK)
   return
   end
#-t-  outtab                      140  local   12/01/80  15:54:32
#-h-  parse                      2627  local   12/01/80  15:54:32
# parse - parse Ratfor source program

   subroutine parse

   include COMMON_BLOCKS

   character lexstr (MAXTOK)

   integer lab, labval (MAXSTACK), lextyp (MAXSTACK), sp, token, i
   integer lex

   call finit
   sp = 1
   lextyp (1) = EOF
   for (token = lex (lexstr); token != EOF; token = lex (lexstr)) {
      if (token == LEXIF)
         call ifcode (lab)
      else if (token == LEXDO)
         call docode (lab)
      else if (token == LEXWHILE)
         call whilec (lab)
      else if (token == LEXFOR)
         call forcod (lab)
      else if (token == LEXREPEAT)
         call repcod (lab)
      else if (token == LEXSWITCH)
         call swcode (lab)
      else if (token == LEXCASE | token == LEXDEFAULT) {
         for (i = sp; i > 0; i = i - 1)   # find for most recent switch
            if (lextyp (i) == LEXSWITCH)
               break
         if (i == 0)
            call synerr ("illegal case or default.")
         else
            call cascod (labval (i), token)
         }
      else if (token == LEXDIGITS)
         call labelc (lexstr)
      else if (token == LEXELSE) {
         if (lextyp (sp) == LEXIF)
            call elseif (labval (sp))
         else
            call synerr ("illegal else.")
         }
      else if (token == LEXLITERAL)
         call litral

      if (token == LEXIF | token == LEXELSE | token == LEXWHILE
        | token == LEXFOR | token == LEXREPEAT | token == LEXSWITCH
        | token == LEXDO | token == LEXDIGITS | token == LBRACE) {
         sp = sp + 1         # beginning of statement
         if (sp > MAXSTACK)
            call baderr ("stack overflow in parser.")
         lextyp (sp) = token      # stack type and value
         labval (sp) = lab
         }
      else if (token != LEXCASE & token != LEXDEFAULT) {
         if (token == RBRACE) {
            if (lextyp (sp) == LBRACE)
               sp = sp - 1
            else if (lextyp (sp) == LEXSWITCH) {
               call swend (labval (sp))
               sp = sp - 1
               }
            else
               call synerr ("illegal right brace.")
            }
         else if (token == LEXOTHER)
            call otherc (lexstr)
         else if (token == LEXBREAK | token == LEXNEXT)
            call brknxt (sp, lextyp, labval, token)
         else if (token == LEXRETURN)
            call retcod
         else if (token == LEXSTRING)
            call strdcl
         token = lex (lexstr)      # peek at next token
         call pbstr (lexstr)
         call unstak (sp, lextyp, labval, token)
         }
      }

   if (sp != 1)
      call synerr ("unexpected EOF.")

   return
   end
#-t-  parse                      2627  local   12/01/80  15:54:32
#-h-  pbnum                       304  local   12/01/80  15:54:33
# pbnum - convert number to string, push back on input

   subroutine pbnum (n)
   integer n

   integer m, num
   integer mod

   string digits '0123456789'

   num = n
   repeat {
      m = mod (num, 10)
      call putbak (digits (m + 1))
      num = num / 10
      } until (num == 0)
   return
   end
#-t-  pbnum                       304  local   12/01/80  15:54:33
#-h-  pbstr                       207  local   12/01/80  15:54:33
# pbstr - push string back onto input

   subroutine pbstr (in)
   character in (ARB)

   integer i
   integer length

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

   return
   end
#-t-  pbstr                       207  local   12/01/80  15:54:33
#-h-  push                        249  local   12/01/80  15:54:34
# push - push ep onto argstk, return new pointer ap

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

   if (ap > ARGSIZE)
      call baderr ('arg stack overflow.')
   argstk (ap) = ep
   push = ap + 1
   return
   end
#-t-  push                        249  local   12/01/80  15:54:34
#-h-  putbak                      254  local   12/01/80  15:54:34
# putbak - push character back onto input

   subroutine putbak (c)
   character c

   include COMMON_BLOCKS

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

   return
   end
#-t-  putbak                      254  local   12/01/80  15:54:34
#-h-  putchr                      233  local   12/01/80  15:54:34
# putchr - put single char into eval stack

   subroutine putchr (c)
   character c

   include COMMON_BLOCKS

   if (ep > EVALSIZE)
      call baderr ('evaluation stack overflow.')
   evalst (ep) = c
   ep = ep + 1
   return
   end
#-t-  putchr                      233  local   12/01/80  15:54:34
#-h-  puttok                      198  local   12/01/80  15:54:34
# puttok-put token into eval stack

    subroutine puttok (str)
    character str (MAXTOK)

    integer i

    for (i = 1; str (i) != EOS; i = i + 1)
       call putchr (str (i))
    return
    end
#-t-  puttok                      198  local   12/01/80  15:54:34
#-h-  relate                     1276  local   12/01/80  15:54:35
# relate - convert relational shorthands into long form

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

   character ngetch

   integer length

   if (ngetch (token (2)) != EQUALS) {
      call putbak (token (2))
      token (3) = LETT
      }
   else
      token (3) = LETE
   token (4) = PERIOD
   token (5) = EOS
   token (6) = EOS # for .not. and .and.
   if (token (1) == GREATER)
      token (2) = LETG
   else if (token (1) == LESS)
      token (2) = LETL
   else if (token (1) == NOT | token (1) == BANG |
            token (1) == CARET | token (1) == TILDE) {
      if (token (2) != EQUALS) {
         token (3) = LETO
         token (4) = LETT
         token (5) = PERIOD
         }
      token (2) = LETN
      }
   else if (token (1) == EQUALS) {
      if (token (2) != EQUALS) {
         token (2) = EOS
         last = 1
         return
         }
      token (2) = LETE
      token (3) = LETQ
      }
   else if (token (1) == AND) {
      token (2) = LETA
      token (3) = LETN
      token (4) = LETD
      token (5) = PERIOD
      }
   else if (token (1) == OR) {
      token (2) = LETO
      token (3) = LETR
      }
   else   # can't happen
      token (2) = EOS
   token (1) = PERIOD
   last = length (token)
   return
   end
#-t-  relate                     1276  local   12/01/80  15:54:35
#-h-  repcod                      262  local   12/01/80  15:54:35
# repcod - generate code for beginning of repeat

   subroutine repcod (lab)
   integer lab

   integer labgen

   call outcon (0)   # in case there was a label
   lab = labgen (3)
   call outcon (lab)
   lab = lab + 1   # label to go on next's
   return
   end
#-t-  repcod                      262  local   12/01/80  15:54:35
#-h-  retcod                      580  local   12/01/80  15:54:35
# retcod - generate code for return

   subroutine retcod

   include COMMON_BLOCKS

   character token (MAXTOK), t
   character gnbtok

   string sret "return"

   t = gnbtok (token, MAXTOK)
   if (t != NEWLINE & t != SEMICOL & t != RBRACE) {
      call pbstr (token)
      call outtab
      call scopy (fcname, 1, token, 1)
      call squash (token)
      call outstr (token)
      call outch (EQUALS)
      call eatup
      call outdon
      }
   else if (t == RBRACE)
      call pbstr (token)
   call outtab
   call outstr (sret)
   call outdon
   xfer = YES
   return
   end
#-t-  retcod                      580  local   12/01/80  15:54:35
#-h-  sdupl                       374  local   12/01/80  15:55:03
# sdupl --- duplicate a string in dynamic storage space

   pointer function sdupl (str)
   character str (ARB)

   DS_DECL(mem, MEMSIZE)

   integer i
   integer length

   pointer j
   pointer dsget

   j = dsget (length (str) + 1)
   sdupl = j
   for (i = 1; str (i) != EOS; i = i + 1) {
      mem (j) = str (i)
      j = j + 1
      }
   mem (j) = EOS

   return
   end
#-t-  sdupl                       374  local   12/01/80  15:55:03
#-h-  skpblk                      247  local   12/01/80  15:55:04
# skpblk - skip blanks and tabs in current input file

   subroutine skpblk

   include COMMON_BLOCKS

   character c
   character ngetch

   for (c = ngetch (c); c == BLANK | c == TAB; c = ngetch (c))
      ;

   call putbak (c)
   return
   end
#-t-  skpblk                      247  local   12/01/80  15:55:04
#-h-  squash                     1515  local   12/01/80  15:55:04
# squash - convert a long or special identifier into a Fortran variable

   subroutine squash (id)
   character id (MAXTOK)

   include COMMON_BLOCKS

   integer junk, i, j
   integer lookup

   character newid (MAXTOK), recdid (MAXTOK)

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

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

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

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

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

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

   return
   end
#-t-  squash                     1515  local   12/01/80  15:55:04
#-h-  strdcl                     2575  local   12/01/80  15:55:05
# strdcl - generate code for string declaration

   subroutine strdcl

   include COMMON_BLOCKS

   character t, token (MAXTOK), dchar (MAXTOK)
   character gnbtok

   integer i, j, k, n, len
   integer length, ctoi, lex

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

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

   return
   end
#-t-  strdcl                     2575  local   12/01/80  15:55:05
#-h-  swcode                      746  local   12/01/80  15:55:06
# swcode - generate code for beginning of switch statement

   subroutine swcode (lab)
   integer lab

   include COMMON_BLOCKS

   character tok (MAXTOK)

   integer labgen, gnbtok

   lab = labgen (2)
   if (swlast + 3 > MAXSWITCH)
      call baderr ("switch table overflow.")
   swstak (swlast) = swtop
   swstak (swlast + 1) = 0
   swstak (swlast + 2) = 0
   swtop = swlast
   swlast = swlast + 3
   xfer = NO
   call outtab  # Innn=(e)
   call swvar (lab)
   call outch (EQUALS)
   call balpar
   call outdon
   call outgo (lab) # goto L
   xfer = YES
   while (gnbtok (tok, MAXTOK) == NEWLINE)
      ;
   if (tok (1) != LBRACE) {
      call synerr ("missing left brace in switch statement.")
      call pbstr (tok)
      }
   return
   end
#-t-  swcode                      746  local   12/01/80  15:55:06
#-h-  swend                      2714  local   12/01/80  15:55:07
# swend - finish off switch statement; generate dispatch code

   subroutine swend (lab)
   integer lab

   include COMMON_BLOCKS

   integer lb, ub, n, i, j

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

   lb = swstak (swtop + 3)
   ub = swstak (swlast - 2)
   n = swstak (swtop + 1)
   call outgo (lab + 1) # terminate last case
   if (swstak (swtop + 2) == 0)
      swstak (swtop + 2) = lab + 1  # default default label
   xfer = NO
   call outcon (lab)  # L   continue
   if (n >= CUTOFF & ub - lb + 1 < DENSITY * n) { # output branch table
      if (lb != 1) {  # L  Innn=Innn-lb+1
         call outtab
         call swvar (lab)
         call outch (EQUALS)
         call swvar (lab)
         if (lb < 1)
            call outch (PLUS)
         call outnum (-lb + 1)
         call outdon
         }
      call outtab  #  if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default
      call outstr (sif)
      call swvar (lab)
      call outstr (slt)
      call swvar (lab)
      call outstr (sgt)
      call outnum (ub - lb + 1)
      call outch (RPAREN)
      call outgo (swstak (swtop + 2))
      call outtab  #  goto (....),Innn
      call outstr (sgoto)
      j = lb
      for (i = swtop + 3; i < swlast; i = i + 3) {
         for ( ; j < swstak (i); j = j + 1) { # fill in vacancies
            call outnum (swstak (swtop + 2))
            call outch (COMMA)
            }
         for (j = swstak (i + 1) - swstak (i); j >= 0; j = j - 1)
            call outnum (swstak (i + 2)) # fill in range
         j = swstak (i + 1) + 1
         if (i < swlast - 3)
            call outch (COMMA)
         }
      call outch (RPAREN)
      call outch (COMMA)
      call swvar (lab)
      call outdon
      }
   else if (n > 0) {  # output linear search form
      for (i = swtop + 3; i < swlast; i = i + 3) {
         call outtab  # if (Innn
         call outstr (sif)
         call swvar (lab)
         if (swstak (i) == swstak (i+1)) {
            call outstr (seq) #   .eq....
            call outnum (swstak (i))
            }
         else {
            call outstr (sge) #   .ge.lb.and.Innn.le.ub
            call outnum (swstak (i))
            call outstr (sand)
            call swvar (lab)
            call outstr (sle)
            call outnum (swstak (i + 1))
            }
         call outch (RPAREN) #    ) goto ...
         call outgo (swstak (i + 2))
         }
      if (lab + 1 != swstak (swtop + 2))
         call outgo (swstak (swtop + 2))
      }
   call outcon (lab + 1)   # L+1  continue
   swlast = swtop # pop switch stack
   swtop = swstak (swtop)
   return
   end
#-t-  swend                      2714  local   12/01/80  15:55:07
#-h-  swvar                       157  local   12/01/80  15:55:08
# swvar - output switch variable Innn, where nnn = lab

   subroutine swvar (lab)
   integer lab

   call outch (BIGI)
   call outnum (lab)
   return
   end
#-t-  swvar                       157  local   12/01/80  15:55:08
#-h-  synerr                      703  local   12/01/80  15:55:08
# synerr --- report non-fatal error

   subroutine synerr (msg)
   character msg (ARB)

   include COMMON_BLOCKS

   character lc (MAXCHARS)

   integer i, junk
   integer itoc

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

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

   call putch (COLON, ERROUT)
   call putch (BLANK, ERROUT)
   call remark (msg)
   return
   end
#-t-  synerr                      703  local   12/01/80  15:55:08
#-h-  ulstal                      268  local   12/01/80  15:55:09
# ulstal - install lower and upper case versions of symbol

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

   include COMMON_BLOCKS

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

   return
   end
#-t-  ulstal                      268  local   12/01/80  15:55:09
#-h-  uniqid                     1825  local   12/01/80  15:55:09
# uniqid - convert an identifier to one never before seen

   subroutine uniqid (id)
   character id (MAXTOK)

   include COMMON_BLOCKS

   integer i, j, junk, idchl, carry
   integer lookup, index, length

   character start (MAXIDLENGTH)

   string idch "0123456789abcdefghijklmnopqrstuvwxyz" # legal id characters

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

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

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

   # At this point, 'id' contains a unique identifier, not previously
   #  seen in this compilation.  Save it for future reference.
   call enter (id, 0, gentbl)

   return
   end
#-t-  uniqid                     1825  local   12/01/80  15:55:09
#-h-  unstak                      854  local   12/01/80  15:55:10
# unstak - unstack at end of statement

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

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

   return
   end
#-t-  unstak                      854  local   12/01/80  15:55:10
#-h-  untils                      397  local   12/01/80  15:55:11
# untils - generate code for until or end of repeat

   subroutine untils (lab, token)
   integer lab, token

   include COMMON_BLOCKS

   character ptoken (MAXTOK)

   integer junk
   integer lex

   xfer = NO
   call outnum (lab)
   if (token == LEXUNTIL) {
      junk = lex (ptoken)
      call ifgo (lab - 1)
      }
   else
      call outgo (lab - 1)
   call outcon (lab + 1)
   return
   end
#-t-  untils                      397  local   12/01/80  15:55:11
#-h-  whilec                      262  local   12/01/80  15:55:11
# whilec - generate code for beginning of while

   subroutine whilec (lab)
   integer lab

   integer labgen

   call outcon (0)    # unlabeled continue, in case there was a label
   lab = labgen (2)
   call outnum (lab)
   call ifgo (lab + 1)
   return
   end
#-t-  whilec                      262  local   12/01/80  15:55:11
#-h-  whiles                      148  local   12/01/80  15:55:12
# whiles - generate code for end of while

   subroutine whiles (lab)
   integer lab

   call outgo (lab)
   call outcon (lab + 1)
   return
   end
#-t-  whiles                      148  local   12/01/80  15:55:12
#-t-  ratfor.r                  69694  local   12/01/80  15:56:25
                                  