
#-h-  ratdef         8633  local  09/22/80  15:38:26
#================= GENERAL SYMBOL DEFINITIONS =================

# General definitions for software tools
# Should be put on a file named 'ratdef'
# Used by all the tools; read automatically by preprocessor


#   Many of these symbols may change for your particular machine.
#   The values provided are intended as guidelines, and may
#   well serve you adequately, but don't hesitate to change them if
#   necessary.

# In particular, the following might have to change for your system:
#         TERMINAL_IN
#         TERMINAL_OUT
#         MAXLINE
#         FILENAMESIZE
#         DRIVER    and    DRETURN
#         MAXOFILES
#         character

#   Also, watch out for the following definitions, which
#   may conflict with the Fortran operators on your system:
#       AND         OR        NOT


#  Many of the definitions will be used in character variables.
#  They must be defined to be something other than a valid ascii
#  character--such as a number > 255 or a negative number.
#  If you have defined "character" to be "integer", then you may
#  use either a very large number or a small negative number.
#  If you have defined "character" to be something like an 8-bit
#  signed field, you'll need to use negative numbers.
#  Use of a standard integer (whatever is the default size on your
#  machine) is STRONGLY recommended, despite the apparent waste of
#  storage.


# ASCII control character definitions:

define(NUL,8%00)
define(SOH,8%01)
define(STX,8%02)
define(ETX,8%03)
define(EOT,8%04)
define(ENQ,8%05)
define(ACK,8%06)
define(BEL,8%07)
define(BS,8%10)
define(HT,8%11)
define(LF,8%12)
define(VT,8%13)
define(FF,8%14)
define(CR,8%15)
define(SO,8%16)
define(SI,8%17)
define(DLE,8%20)
define(DC1,8%21)
define(DC2,8%22)
define(DC3,8%23)
define(DC4,8%24)
define(NAK,8%25)
define(SYN,8%26)
define(ETB,8%27)
define(CAN,8%30)
define(EM,8%31)
define(SUB,8%32)
define(ESC,8%33)
define(FS,8%34)
define(GS,8%35)
define(RS,8%36)
define(US,8%37)
define(SP,8%40)
define(DEL,8%177)


# Synonyms for important non-printing ASCII characters:

define(BACKSPACE,8%10)
define(BELL,8%07)
define(BLANK,8%40)
define(NEWLINE,8%12)
define(RUBOUT,8%177)
define(TAB,8%11)


# Printable ASCII characters:

define(ACCENT,96)
define(AMPER,38)           # ampersand
define(AMPERSAND,AMPER)
define(AND,AMPER)
define(ATSIGN,64)
define(BACKSLASH,92)
define(BANG,33)            # exclamation mark
define(BAR,124)
define(BIGA,65)
define(BIGB,66)
define(BIGC,67)
define(BIGD,68)
define(BIGE,69)
define(BIGF,70)
define(BIGG,71)
define(BIGH,72)
define(BIGI,73)
define(BIGJ,74)
define(BIGK,75)
define(BIGL,76)
define(BIGM,77)
define(BIGN,78)
define(BIGO,79)
define(BIGP,80)
define(BIGQ,81)
define(BIGR,82)
define(BIGS,83)
define(BIGT,84)
define(BIGU,85)
define(BIGV,86)
define(BIGW,87)
define(BIGX,88)
define(BIGY,89)
define(BIGZ,90)
define(CARET,94)
define(COLON,58)
define(COMMA,44)
define(DASH,45)            #same as MINUS
define(DIG0,48)
define(DIG1,49)
define(DIG2,50)
define(DIG3,51)
define(DIG4,52)
define(DIG5,53)
define(DIG6,54)
define(DIG7,55)
define(DIG8,56)
define(DIG9,57)
define(DOLLAR,36)
define(DQUOTE,34)
define(EQUALS,61)
define(ESCAPE,ATSIGN)      #escape character for ch, find, tr, ed, and sh
define(GREATER,62)
define(LBRACE,123)
define(LBRACK,91)
define(LESS,60)
define(LETA,97)
define(LETB,98)
define(LETC,99)
define(LETD,100)
define(LETE,101)
define(LETF,102)
define(LETG,103)
define(LETH,104)
define(LETI,105)
define(LETJ,106)
define(LETK,107)
define(LETL,108)
define(LETM,109)
define(LETN,110)
define(LETO,111)
define(LETP,112)
define(LETQ,113)
define(LETR,114)
define(LETS,115)
define(LETT,116)
define(LETU,117)
define(LETV,118)
define(LETW,119)
define(LETX,120)
define(LETY,121)
define(LETZ,122)
define(LPAREN,40)
define(MINUS,45)
define(NOT,TILDE)  # used in pattern matching; choose ~, ^, or !
define(OR,BAR)
define(PERCENT,37)
define(PERIOD,46)
define(PLUS,43)
define(QMARK,63)
define(RBRACE,125)
define(RBRACK,93)
define(RPAREN,41)
define(SEMICOL,59)
define(SHARP,35)
define(SLASH,47)
define(SQUOTE,39)
define(STAR,42)
define(TAB,9)
define(TILDE,126)
define(UNDERLINE,95)


# Ratfor language extensions:

define(andif,if)
define(ARB,100)
define(character,integer)  # define character data type
define(CHARACTER,character)
define(DS_DECL,integer $1($2);common/cdsmem/$1)
define(elif,else if)
define(filedes,integer)    # file descriptor/designator data type
define(FILEDES,filedes)
define(IS_DIGIT,(DIG0<=$1&$1<=DIG9))   # valid only for ASCII!
define(IS_LETTER,(IS_UPPER($1)|IS_LOWER($1)))
define(IS_LOWER,(LETA<=$1&$1<=LETZ))
define(IS_UPPER,(BIGA<=$1&$1<=BIGZ))
define(long_real,double precision)
define(max,max0)
define(MAX,max0)
define(min,min0)
define(MIN,min0)
define(pointer,integer)
define(POINTER,integer)



# Input/output modes:

define(APPEND,4)
define(READ,1)
define(READWRITE,3)
define(WRITE,2)


# Standard input/output ports:

define(ERROUT,3)           # standard error file
define(STDERR,ERROUT)
define(STDIN,1)            # standard input file
define(STDOUT,2)           # standard output file


# TERMINAL_IN and TERMINAL_OUT are the names of the I/O channels
# from and to the user's terminal, respectively.  It's highly likely
# there is no such thing on your system; in this case, simply invent
# a name that is not likely to conflict with any file name.
# For example, the VAX/VMS version of the tools uses "TT:", the RSX/11M
# version uses "TT0:", the DEC 10 version uses "tty:", and the Prime
# version uses "/dev/tty".
# Note that you must make the 'open' primitive recognize this name
# and provide access to the terminal accordingly.

define(TERMINAL_IN,"tty")
define(TERMINAL_OUT,"tty")


# Manifest constants included for readability and modifiability:

define(ALPHA,-9)
define(ASCII,12)             # flag for ascii character file
define(BEGINNING_OF_FILE,-2) # flag to seek for positioning at
                             # the beginning of a file
define(BINARY,60)            # flag for indicating binary file
define(DIGIT,DIG0)
define(END_OF_FILE,-1)       # flag to seek for positioning at
                             # end of file
define(EOF,-1)
define(EOS,-2)
define(ERR,-3)
define(HUGE,30000)           # some arbitrarily large number
define(LAMBDA,0)             # end of list marker
define(LETTER,LETA)
define(LOCAL,6)              # flag for local-type character file
define(NO,0)
define(NOERR,0)              # flag for successful completion
define(OK,-2)                # success flag
define(YES,1)


# Size limiting definitions for important objects:

define(FILENAMESIZE,30)    # max characters in file name
                           # (including EOS)
define(MAXARG,128)         # max size of command line argument
define(MAXCARD,80)         # "card" size
define(MAXCHARS,20)        # max nbr of chars when converting
                           # from integers to characters
                           # (used by putint, outnum, etc.)
define(MAXLINE,128)        # normal size of line buffers;
                           # must be at least 1 more than MAXCARD
define(MAXNAME,FILENAMESIZE)  # max size of file name
define(MAXOFILES,6)        # max nbr opened files allowed at a time
define(MAXPAT,128)         # max size of encoded patterns
                           # (used in string matching)
define(NCHARS,33)          # number of special characters


# Machine-dependent parameters:

define(BITS_PER_CHAR,8)
define(BITS_PER_WORD,16)
define(CHARS_PER_WORD,2)
define(MAX_INTEGER,32767)
define(MIN_INTEGER,-32768)
define(MAX_REAL_EXP,38)
define(MIN_REAL_EXP,-38)
define(REAL_PRECISION,6)


# DRIVER is defined as those things you need to do to start a Software
# Tools program running.  The following is a common approach, but you
# may have to change it (for example, by adding a "program" card).
# Many machines will require no special driver procedure other than
# the call to 'initst'.

define(DRIVER,
   call initst
   ifelse($1,,   call main,   call $1)
   call endst
   end
   ifelse($1,,   subroutine main,   subroutine $1)
   )


# DRETURN is used to finish up a Software Tools program:

define(DRETURN,return)   # (returning from subroutine defined in DRIVER)


# Definitions for 'spawn' primitive (if implemented):

define(WAIT,LETW)              # wait for subprocess to complete
define(NOWAIT,LETN)            # control returns as soon as
                               # subprocess starts
define(BACKGR,LETB)            # spawning a background process


# It may be necessary to add special definitions; for example
# names of important directories, substitute routine names for
# Software Tools primitives that conflict with local subprograms,
# etc.
#-t-  ratdef         8633  local  09/22/80  15:38:26
#-h-  libdef         1912  local  09/22/80  15:38:29
 # Symbol definitions for the portable primitives


 # You might need to adjust these for your system:

   define (STDINUNIT,5)    # Unit number for standard input
   define (STDOUTUNIT,6)   # Unit number for standard output
   define (ERROUTUNIT,6)   # Unit number for error output
   define (UNITA,1)        # First available unit (other than
                           # standard ones)
   define (UNITB,2)        # Next available unit
   define (UNITC,3)        # Third available unit


 # These definitions shouldn't have to be changed:

   define (DISK,1)         # Flag for disk files (UNITA, UNITB, UNITC)
   define (TERMINAL,0)     # Flag for terminal files (standard input,
                           # output, error output)
   define (MAXARGS,32)     # Max nbr command line arguments allowed
   define (ARGBUFSIZE,MAXLINE) # Size of buffer to hold command line args



# Defines for support library routines

# Defines for memory management routines:
define(DS_MEMEND,1)     # pointer to end of memory
define(DS_AVAIL,2)      # start of available space list
define(DS_CLOSE,8)      # threshhold for close-fitting blocks
define(DS_LINK,1)       # link field of storage block
define(DS_SIZE,0)       # size field of storage block
define(DS_OHEAD,2)      # total words of overhead per block

# Defines for symbol table routines:
define(ST_LINK,0)       # offset of link field in symbol table node
define(ST_DATA,1)       # offset of data field in symbol table node
define(ST_HTABSIZE,43)  # should be a prime number

# Definitions used only for pattern matching
define(AND,AMPER)
define(ANY,QMARK)
define(BOL,PERCENT)
define(CCL,LBRACK)
define(CCLEND,RBRACK)
define(CHAR,LETA)
define(CLOSIZE,4)
define(CLOSURE,STAR)
define(COUNT,1)
define(DASH,MINUS)
define(DITTO,-3)
define(EOL,DOLLAR)
define(NCCL,LETN)
define(NOT,TILDE)
define(PREVCL,2)
define(START,3)
define(START_TAG,LBRACE)
define(STOP_TAG,RBRACE)
#-t-  libdef         1912  local  09/22/80  15:38:29
#-h-  addstr          350  local  09/22/80  15:38:30
# addstr - add s to str(j) if it fits, increment j

   integer function addstr (s, str, j, maxsiz)
   integer j, maxsiz
   character s (ARB), str (maxsiz)

   integer i, addset

   for (i = 1; s (i) != EOS; i = i + 1)
      if (addset (s (i), str, j, maxsiz) == NO) {
         addstr = NO
         return
         }
   addstr = YES

   return
   end
#-t-  addstr          350  local  09/22/80  15:38:30
#-h-  amove          639  local  09/22/80  15:38:30
# amove - move name1 to name2

   integer function amove (name1, name2)
   character name1 (ARB), name2 (ARB)

   character buf (MAXLINE)

   integer junk
   integer getlin, remove

   filedes fd1, fd2
   filedes create, open

   # open the files:
   fd1 = open (name1,READ)
   if (fd1 == ERR)
      return (ERR)
   fd2 = create (name2, WRITE)
   if (fd2 == ERR)
      return (ERR)

   # copy the contents of file 'name1' to file 'name2':
   while (getlin (buf,fd1) != EOF)
      call putlin (buf,fd2)

   # close files and remove 'name1' if possible
   call close (fd1)
   call close (fd2)
   junk = remove (name1)

   return (OK)
   end
#-t-  amove          639  local  09/22/80  15:38:30
#-h-  catsub          561  local  09/22/80  15:38:30
# catsub --- add replacement text to end of  new

   subroutine catsub (lin, from, to, sub, new, k, maxnew)
   character lin (MAXLINE), sub (maxnew), new (MAXPAT)
   integer from (10), to (10), k, maxnew

   integer i, j, junk, ri
   integer addset

   for (i = 1; sub (i) != EOS; i = i + 1)
      if (sub (i) == DITTO) {
         i = i + 1
         ri = sub (i) + 1
         for (j = from (ri); j < to (ri); j = j + 1)
            junk = addset (lin (j), new, k, maxnew)
         }
      else
         junk = addset (sub (i), new, k, maxnew)

   return
   end
#-t-  catsub          561  local  09/22/80  15:38:30
#-h-  concat          247  local  09/22/80  15:38:31
# concat - concatenate two strings together

   subroutine concat (buf1, buf2, outstr)
   character buf1(ARB), buf2(ARB), outstr(ARB)

   integer i

   i = 1
   call stcopy (buf1, 1, outstr, i)
   call scopy (buf2, 1, outstr, i)

   return
   end
#-t-  concat          247  local  09/22/80  15:38:31
#-h-  ctoi          736  local  09/22/80  15:38:31
# ctoi - convert string at in(i) to integer, increment i

   integer function ctoi(in, i)
   character in (ARB)
   integer i

   integer d
   integer index

   # string digits "0123456789"
   character digits(11)
   data digits (1) /DIG0/,
      digits (2) /DIG1/,
      digits (3) /DIG2/,
      digits (4) /DIG3/,
      digits (5) /DIG4/,
      digits (6) /DIG5/,
      digits (7) /DIG6/,
      digits (8) /DIG7/,
      digits (9) /DIG8/,
      digits (10) /DIG9/,
      digits (11) /EOS/

   while (in (i) == BLANK | in (i) == TAB)
      i = i + 1
   for (ctoi = 0; in (i) != EOS; i = i + 1) {
      d = index (digits, in (i))
      if (d == 0)      # non-digit
         break
      ctoi = 10 * ctoi + d - 1
      }

   return
   end
#-t-  ctoi          736  local  09/22/80  15:38:31
#-h-  ctomn         1584  local  09/22/80  15:38:31
# ctomn --- translate ASCII control character to mnemonic string

   integer function ctomn (c, rep)
   character c, rep (4)

   integer i
   integer length

   character mntext (136)     # 4 chars/mnemonic; 32 control chars + SP + DEL
   data mntext / _
      BIGN, BIGU, BIGL, EOS,
      BIGS, BIGO, BIGH, EOS,
      BIGS, BIGT, BIGX, EOS,
      BIGE, BIGT, BIGX, EOS,
      BIGE, BIGO, BIGT, EOS,
      BIGE, BIGN, BIGQ, EOS,
      BIGA, BIGC, BIGK, EOS,
      BIGB, BIGE, BIGL, EOS,
      BIGB, BIGS, EOS,  EOS,
      BIGH, BIGT, EOS,  EOS,
      BIGL, BIGF, EOS,  EOS,
      BIGV, BIGT, EOS,  EOS,
      BIGF, BIGF, EOS,  EOS,
      BIGC, BIGR, EOS,  EOS,
      BIGS, BIGO, EOS,  EOS,
      BIGS, BIGI, EOS,  EOS,
      BIGD, BIGL, BIGE, EOS,
      BIGD, BIGC, DIG1, EOS,
      BIGD, BIGC, DIG2, EOS,
      BIGD, BIGC, DIG3, EOS,
      BIGD, BIGC, DIG4, EOS,
      BIGN, BIGA, BIGK, EOS,
      BIGS, BIGY, BIGN, EOS,
      BIGE, BIGT, BIGB, EOS,
      BIGC, BIGA, BIGN, EOS,
      BIGE, BIGM, EOS,  EOS,
      BIGS, BIGU, BIGB, EOS,
      BIGE, BIGS, BIGC, EOS,
      BIGF, BIGS, EOS,  EOS,
      BIGG, BIGS, EOS,  EOS,
      BIGR, BIGS, EOS,  EOS,
      BIGU, BIGS, EOS,  EOS,
      BIGS, BIGP, EOS,  EOS,
      BIGD, BIGE, BIGL, EOS/

   i = and (c, 127)
   if (0 <= i & i <= 32)     # non-printing character or space
      call scopy (mntext, 4 * i + 1, rep, 1)
   elif (i == 127)            # rubout (DEL)
      call scopy (mntext, 133, rep, 1)
   else {                     # printing character
      rep (1) = c
      rep (2) = EOS
      }

   return (length (rep))
   end
#-t-  ctomn         1584  local  09/22/80  15:38:31
#-h-  delete          336  local  09/22/80  15:38:32
# delete --- remove a symbol from the symbol table

   subroutine delete (symbol, st)
   character symbol (ARB)
   pointer st

   DS_DECL(Mem, 1)

   integer stlu

   pointer node, pred

   if (stlu (symbol, node, pred, st) == YES) {
      Mem (pred + ST_LINK) = Mem (node + ST_LINK)
      call dsfree (node)
      }

   return
   end
#-t-  delete          336  local  09/22/80  15:38:32
#-h-  dsinit          555  local  09/22/80  15:38:32
# dsinit --- initialize dynamic storage space to w words

   subroutine dsinit (w)
   integer w

   DS_DECL(Mem, 1)

   pointer t

   if (w < 2 * DS_OHEAD + 2)
      call error ("in dsinit: unreasonably small memory size.")

   # set up avail list:
   t = DS_AVAIL
   Mem (t + DS_SIZE) = 0
   Mem (t + DS_LINK) = DS_AVAIL + DS_OHEAD

   # set up first block of space:
   t = DS_AVAIL + DS_OHEAD
   Mem (t + DS_SIZE) = w - DS_OHEAD - 1     # -1 for MEMEND
   Mem (t + DS_LINK) = LAMBDA

   # record end of memory:
   Mem (DS_MEMEND) = w

   return
   end
#-t-  dsinit          555  local  09/22/80  15:38:32
#-h-  enter          794  local  09/22/80  15:38:32
# enter --- place a symbol in the symbol table, updating if already present

   subroutine enter (symbol, info, st)
   character symbol (ARB)
   integer info (ARB)
   pointer st

   DS_DECL(Mem, 1)

   integer i, nodsiz, j
   integer stlu, length

   pointer node, pred
   pointer dsget

   nodsiz = Mem (st)

   if (stlu (symbol, node, pred, st) == NO) {
      node = dsget (1 + nodsiz + length (symbol) + 1)
      Mem (node + ST_LINK) = LAMBDA
      Mem (pred + ST_LINK) = node
      i = 1
      j = node + ST_DATA + nodsiz
      while (symbol (i) != EOS) {
         Mem (j) = symbol (i)
         i = i + 1
         j = j + 1
         }
      Mem (j) = EOS
      }

   for (i = 1; i <= nodsiz; i = i + 1) {
      j = node + ST_DATA + i - 1
      Mem (j) = info (i)
      }

   return
   end
#-t-  enter          794  local  09/22/80  15:38:32
#-h-  fcopy          218  local  09/22/80  15:38:32
# fcopy - copy file in to file out

   subroutine fcopy (in, out)
   filedes in, out

   character line (MAXLINE)

   integer getlin

   while (getlin (line, in) != EOF)
      call putlin (line, out)

   return
   end
#-t-  fcopy          218  local  09/22/80  15:38:32
#-h-  fmtdat          880  local  09/22/80  15:38:33
# fmtdat - format date and time information

   subroutine fmtdat (date, time, now, form)
   character date (ARB), time (ARB)
   integer now (7), form

   # at present, simply return mm/dd/yy and hh:mm:ss
   # 'form' is reserved for selecting different formats
   # when those have been chosen.

   date (1) = now (2) / 10 + DIG0
   date (2) = mod (now (2), 10) + DIG0
   date (3) = SLASH
   date (4) = now (3) / 10 + DIG0
   date (5) = mod (now (3), 10) + DIG0
   date (6) = SLASH
   date (7) = mod (now (1), 100) / 10 + DIG0
   date (8) = mod (now (1), 10) + DIG0
   date (9) = EOS

   time (1) = now (4) / 10 + DIG0
   time (2) = mod (now (4), 10) + DIG0
   time (3) = COLON
   time (4) = now (5) / 10 + DIG0
   time (5) = mod (now (5), 10) + DIG0
   time (6) = COLON
   time (7) = now (6) / 10 + DIG0
   time (8) = mod (now (6), 10) + DIG0
   time (9) = EOS

   return
   end
#-t-  fmtdat          880  local  09/22/80  15:38:33
#-h-  gctoi         1109  local  09/22/80  15:38:33
# gctoi --- convert any radix string to single precision integer

   integer function gctoi (str, i, radix)
   character str (ARB)
   integer i, radix

   integer base, v, d, j
   integer index

   character clower

   logical neg

   string digits "0123456789abcdef"

   v = 0
   base = radix

   while (str (i) == BLANK | str (i) == TAB)
      i = i + 1

   neg = (str (i) == MINUS)
   if (str (i) == PLUS | str (i) == MINUS)
      i = i + 1

   if (str (i + 2) == LETR & str (i) == DIG1 & IS_DIGIT(str (i + 1))
         | str (i + 1) == LETR & IS_DIGIT(str (i))) {
      base = str (i) - DIG0
      j = i
      if (str (i + 1) != LETR) {
         j = j + 1
         base = base * 10 + (str (j) - DIG0)
         }
      if (base < 2 | base > 16)
         base = radix
      else
         i = j + 2
      }

   for (; str (i) != EOS; i = i + 1) {
      if (IS_DIGIT(str (i)))
         d = str (i) - DIG0
      else
         d = index (digits, clower (str (i))) - 1
      if (d < 0 | d >= base)
         break
      v = v * base + d
      }

   if (neg)
      return (-v)
   else
      return (+v)

   end
#-t-  gctoi         1109  local  09/22/80  15:38:33
#-h-  getc          147  local  09/22/80  15:38:33
# getc - get character from STDIN

   character function getc (c)
   character c

   character getch

   getc = getch (c, STDIN)

   return
   end
#-t-  getc          147  local  09/22/80  15:38:33
#-h-  getnow          587  local  09/22/80  15:38:33
# getnow - return current time and date

   subroutine getnow (now)
   integer now (7)

   now (1) = 1980                   # the year
   now (2) = 09                     # the month
   now (3) = 30                     # the day of the month
   now (4) = 23                     # the hour of the day (24-hour clock)
   now (5) = 59                     # the minute of the hour
   now (6) = 59                     # the second of the minute
   now (7) = 999                    # the millisecond of the second

   # values unobtainable on your system may default to zero

   return
   end
#-t-  getnow          587  local  09/22/80  15:38:33
#-h-  getpat          175  local  09/22/80  15:38:34
# getpat - convert str into pattern

   integer function getpat (str, pat)
   character str (ARB), pat (ARB)

   integer makpat

   return (makpat (str, 1, EOS, pat))

   end
#-t-  getpat          175  local  09/22/80  15:38:34
#-h-  getwrd          436  local  09/22/80  15:38:34
# getwrd - get non-blank word from in (i) into out, increment i

   integer function getwrd (in, i, out)
   character in (ARB), out (ARB)
   integer i

   integer j

   while (in (i) == BLANK | in (i) == TAB)
      i = i + 1

   j = 1
   while (in (i) != EOS & in (i) != BLANK
    & in (i) != TAB & in (i) != NEWLINE) {
      out (j) = in (i)
      i = i + 1
      j = j + 1
      }
   out (j) = EOS

   getwrd = j - 1
   return
   end
#-t-  getwrd          436  local  09/22/80  15:38:34
#-h-  gfnarg         3400  local  09/22/80  15:38:34
# gfnarg --- get the next file name from the argument list

   integer function gfnarg (name, state)
   character name (ARB)
   integer state (4)

   integer l
   integer getarg, getlin, length

   filedes fd
   filedes open

   string in1 "/dev/stdin1"
   string in2 "/dev/stdin2"
   string in3 "/dev/stdin3"

   repeat {

      if (state (1) == 1) {
         state (1) = 2        # new state
         state (2) = 1        # next argument
         state (3) = ERR      # current input file
         state (4) = 0        # input file count
         }

      else if (state (1) == 2) {
         if (getarg (state (2), name, MAXARG) != EOF) {
            state (1) = 2     # stay in same state
            state (2) = state (2) + 1  # bump argument count
            if (name (1) != MINUS) {
               state (4) = state (4) + 1    # bump input file count
               return (OK)
               }
            else if (name (2) == EOS) {
               call scopy (in1, 1, name, 1)
               state (4) = state (4) + 1    # bump input file count
               return (OK)
               }
            else if (name (2) == DIG1 & name (3) == EOS) {
               call scopy (in1, 1, name, 1)
               state (4) = state (4) + 1    # bump input file count
               return (OK)
               }
            else if (name (2) == DIG2 & name (3) == EOS) {
               call scopy (in2, 1, name, 1)
               state (4) = state (4) + 1    # bump input file count
               return (OK)
               }
            else if (name (2) == DIG3 & name (3) == EOS) {
               call scopy (in3, 1, name, 1)
               state (4) = state (4) + 1    # bump input file count
               return (OK)
               }

            else if (name (2) == LETN | name (2) == BIGN) {
               state (1) = 3           # new state
               if (name (3) == EOS)
                  state (3) = STDIN
               else if (name (3) == DIG1 & name (4) == EOS)
                  state (3) = STDIN1
               else if (name (3) == DIG2 & name (4) == EOS)
                  state (3) = STDIN2
               else if (name (3) == DIG3 & name (4) == EOS)
                  state (3) = STDIN3
               else {
                  state (3) = open (name (3), READ)
                  if (state (3) == ERR) {
                     call putlin (name, ERROUT)
                     call remark (":  can't open.")
                     state (1) = 2
                     }
                  }
               }
            else
               return (ERR)
            }

         else
            state (1) = 4     # EOF state
         }

      else if (state (1) == 3) {
         l = getlin (name, state (3))
         if (l != EOF) {
            name (l) = EOS
            state (4) = state (4) + 1  # bump input file count
            return (OK)
            }
         if (fd != ERR & fd != STDIN)
            call close (state (3))
         state (1) = 2
         }

      else if (state (1) == 4) {
         state (1) = 5
         if (state (4) == 0) {# no input files
            call scopy (in1, 1, name, 1)
            return (OK)
            }
         break
         }

      else if (state (1) == 5)
         break

      else
         call error ("in gfnarg:  bad state (1) value.")

      } # end of infinite repeat

   name (1) = EOS
   return (EOF)
   end
#-t-  gfnarg         3400  local  09/22/80  15:38:34
#-h-  gitoc         1705  local  09/22/80  15:38:35
# gitoc --- convert single precision integer to any radix string

   integer function gitoc (int, str, size, base)
   integer int, size, base
   character str (size)

   integer carry, d, i, radix, n

   logical unsign

   string digits "0123456789ABCDEF"

   str (1) = EOS  # digit string is generated backwards, then reversed
   if (size <= 1)
      return (0)

   radix = iabs (base)        # get actual conversion radix
   if (radix < 2 | radix > 16)
      radix = 10
   unsign = (base < 0)      # negative radices mean unsign conversion
   if (unsign) {
      n = and (int / 2,       # make pos. but keep high-order bits intact
            MAX_INTEGER)
      carry = and (int, 1)    # get initial carry
      }
   else
      n = int

   i = 1
   repeat {
      d = iabs (mod (n, radix))  # generate next digit
      if (unsign) {      # this is only half of actual digit value
         d = 2 * d + carry    # get actual digit value
         if (d >= radix) {    # check for generated carry
            d = d - radix
            carry = 1
            }
         else
            carry = 0
         }
      i = i + 1
      str (i) = digits (d + 1)   # convert to character and store
      n = n / radix
      } until (n == 0 | i >= size)

   if (unsign) {
      if (carry != 0 & i < size) {    # check for final carry
         i = i + 1
         str (i) = DIG1
         }
      }
   elif (int < 0 & i < size) {     # add sign if needed
      i = i + 1
      str (i) = MINUS
      }

   gitoc = i - 1     # will return length of string

   for (d = 1; d < i; d = d + 1) {     # reverse digits
      carry = str (d)
      str (d) = str (i)
      str (i) = carry
      i = i - 1
      }

   return
   end
#-t-  gitoc         1705  local  09/22/80  15:38:35
#-h-  initst         4393  local  09/22/80  15:38:36
# initst - initialize variables and I/O for software tools programs

   subroutine initst

   character input (FILENAMESIZE),
             output (FILENAMESIZE),
             errout (FILENAMESIZE),
             buf (MAXLINE)

   integer i, outacc, erracc
   integer getarg, assign, insub, outsub, errsub

   filedes open

   # include args

 ## common block used to hold command line argument information
 # Put on a file called 'args'

 common /args/ nbrarg, ptr (MAXARGS), arg (ARGBUFSIZE)
 integer nbrarg         #number arguments in list; initialize to 0
 integer ptr            #pointers (into 'arg') for each argument
 character arg          #arguments stored as ascii strings terminated
                        #with EOS markers


   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit



   # Set default output and errout access types (WRITE or APPEND)
   data outacc /WRITE/
   data erracc /WRITE/


   #----------------------------------------------------------------
   #
   #   These initializations are done with substitutions rather than
   #   data or block data statements to avoid the problem of block
   #   data programs.
   #
   #----------------------------------------------------------------

   # Initialize command line argument count
   # (Located in /args/)

   nbrarg = 0

   # Initialize fortran units for I/O
   # (These are located in the 'io' common block
   # Change these to units appropriate to your machine

   #                      This is STDIN (1)
   unit (STDIN) = STDINUNIT
   mode (STDIN) = TERMINAL         # TERMINAL or DISK
   ftype (STDIN) = LOCAL           # File type - LOCAL, ASCII, or BINARY

   #                      This is STDOUT (2)
   unit (STDOUT) = STDOUTUNIT
   mode (STDOUT) = TERMINAL        # TERMINAL or DISK
   ftype (STDOUT) = LOCAL          # File type - LOCAL, ASCII, or BINARY

   #                      This is ERROUT (3)
   unit (ERROUT) = ERROUTUNIT
   mode (ERROUT) = TERMINAL        # TERMINAL or DISK
   ftype (ERROUT) = LOCAL          # File type - LOCAL, ASCII, or BINARY

   #                      Any unit is OK here
   unit (4) = UNITA
   mode (4) = DISK                 # TERMINAL or DISK
   ftype (4) = LOCAL               # File type - LOCAL, ASCII, or BINARY

   #                      This is UNITB (any unit)
   unit (5) = UNITB
   mode (5) = DISK                 # TERMINAL or DISK
   ftype (5) = LOCAL               # File type - LOCAL, ASCII, or BINARY

   #                      This is UNITC (any unit)
   unit (6) = UNITC
   mode (6) = DISK                 # TERMINAL or DISK
   ftype (6) = LOCAL               # File type - LOCAL, ASCII, or BINARY


   # initialize default standard files
   call termin (input)
   call trmout (output)
   call trmout (errout)

   # initialize /io/ common block variables
   for (i = 1; i <= MAXOFILES; i = i + 1)
          filenm (1, i) = EOS

   # set up list of command arguments
   call makarg

   # pick up file substitutions for standard files
   for (i=1; getarg (i, buf, MAXLINE) != EOF; ) {
      if (insub (buf,input) == YES |
       outsub (buf,output, outacc) == YES |
       errsub (buf, errout, erracc) == YES )
         call delarg (i)
      else
         i = i + 1
      }

   # open standard input, output, and errout files
   if (assign (errout, ERROUT, erracc) == ERR)
      call endst    # can't print error message cause no ERROUT file
   if (assign (input, STDIN, READ) == ERR)
      call cant (input)
   if (assign (output, STDOUT, outacc) == ERR)
      call cant (output)

   return
   end
#-h-  initst         4393  local  09/22/80  15:38:36
#-h-  isatty         1107  local  09/22/80  15:38:37
# isatty - determine if file is a teletype/CRT device

   integer function isatty (int)
   filedes int

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   if (mode (int) == TERMINAL)
      isatty = YES
   else
      isatty = NO

   return
   end
#-t-  initst         4393  local  09/22/80  15:38:36
#-h-  lookup          519  local  09/22/80  15:38:37
# lookup --- find a symbol in the symbol table, return its data

   integer function lookup (symbol, info, st)
   character symbol (ARB)
   integer info (ARB)
   pointer st

   DS_DECL(Mem, 1)

   integer i, nodsiz, kluge
   integer stlu

   pointer node, pred

   if (stlu (symbol, node, pred, st) == NO) {
      lookup = NO
      return
      }

   nodsiz = Mem (st)
   for (i = 1; i <= nodsiz; i = i + 1) {
      kluge = node + ST_DATA - 1 + i
      info (i) = Mem (kluge)
      }
   lookup = YES

   return
   end
#-t-  lookup          519  local  09/22/80  15:38:37
#-h-  maksub          879  local  09/22/80  15:38:37
# maksub --- make substitution string in sub

   integer function maksub (arg, from, delim, sub)
   character arg (MAXARG), delim, sub (MAXPAT)
   integer from

   character esc, type

   integer i, j, junk
   integer addset

   j = 1
   for (i = from; arg (i) != delim & arg (i) != EOS; i = i + 1)
      if (arg (i) == AND) {
         junk = addset (DITTO, sub, j, MAXPAT)
         junk = addset (0, sub, j, MAXPAT)
         }
      else if (arg (i) == ESCAPE & type (arg (i + 1)) == DIGIT) {
         i = i + 1
         junk = addset (DITTO, sub, j, MAXPAT)
         junk = addset (arg (i) - DIG0, sub, j, MAXPAT)
         }
      else
         junk = addset (esc (arg, i), sub, j, MAXPAT)
   if (arg (i) != delim)   # missing delimiter
      maksub = ERR
   else if (addset (EOS, sub, j, MAXPAT) == NO)   # no room
      maksub = ERR
   else
      maksub = i
   return
   end
#-t-  maksub          879  local  09/22/80  15:38:37
#-h-  match          333  local  09/22/80  15:38:38
# match --- find match anywhere on line

   integer function match (lin, pat)
   character lin (MAXLINE), pat (MAXPAT)

   integer i, junk (9)
   integer amatch

   for (i = 1; lin (i) != EOS; i = i + 1)
      if (amatch (lin, i, pat, junk, junk) > 0) {
         match = YES
         return
         }
   match = NO
   return
   end
#-t-  match          333  local  09/22/80  15:38:38
#-h-  mktabl          386  local  09/22/80  15:38:38
# mktabl --- make a new (empty) symbol table

   pointer function mktabl (nodsiz)
   integer nodsiz

   DS_DECL(Mem, 1)

   pointer st
   pointer dsget

   integer i

   st = dsget (ST_HTABSIZE + 1)     # +1 for record of nodsiz
   Mem (st) = nodsiz
   mktabl = st
   do i = 1, ST_HTABSIZE; {
      st = st + 1
      Mem (st) = LAMBDA             # null link
      }

   return
   end
#-t-  mktabl          386  local  09/22/80  15:38:38
#-h-  mkuniq          330  local  09/22/80  15:38:38
# mkuniq - get scratch file name based on 'seed'

   subroutine mkuniq (seed, name)
   character seed (ARB), name (ARB)

   # Portable version - return 'seed' as scratch file name
   # In system-dependent version, append process ID or some other
   # unique identifier to 'seed'

   call scopy (seed, 1, name, 1)
   return
   end
#-t-  mkuniq          330  local  09/22/80  15:38:38
#-h-  mntoc         1916  local  09/22/80  15:38:38
# mntoc --- translate ASCII mnemonic into a character

   character function mntoc (buf, p, default)
   character buf (ARB), default
   integer p

   integer i, tp
   integer equal

   character c, tmp (MAXLINE)

   character text (170)
   data text / _
      ACK, LETA, LETC, LETK, EOS,
      BEL, LETB, LETE, LETL, EOS,
      BS,  LETB, LETS, EOS,  EOS,
      CAN, LETC, LETA, LETN, EOS,
      CR,  LETC, LETR, EOS,  EOS,
      DC1, LETD, LETC, DIG1, EOS,
      DC2, LETD, LETC, DIG2, EOS,
      DC3, LETD, LETC, DIG3, EOS,
      DC4, LETD, LETC, DIG4, EOS,
      DEL, LETD, LETE, LETL, EOS,
      DLE, LETD, LETL, LETE, EOS,
      EM,  LETE, LETM, EOS,  EOS,
      ENQ, LETE, LETN, LETQ, EOS,
      EOT, LETE, LETO, LETT, EOS,
      ESC, LETE, LETS, LETC, EOS,
      ETB, LETE, LETT, LETB, EOS,
      ETX, LETE, LETT, LETX, EOS,
      FF,  LETF, LETF, EOS,  EOS,
      FS,  LETF, LETS, EOS,  EOS,
      GS,  LETG, LETS, EOS,  EOS,
      HT,  LETH, LETT, EOS,  EOS,
      LF,  LETL, LETF, EOS,  EOS,
      NAK, LETN, LETA, LETK, EOS,
      NUL, LETN, LETU, LETL, EOS,
      RS,  LETR, LETS, EOS,  EOS,
      SI,  LETS, LETI, EOS,  EOS,
      SO,  LETS, LETO, EOS,  EOS,
      SOH, LETS, LETO, LETH, EOS,
      SP,  LETS, LETP, EOS,  EOS,
      STX, LETS, LETT, LETX, EOS,
      SUB, LETS, LETU, LETB, EOS,
      SYN, LETS, LETY, LETN, EOS,
      US,  LETU, LETS, EOS,  EOS,
      VT,  LETV, LETT, EOS,  EOS/

   tp = 1
   repeat {
      tmp (tp) = buf (p)
      tp = tp + 1
      p = p + 1
      } until (! (IS_LETTER(buf (p)) | IS_DIGIT(buf (p)))
                  | tp >= MAXLINE)
   tmp (tp) = EOS

   if (tp == 2)
      c = tmp (1)
   else {
      call lower (tmp)
      for (i = 1; i < 170; i = i + 5)  # should use binary search here
         if (equal (tmp, text (i + 1)) == YES)
            break
      if (i < 170)
         c = text (i)
      else
         c = default
      }

   return (c)
   end
#-t-  mntoc         1916  local  09/22/80  15:38:38
#-h-  note         1197  local  09/22/80  15:38:39
# note - determine current file position (i.e. place where next
#        record will be read/written

   subroutine note (int, offset)
   filedes int
   integer offset (2)

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   # Transportable version - assume 'offset' is a character count

   offset (1) = ccnt (int) + 1
   return
   end
#-t-  note         1197  local  09/22/80  15:38:39
#-h-  prompt                      302  local   01/06/81  16:14:45
# prompt - write to/read from teletype

   subroutine prompt (str, buf, fd)
   character str(ARB), buf(ARB)
   filedes fd

   integer i
   integer isatty

   if (isatty(fd) == YES)
         {
         call putlin (str, fd)
         call flush (fd)
         }
   call getlin (buf, fd)

   return
   end
#-t-  prompt                      302  local   01/06/81  16:14:45
#-h-  putdec          340  local  09/22/80  15:38:40
# putdec - put decimal integer n in field width >= w

   subroutine putdec(n,w)
   integer n, w

   character chars (MAXCHARS)

   integer i, nd
   integer itoc

   nd = itoc (n, chars, MAXCHARS)
   for (i = nd + 1; i <= w; i = i + 1)
      call putc (BLANK)
   for (i = 1; i <= nd; i = i + 1)
      call putc (chars (i))

   return
   end
#-t-  putdec          340  local  09/22/80  15:38:40
#-h-  query          317  local  09/22/80  15:38:40
# query - print usage message if user has requested one

   subroutine query (mesg)
   character mesg (ARB)

   integer getarg

   character arg1 (3), arg2 (1)

   if (getarg (1, arg1, 3) != EOF & getarg (2, arg2, 1) == EOF)
      if (arg1 (1) == QMARK & arg1 (2) == EOS)
         call error (mesg)

   return
   end
#-t-  query          317  local  09/22/80  15:38:40
#-h-  readf          394  local  09/22/80  15:38:40
# readf - read 'n' bytes/words/whatever from file fd
   #  PORTABLE version - read 'n' characters

   integer function readf (buf, n, fd)
   character buf (ARB)
   integer n
   filedes fd

   character getch

   integer i

   for (i = 1; i <= n; i = i + 1)
      if (getch (buf (i), fd) == EOF) {
         buf (i) = EOS
         return (EOF)
         }

   buf (i) = EOS
   return (i-1)
   end
#-t-  readf          394  local  09/22/80  15:38:40
#-h-  rmtabl          444  local  09/22/80  15:38:40
# rmtabl --- remove a symbol table, deleting all entries

   subroutine rmtabl (st)
   pointer st

   DS_DECL(Mem, 1)

   integer i

   pointer walker, bucket, node

   bucket = st
   do i = 1, ST_HTABSIZE; {
      bucket = bucket + 1
      walker = Mem (bucket)
      while (walker != LAMBDA) {
         node = walker
         walker = Mem (node + ST_LINK)
         call dsfree (node)
         }
      }

   call dsfree (st)
   return
   end
#-t-  rmtabl          444  local  09/22/80  15:38:40
#-h-  sctabl         1554  local  09/22/80  15:38:40
# sctabl --- scan symbol table, returning next entry or EOF

   integer function sctabl (table, sym, info, posn)
   pointer table, posn
   character sym (ARB)
   integer info (ARB)

   DS_DECL(Mem, 1)

   pointer bucket, walker
   pointer dsget

   integer nodsiz, i, j

   if (posn == 0) {                 # just starting scan?
      posn = dsget (2)                 # get space for position info
      Mem (posn) = 1                   # get index of first bucket
      Mem (posn + 1) = Mem (table + 1) # get pointer to first chain
      }

   bucket = Mem (posn)              # recover previous position
   walker = Mem (posn + 1)
   nodsiz = Mem (table)

   repeat {    # until the next symbol, or none are left
      if (walker != LAMBDA) {       # symbol available?
         i = walker + ST_DATA + nodsiz
         j = 1
         while (Mem (i) != EOS) {
            sym (j) = Mem (i)
            i = i + 1
            j = j + 1
            }
         sym (j) = EOS
         for (i = 1; i <= nodsiz; i = i + 1) {
            j = walker + ST_DATA + i - 1
            info (i) = Mem (j)
            }
         Mem (posn) = bucket        # save position of next symbol
         Mem (posn + 1) = Mem (walker + ST_LINK)
         sctabl = 1  # not EOF
         return
         }
      else {
         bucket = bucket + 1
         if (bucket > ST_HTABSIZE)
            break
         j = table + bucket
         walker = Mem (j)
         }
      }

   call dsfree (posn)      # throw away position information
   posn = 0
   sctabl = EOF
   return
   end
#-t-  sctabl         1554  local  09/22/80  15:38:40
#-h-  sdrop          401  local  09/22/80  15:38:41
# sdrop --- drop characters from a string APL-style

   integer function sdrop (from, to, chars)
   character from (ARB), to (ARB)
   integer chars

   integer len, start
   integer ctoc, length, min0

   len = length (from)
   if (chars < 0)
      return (ctoc (from, to, len + chars + 1))
   else {
      start = min0 (chars, len)
      return (ctoc (from (start + 1), to, len + 1))
      }

   end
#-t-  sdrop          401  local  09/22/80  15:38:41
#-h-  seek         1308  local  09/22/80  15:38:41
# seek - move read/write pointer to location 'offset'
   # Portable version - assume offset applies to a character
   # count and locate from beginning of file


   subroutine seek (offset, int)
   integer offset (2), int

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit

   character c

   if (offset (1) <= ccnt (int))
      call rwind (int)
   while (ccnt (int) + 1 < offset (1))
      if (getch (c, int) == EOF)
         break

   return
   end
#-t-  seek         1308  local  09/22/80  15:38:41
#-h-  stake          399  local  09/22/80  15:38:42
# stake --- take characters from a string APL-style

   integer function stake (from, to, chars)
   character from (ARB), to (ARB)
   integer chars

   integer len, start
   integer length, ctoc, max0

   len = length (from)
   if (chars < 0) {
      start = max0 (len + chars, 0)
      return (ctoc (from (start + 1), to, len + 1))
      }
   else
      return (ctoc (from, to, chars + 1))

   end
#-t-  stake          399  local  09/22/80  15:38:42
#-h-  strcmp          435  local  09/22/80  15:38:42
# strcmp - compare 2 strings; return -1 if <, 0 if =, +1 if >

   integer function strcmp (str1, str2)
   character str1 (ARB), str2 (ARB)

   integer i

   for (i = 1; str1 (i) == str2 (i); i = i + 1)
      if (str1 (i) == EOS)
         return (0)

   if (str1 (i) == EOS)
      strcmp = -1
   else if (str2 (i) == EOS)
      strcmp = + 1
   else if (str1 (i) < str2 (i))
      strcmp = -1
   else
      strcmp = +1

   return
   end
#-t-  strcmp          435  local  09/22/80  15:38:42
#-h-  strim          295  local  09/22/80  15:38:42
# strim --- trim trailing blanks and tabs from a string

   integer function strim (str)
   character str (ARB)

   integer lnb, i

   lnb = 0
   for (i = 1; str (i) != EOS; i = i + 1)
      if (str (i) != BLANK & str (i) != TAB)
         lnb = i

   str (lnb + 1) = EOS
   return (lnb)

   end
#-t-  strim          295  local  09/22/80  15:38:42
#-h-  slstr          557  local  09/22/80  15:38:42
# slstr --- slice a substring from a string

   integer function slstr (from, to, first, chars)
   character from (ARB), to (ARB)
   integer first, chars

   integer len, i, j, k
   integer length

   len = length (from)

   i = first
   if (i < 1)
      i = i + len + 1

   if (chars < 0) {
      i = i + chars + 1
      chars = - chars
      }

   j = i + chars - 1
   if (i < 1)
      i = 1
   if (j > len)
      j = len

   for (k = 0; i <= j; k = k + 1) {
      to (k + 1) = from (i)
      i = i + 1
      }
   to (k + 1) = EOS

   return (k)
   end
#-t-  slstr          557  local  09/22/80  15:38:42
#-h-  type         2476  local  09/22/80  15:38:43
# type - determine type of character

   character function type (c)

   character c

   if ((LETA <= c & c <= LETZ) | (BIGA <= c & c <= BIGZ))
      type = LETTER
   else if (DIG0 <= c & c <= DIG9)
      type = DIGIT
   else
      type = c

   # The original version used a table look-up; you'll have to
   # use that method if you have subverted the convention to
   # use ASCII characters internally:
   # integer index
   # character digits(11), lowalf(27), upalf(27)
   # data digits(1) /DIG0/
   # data digits(2) /DIG1/
   # data digits(3) /DIG2/
   # data digits(4) /DIG3/
   # data digits(5) /DIG4/
   # data digits(6) /DIG5/
   # data digits(7) /DIG6/
   # data digits(8) /DIG7/
   # data digits(9) /DIG8/
   # data digits(10) /DIG9/
   # data digits(11) /EOS/
   #
   # data lowalf(1) /LETA/
   # data lowalf(2) /LETB/
   # data lowalf(3) /LETC/
   # data lowalf(4) /LETD/
   # data lowalf(5) /LETE/
   # data lowalf(6) /LETF/
   # data lowalf(7) /LETG/
   # data lowalf(8) /LETH/
   # data lowalf(9) /LETI/
   # data lowalf(10) /LETJ/
   # data lowalf(11) /LETK/
   # data lowalf(12) /LETL/
   # data lowalf(13) /LETM/
   # data lowalf(14) /LETN/
   # data lowalf(15) /LETO/
   # data lowalf(16) /LETP/
   # data lowalf(17) /LETQ/
   # data lowalf(18) /LETR/
   # data lowalf(19) /LETS/
   # data lowalf(20) /LETT/
   # data lowalf(21) /LETU/
   # data lowalf(22) /LETV/
   # data lowalf(23) /LETW/
   # data lowalf(24) /LETX/
   # data lowalf(25) /LETY/
   # data lowalf(26) /LETZ/
   # data lowalf(27) /EOS/
   #
   # data upalf(1) /BIGA/
   # data upalf(2) /BIGB/
   # data upalf(3) /BIGC/
   # data upalf(4) /BIGD/
   # data upalf(5) /BIGE/
   # data upalf(6) /BIGF/
   # data upalf(7) /BIGG/
   # data upalf(8) /BIGH/
   # data upalf(9) /BIGI/
   # data upalf(10) /BIGJ/
   # data upalf(11) /BIGK/
   # data upalf(12) /BIGL/
   # data upalf(13) /BIGM/
   # data upalf(14) /BIGN/
   # data upalf(15) /BIGO/
   # data upalf(16) /BIGP/
   # data upalf(17) /BIGQ/
   # data upalf(18) /BIGR/
   # data upalf(19) /BIGS/
   # data upalf(20) /BIGT/
   # data upalf(21) /BIGU/
   # data upalf(23) /BIGW/
   # data upalf(24) /BIGX/
   # data upalf(25) /BIGY/
   # data upalf(26) /BIGZ/
   # data upalf(27) /EOS/
   #
   # if (index(lowalf, c) > 0)
   #        type = LETTER
   # else if (index(upalf,c) >0)
   #        type = LETTER
   # else if (index(digits,c) > 0)
   #        type = DIGIT
   # else
   #        type = c


   return
   end
#-t-  type         2476  local  09/22/80  15:38:43
#-h-  upper          229  local  09/22/80  15:38:44
# upper - fold all alphas to upper case

   subroutine upper (token)
   character token (ARB)

   character cupper

   integer i

   for (i = 1; token (i) != EOS; i = i + 1)
      token (i) = cupper (token (i))

   return
   end
#-t-  upper          229  local  09/22/80  15:38:44
#-h-  wkday          406  local  09/22/80  15:38:44
# wkday --- get day-of-week corresponding to month,day,year

   integer function wkday (month, day, year)
   integer month, day, year

   integer lmonth, lday, lyear

   lmonth = month - 2
   lday = day
   lyear = year

   if (lmonth <= 0) {
      lmonth = lmonth + 12
      lyear = lyear - 1
      }

   wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 34,
       7) + 1

   return
   end
#-t-  wkday          406  local  09/22/80  15:38:44
#-h-  writef          347  local  09/22/80  15:38:44
# writef - write 'n' bytes/words/whatever to file fd
   #  PORTABLE version - write 'n' characters

   integer function writef (buf, n, fd)
   character buf (ARB)
   integer n
   filedes fd

   integer i

   for (i = 1; i <= n; i = i + 1) {
      if (buf (i) == EOS)
         break
      call putch (buf (i), fd)
      }

   return (i - 1)
   end
#-t-  writef          347  local  09/22/80  15:38:44
#-h-  remove          247  local  09/22/80  15:38:44
# remove - remove a file from the file system

   integer function remove (file)
   character file (ARB)

   call remark ('-Remove- not fully implemented.')
   call putlin (file, ERROUT)
   call remark (':  cannot remove.')
   return (ERR)
   end
#-t-  remove          247  local  09/22/80  15:38:44
#-h-  create         1195  local  09/22/80  15:38:44
# create - associate filename with internal specifier; create file
   # PORTABLE version - cannot tell if file exists or not - just call open


   filedes function create (name, access)
   character name (ARB)
   integer access

   filedes open

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   return (open (name, access))

   end
#-t-  create         1195  local  09/22/80  15:38:44
#-h-  stcopy          283  local  09/22/80  15:38:45
# stcopy - copy string from in (i) to out (j), updating j, excluding EOS

   subroutine stcopy (in, i, out, j)
   character in (ARB), out (ARB)
   integer i, j

   integer k

   for (k = i; in (k) != EOS; k = k + 1) {
      out (j) = in (k)
      j = j + 1
      }
   out(j) = EOS
   return
   end
#-t-  stcopy          283  local  09/22/80  15:38:45
#-h-  makpat         2047  local  09/22/80  15:38:45
# makpat --- make pattern from arg (from), terminate at delim

   integer function makpat (arg, from, delim, pat)
   character arg (MAXARG), delim, pat (MAXPAT)
   integer from

   character esc

   integer i, j, junk, lastcl, lastj, lj,
      tagnst, tagnum, tagstk (9)
   integer addset, getccl, stclos

   j = 1      # pat index
   lastj = 1
   lastcl = 0
   tagnum = 0
   tagnst = 0
   for (i = from; arg (i) != delim & arg (i) != EOS; i = i + 1) {
      lj = j
      if (arg (i) == ANY)
         junk = addset (ANY, pat, j, MAXPAT)
      else if (arg (i) == BOL & i == from)
         junk = addset (BOL, pat, j, MAXPAT)
      else if (arg (i) == EOL & arg (i + 1) == delim)
         junk = addset (EOL, pat, j, MAXPAT)
      else if (arg (i) == CCL) {
         if (getccl (arg, i, pat, j) == ERR) {
            makpat = ERR
            return
            }
         }
      else if (arg (i) == CLOSURE & i > from) {
         lj = lastj
         if (pat (lj) == BOL | pat (lj) == EOL | pat (lj) == CLOSURE |
               pat (lj) == START_TAG | pat (lj) == STOP_TAG)
            break
         lastcl = stclos (pat, j, lastj, lastcl)
         }
      else if (arg (i) == START_TAG) {
         if (tagnum >= 9)    # too many tagged sub-patterns
            break
         tagnum = tagnum + 1
         tagnst = tagnst + 1
         tagstk (tagnst) = tagnum
         junk = addset (START_TAG, pat, j, MAXPAT)
         junk = addset (tagnum, pat, j, MAXPAT)
         }
      else if (arg (i) == STOP_TAG & tagnst > 0) {
         junk = addset (STOP_TAG, pat, j, MAXPAT)
         junk = addset (tagstk (tagnst), pat, j, MAXPAT)
         tagnst = tagnst - 1
         }
      else {
         junk = addset (CHAR, pat, j, MAXPAT)
         junk = addset (esc (arg, i), pat, j, MAXPAT)
         }
      lastj = lj
      }
   if (arg (i) != delim)   # terminated early
      makpat = ERR
   else if (addset (EOS, pat, j, MAXPAT) == NO)   # no room
      makpat = ERR
   else if (tagnst != 0)
      makpat = ERR
   else
      makpat = i
   return
   end
#-t-  makpat         2047  local  09/22/80  15:38:45
#-h-  cant          502  local  09/22/80  15:38:46
# cant - print "file:  can't open" and terminate execution

   subroutine cant (file)
   character file (ARB)

   # string msg ":  can't open"
   character msg(15)
   data msg(1), msg(2), msg(3), msg(4), msg(5), msg(6), msg(7),
      msg(8), msg(9), msg(10), msg(11), msg(12), msg(13), msg(14),
      msg(15) /COLON, BLANK, BLANK,
      LETC, LETA, LETN, SQUOTE, LETT, BLANK,
      LETO, LETP, LETE, LETN, NEWLINE, EOS/

   call putlin (file, ERROUT)
   call putlin (msg, ERROUT)
   call endst

   end
#-t-  cant          502  local  09/22/80  15:38:46
#-h-  delarg          727  local  09/22/80  15:38:46
# delarg - delete reference to specified command line argument

   subroutine delarg (n)
   integer n

   # include args

 ## common block used to hold command line argument information
 # Put on a file called 'args'

 common /args/ nbrarg, ptr (MAXARGS), arg (ARGBUFSIZE)
 integer nbrarg         #number arguments in list; initialize to 0
 integer ptr            #pointers (into 'arg') for each argument
 character arg          #arguments stored as ascii strings terminated
                        #with EOS markers

   integer i

   if (n > nbrarg)        #check for valid argument
      return

   for (i = n; i < nbrarg; i = i + 1)  # rearrange pointers
      ptr (i) = ptr (i + 1)

   nbrarg = nbrarg - 1
   return
   end
#-t-  delarg          727  local  09/22/80  15:38:46
#-h-  errsub          497  local  09/22/80  15:38:46
# errsub - see if argument is ERROUT substitution

   integer function errsub (arg, file, access)

   character arg (ARB), file (ARB)
   integer access

   if (arg (1) == QMARK & arg (2) != QMARK & arg (2) != EOS) {
      errsub = YES
      access = WRITE
      call scopy (arg, 2, file, 1)
      }

   else if (arg (1) == QMARK & arg (2) == QMARK & arg (3) != EOS) {
      errsub = YES
      access = APPEND
      call scopy (arg, 3, file, 1)
      }

   else
      errsub = NO

   return
   end
#-t-  errsub          497  local  09/22/80  15:38:46
#-h-  outsub          510  local  09/22/80  15:38:46
# outsub - determine if argument is STDOUT substitution

   integer function outsub (arg, file, access)
   character arg (ARB), file (ARB)
   integer access

   if (arg (1) == GREATER & arg (2) != GREATER & arg (2) != EOS) {
      outsub = YES
      access = WRITE
      call scopy (arg, 2, file, 1)
      }

   else if (arg (1) == GREATER & arg (2) == GREATER & arg (3) != EOS) {
      access = APPEND
      outsub = YES
      call scopy (arg, 3, file, 1)
      }

   else
      outsub = NO

   return
   end
#-t-  outsub          510  local  09/22/80  15:38:46
#-h-  insub          276  local  09/22/80  15:38:46
# insub - determine if argument is STDIN substitution

   integer function insub (arg, file)
   character arg (ARB), file (ARB)

   if (arg (1) == LESS & arg (2) != EOS) {
      insub = YES
      call scopy (arg, 2, file, 1)
      }
   else
      insub = NO

   return
   end
#-t-  insub          276  local  09/22/80  15:38:46
#-h-  makarg         2928  local  09/22/80  15:38:47
# makarg - get command line arguments from system/user
   # PORTABLE version - prompt user with Fortran read & write

   subroutine makarg

   # include args

 ## common block used to hold command line argument information
 # Put on a file called 'args'

 common /args/ nbrarg, ptr (MAXARGS), arg (ARGBUFSIZE)
 integer nbrarg         #number arguments in list; initialize to 0
 integer ptr            #pointers (into 'arg') for each argument
 character arg          #arguments stored as ascii strings terminated
                        #with EOS markers


   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   integer index, tog, funit, i

   character inmap

   nbrarg = 0

   # Read the command line arguments into the 'arg' array as
   # a single line terminated with an EOS.  The rest of this
   # code will unpack them (assuming they are separated by a blank).

   # The arguments can be picked up directly from the system, if
   # this is possible, or this routine can prompt the user for them.
   # Here's an example of prompting for arguments:

   funit = unit (STDOUT)
   write (funit, 10)
10 format (1x, 5hArgs:)
   funit = unit (STDIN)
   read (funit, 20) (arg (i), i = 1, ARGBUFSIZE)
20 format (ARGBUFSIZE a1)
   for (i = 1; i <= ARGBUFSIZE; i = i + 1)
     arg (i) = inmap (arg (i))
   arg (ARGBUFSIZE) = EOS

   #  The rest of this code will separate the arguments with EOS
   #  markers (instead of blanks) and will strip off quote marks

   index = 1
   for (i = 1; i <= MAXARGS; i = i + 1) {
      if (index < ARGBUFSIZE)
         call skipbl (arg, index)
      if (index >= ARGBUFSIZE)
         break
      ptr (i) = index
      if (arg (index) == SQUOTE | arg (index) == DQUOTE) {
         ptr (i) = index+1
         tog = arg (index)
         index = index + 1
         while (arg (index) != tog & arg (index) != EOS)
            index = index + 1
         }
      else
         while (arg (index) != BLANK & arg (index) != EOS)
            index = index + 1
      arg (index) = EOS
      index = index + 1
      }

   nbrarg = i -1
   return
   end
#-t-  makarg         2928  local  09/22/80  15:38:47
#-h-  trmout          195  local  09/22/80  15:38:48
# trmout - pick up name of output channel to users teletype

   subroutine trmout (name)
   character name (ARB)

   string tname TERMINAL_OUT

   call scopy (tname, 1, name, 1)
   return
   end
#-t-  trmout          195  local  09/22/80  15:38:48
#-h-  termin          193  local  09/22/80  15:38:48
# termin - pick up name of input channel to users teletype

   subroutine termin (name)
   character name (ARB)

   string tname TERMINAL_IN

   call scopy (tname, 1, name, 1)
   return
   end
#-t-  termin          193  local  09/22/80  15:38:48
#-h-  stlu          705  local  09/22/80  15:38:48
# stlu --- symbol table lookup primitive

   integer function stlu (symbol, node, pred, st)
   character symbol (ARB)
   pointer node, pred, st

   DS_DECL(Mem, 1)

   integer hash, i, j, nodsiz
   integer equal

   nodsiz = Mem (st)

   hash = 0
   for (i = 1; symbol (i) != EOS; i = i + 1)
      hash = hash + symbol (i)
   hash = mod (hash, ST_HTABSIZE) + 1

   pred = st + hash
   node = Mem (pred)
   while (node != LAMBDA) {
      i = 1
      j = node + ST_DATA + nodsiz
      while (symbol (i) == Mem (j)) {
         if (symbol (i) == EOS)
            return (YES)
         i = i + 1
         j = j + 1
         }
      pred = node
      node = Mem (pred + ST_LINK)
      }

   return (NO)
   end
#-t-  stlu          705  local  09/22/80  15:38:48
#-h-  amatch         1714  local  09/22/80  15:38:48
# amatch --- (non-recursive) look for match starting at lin (from)

   integer function amatch (lin, from, pat, tagbeg, tagend)
   character lin (MAXLINE), pat (MAXPAT)
   integer from, tagbeg (10), tagend (10)

   integer i, j, offset, stack
   integer omatch, patsiz

   for (i = 1; i <= 10; i = i + 1) {
      tagbeg (i) = 0
      tagend (i) = 0
      }
   tagbeg (1) = from
   stack = 0
   offset = from      # next unexamined input character
   for (j = 1; pat (j) != EOS; j = j + patsiz (pat, j))
      if (pat (j) == CLOSURE) {      # a closure entry
         stack = j
         j = j + CLOSIZE      # step over CLOSURE
         for (i = offset; lin (i) != EOS; )      # match as many as
            if (omatch (lin, i, pat, j) == NO)   # possible
               break
         pat (stack + COUNT) = i - offset
         pat (stack + START) = offset
         offset = i      # character that made us fail
         }
      else if (pat (j) == START_TAG) {
         i = pat (j + 1)
         tagbeg (i + 1) = offset
         }
      else if (pat (j) == STOP_TAG) {
         i = pat (j + 1)
         tagend (i + 1) = offset
         }
      else if (omatch (lin, offset, pat, j) == NO) {  # non-closure
         for ( ; stack > 0; stack = pat (stack + PREVCL))
            if (pat (stack + COUNT) > 0)
               break
         if (stack <= 0) {      # stack is empty
            amatch = 0      # return failure
            return
            }
         pat (stack + COUNT) = pat (stack + COUNT) - 1
         j = stack + CLOSIZE
         offset = pat (stack + START)  +  pat (stack + COUNT)
         }
      # else omatch succeeded

   amatch = offset
   tagend (1) = offset
   return      # success
   end
#-t-  amatch         1714  local  09/22/80  15:38:48
#-h-  lower          135  local  09/22/80  15:38:49
# lower - fold all letters to lower case

   subroutine lower (token)
   character token (ARB)

   call fold (token)

   return
   end
#-t-  lower          135  local  09/22/80  15:38:49
#-h-  flush         1236  local  09/22/80  15:38:49
# flush - flush output buffer of file 'fd'
   # PORTABLE version - simply output line

   subroutine flush (int)
   filedes int

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   if (filenm (1, int) == EOS)             # error, file not really open
      return
   if (lastc (int) > 0 & filacc (int) != READ)  # flush buffer
      call putch (NEWLINE,int)

   return
   end
#-t-  flush         1236  local  09/22/80  15:38:49
#-h-  putc          119  local  09/22/80  15:38:49
# putc - put character onto STDOUT

   subroutine putc (c)
   character c

   call putch (c, STDOUT)

   return
   end
#-t-  putc          119  local  09/22/80  15:38:49
#-h-  getarg          975  local  09/22/80  15:38:49
# getarg - get specified command line argument
   #  see the routine 'markarg' for storing the arguments in an array

   integer function getarg (n, array, maxsiz)
   integer n, maxsiz
   character array (maxsiz)

   # include args

 ## common block used to hold command line argument information
 # Put on a file called 'args'

 common /args/ nbrarg, ptr (MAXARGS), arg (ARGBUFSIZE)
 integer nbrarg         #number arguments in list; initialize to 0
 integer ptr            #pointers (into 'arg') for each argument
 character arg          #arguments stored as ascii strings terminated
                        #with EOS markers

   integer index, i

   if (n < 1 | n > nbrarg) {  # no argument 'n'
      array (1) = EOS
      getarg = EOF
      return
      }

   index = ptr (n)
   for (i = 1; i <= maxsiz; i = i + 1) {
      array (i) = arg (index)
      if (arg (index) == EOS)  break
      index = index + 1
      }
   array (i) = EOS
   getarg = i - 1

   return
   end
#-t-  getarg          975  local  09/22/80  15:38:49
#-h-  dsfree         1078  local  09/22/80  15:38:50
# dsfree --- return a block of storage to the available space list

   subroutine dsfree (block)
   pointer block

   DS_DECL(Mem, 1)

   pointer p0, p, q

   integer n, junk

   character con (10)

   p0 = block - DS_OHEAD
   n = Mem (p0 + DS_SIZE)
   q = DS_AVAIL

   repeat {
      p = Mem (q + DS_LINK)
      if (p == LAMBDA | p > p0)
         break
      q = p
      }

   if (q + Mem (q + DS_SIZE) > p0) {
      call remark ("in dsfree:  attempt to free unallocated block.")
      call remark ("type 'c' to continue.")
      junk = getlin (con, STDIN)
      if (con (1) != LETC & con (1) != BIGC)
         call endst
      return      # do not attempt to free the block
      }

   if (p0 + n == p & p != LAMBDA) {
      n = n + Mem (p + DS_SIZE)
      Mem (p0 + DS_LINK) = Mem (p + DS_LINK)
      }
   else
      Mem (p0 + DS_LINK) = p

   if (q + Mem (q + DS_SIZE) == p0) {
      Mem (q + DS_SIZE) = Mem (q + DS_SIZE) + n
      Mem (q + DS_LINK) = Mem (p0 + DS_LINK)
      }
   else {
      Mem (q + DS_LINK) = p0
      Mem (p0 + DS_SIZE) = n
      }

   return
   end
#-t-  dsfree         1078  local  09/22/80  15:38:50
#-h-  dsget          995  local  09/22/80  15:38:50
# dsget --- get pointer to block of at least w available words

   pointer function dsget (w)
   integer w

   DS_DECL(Mem, 1)

   pointer p, q, l

   integer n, k, junk
   integer getlin

   character c (10)

   n = w + DS_OHEAD
   q = DS_AVAIL

   repeat {
      p = Mem (q + DS_LINK)
      if (p == LAMBDA) {
         call remark ("in dsget: out of storage space.")
         call remark ("type 'c' or 'i' for char or integer dump.")
         junk = getlin (c, STDIN)
         if (c (1) == LETC | c (1) == BIGC)
            call dsdump (LETTER)
         else if (c (1) == LETI | c (1) == BIGI)
            call dsdump (DIGIT)
         call error ("program terminated.")
         }
      if (Mem (p + DS_SIZE) >= n)
         break
      q = p
      }

   k = Mem (p + DS_SIZE) - n
   if (k >= DS_CLOSE) {
      Mem (p + DS_SIZE) = k
      l = p + k
      Mem (l + DS_SIZE) = n
      }
   else {
      Mem (q + DS_LINK) = Mem (p + DS_LINK)
      l = p
      }

   return (l + DS_OHEAD)

   end
#-t-  dsget          995  local  09/22/80  15:38:50
#-h-  ctoc          290  local  09/22/80  15:38:50
# ctoc --- convert EOS-terminated string to EOS-terminated string

   integer function ctoc (from, to, len)
   integer len
   character from (ARB), to (len)

   integer i

   for (i = 1; i < len & from (i) != EOS; i = i + 1)
      to (i) = from (i)

   to (i) = EOS

   return (i - 1)

   end
#-t-  ctoc          290  local  09/22/80  15:38:50
#-h-  cupper          195  local  09/22/80  15:38:51
# cupper - change letter to upper case

   character function cupper (c)
   character c

   if (c >= LETA & c <= LETZ)
      cupper = c + (BIGA - LETA)
   else
      cupper = c

   return
   end
#-t-  cupper          195  local  09/22/80  15:38:51
#-h-  open         1407  local  09/22/80  15:38:51
# open - associate filename with internal specifier; attach file
   #   PORTABLE version - fortran IO

   integer function open (name, access)
   character name (ARB)
   integer access

   integer i
   integer assign

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   for (i = 1; i <= MAXOFILES; i = i + 1)    # locate an unused unit
      if (filenm (1, i) == EOS)
         break
   if (i > MAXOFILES)                        # no space left
      return (ERR)
   open = assign (name, i, access)           # assign file to unit
   return
   end
#-t-  open         1407  local  09/22/80  15:38:51
#-h-  stclos          635  local  09/22/80  15:38:51
# stclos --- insert closure entry at pat (j)

   integer function stclos (pat, j, lastj, lastcl)
   character pat (MAXPAT)
   integer j, lastj, lastcl

   integer addset
   integer jp, jt, junk

   for (jp = j - 1; jp >= lastj; jp = jp - 1) {   # make a hole
      jt = jp + CLOSIZE
      junk = addset (pat (jp), pat, jt, MAXPAT)
      }
   j = j + CLOSIZE
   stclos = lastj
   junk = addset (CLOSURE, pat, lastj, MAXPAT)   # put closure in it
   junk = addset (0, pat, lastj, MAXPAT)         # COUNT
   junk = addset (lastcl, pat, lastj, MAXPAT)    # PREVCL
   junk = addset (0, pat, lastj, MAXPAT)         # START

   return
   end
#-t-  stclos          635  local  09/22/80  15:38:51
#-h-  getccl          623  local  09/22/80  15:38:52
# getccl --- expand char class at arg (i) into pat (j)

   integer function getccl (arg, i, pat, j)
   character arg (MAXARG), pat (MAXPAT)
   integer i, j

   integer jstart, junk
   integer addset

   i = i + 1      # skip over [
   if (arg (i) == NOT) {
      junk = addset (NCCL, pat, j, MAXPAT)
      i = i + 1
      }
   else
      junk = addset (CCL, pat, j, MAXPAT)
   jstart = j
   junk = addset (0, pat, j, MAXPAT)      # leave room for count
   call filset (CCLEND, arg, i, pat, j, MAXPAT)
   pat (jstart) = j - jstart - 1
   if (arg (i) == CCLEND)
      getccl = OK
   else
      getccl = ERR

   return
   end
#-t-  getccl          623  local  09/22/80  15:38:52
#-h-  skipbl          187  local  09/22/80  15:38:52
# skipbl - skip blanks and tabs at lin(i)

   subroutine skipbl(lin, i)
   character lin(ARB)
   integer i

   while (lin (i) == BLANK | lin (i) == TAB)
      i = i + 1

   return
   end
#-t-  skipbl          187  local  09/22/80  15:38:52
#-h-  equal          273  local  09/22/80  15:38:52
# equal - compare str1 to str2;  return YES if equal, NO if not

   integer function equal (str1, str2)
   character str1(ARB), str2(ARB)

   integer i

   for (i = 1; str1 (i) == str2 (i); i = i + 1)
      if (str1 (i) == EOS)
         return (YES)

   return (NO)
   end
#-t-  equal          273  local  09/22/80  15:38:52
#-h-  omatch          953  local  09/22/80  15:38:52
# omatch --- try to match a single pattern at pat (j)

   integer function omatch (lin, i, pat, j)
   character lin (MAXLINE), pat (MAXPAT)
   integer i, j

   integer bump
   integer locate

   omatch = NO
   if (lin (i) == EOS)
      return
   bump = -1
   if (pat (j) == CHAR) {
      if (lin (i) == pat (j + 1))
         bump = 1
      }
   else if (pat (j) == BOL) {
      if (i == 1)
         bump = 0
      }
   else if (pat (j) == ANY) {
      if (lin (i) != NEWLINE)
         bump = 1
      }
   else if (pat (j) == EOL) {
      if (lin (i) == NEWLINE)
         bump = 0
      }
   else if (pat (j) == CCL) {
      if (locate (lin (i), pat, j + 1) == YES)
         bump = 1
      }
   else if (pat (j) == NCCL) {
      if (lin (i) != NEWLINE & locate (lin (i), pat, j + 1) == NO)
         bump = 1
      }
   else
      call error ("in omatch: can't happen.")
   if (bump >= 0) {
      i = i + bump
      omatch = YES
      }

   return
   end
#-t-  omatch          953  local  09/22/80  15:38:52
#-h-  patsiz          516  local  09/22/80  15:38:53
# patsiz --- returns size of pattern entry at pat (n)

   integer function patsiz (pat, n)
   character pat (MAXPAT)
   integer n

   if (pat (n) == CHAR | pat (n) == START_TAG | pat (n) == STOP_TAG)
      patsiz = 2
   else if (pat (n) == BOL | pat (n) == EOL | pat (n) == ANY)
      patsiz = 1
   else if (pat (n) == CCL | pat (n) == NCCL)
      patsiz = pat (n + 1) + 2
   else if (pat (n) == CLOSURE)      # optional
      patsiz = CLOSIZE
   else
      call error ("in patsiz: can't happen.")

   return
   end
#-t-  patsiz          516  local  09/22/80  15:38:53
#-h-  fold          240  local  09/22/80  15:38:53
# fold - fold all letters in a string to lower case

   subroutine fold (token)
   character token (ARB)

   character clower

   integer i

   for (i = 1; token (i) != EOS; i = i + 1)
      token (i) = clower (token (i))

   return
   end
#-t-  fold          240  local  09/22/80  15:38:53
#-h-  dsdump          756  local  09/22/80  15:38:53
# dsdump --- produce semi-readable dump of storage

   subroutine dsdump (form)
   character form

   DS_DECL(Mem, 1)

   pointer p, t, q

   t = DS_AVAIL

   call remark ("** DYNAMIC STORAGE DUMP **.")
   call putint (1, 5, ERROUT)
   call putch (BLANK, ERROUT)
   call putint (DS_OHEAD + 1, 0, ERROUT)
   call remark (" words in use.")

   p = Mem (t + DS_LINK)
   while (p != LAMBDA) {
      call putint (p, 5, ERROUT)
      call putch (BLANK, ERROUT)
      call putint (Mem (p + DS_SIZE), 0, ERROUT)
      call remark (" words available.")
      q = p + Mem (p + DS_SIZE)
      while (q != Mem (p + DS_LINK) & q < Mem (DS_MEMEND))
         call dsdbiu (q, form)
      p = Mem (p + DS_LINK)
      }

   call remark ("** END DUMP **.")
   return
   end
#-t-  dsdump          756  local  09/22/80  15:38:53
#-h-  getlin          456  local  09/22/80  15:38:53
# getlin - get line by repeated calls to getch

   integer function getlin (line, int)
   character line (MAXLINE)
   filedes int

   integer i

   character getch

   for (i = 1; i < MAXLINE; i = i + 1)
      if (getch (line (i), int) == NEWLINE) {
         line (i + 1) = EOS
         return (i)
         }
      else if (line (i) == EOF) {
         line (i) = EOS
         return (EOF)
         }

   line (MAXLINE) = EOS
   return (MAXLINE - 1)
   end
#-t-  getlin          456  local  09/22/80  15:38:53
#-h-  assign         1419  local  09/22/80  15:38:53
# assign - associate file with specified unit 'int'
   #  PORTABLE version using fortran IO

   integer function assign (name, int, access)
   character name (ARB)
   integer int, access

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   if (int < 1 | int > MAXOFILES)
      assign = ERR
   else {
      call scopy (name, 1, filenm (1, int), 1)
      assign = int
      lastc (int) = 0
      ccnt (int) = 0
      filacc (int) = access
      }

   if (mode (int) == DISK)
      call rwind (int)                 # position file at beginning

   return
   end
#-t-  assign         1419  local  09/22/80  15:38:53
#-h-  filset         1102  local  09/22/80  15:38:54
# filset --- expand set at  array (i)  into  set (j),  stop at  delim

   subroutine filset (delim, array, i, set, j, maxset)
   integer i, j, maxset
   character array (ARB), delim, set (maxset)

   character esc

   integer junk
   integer addset, index

   string digits "0123456789"
   string lowalf "abcdefghijklmnopqrstuvwxyz"
   string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

   for ( ; array (i) != delim & array (i) != EOS; i = i + 1)
      if (array (i) == ESCAPE)
         junk = addset (esc (array, i), set, j, maxset)
      else if (array (i) != DASH)
         junk = addset (array (i), set, j, maxset)
      else if (j <= 1 | array (i + 1) == EOS)   # literal -
         junk = addset (DASH, set, j, maxset)
      else if (index (digits, set (j - 1)) > 0)
         call dodash (digits, array, i, set, j, maxset)
      else if (index (lowalf, set (j - 1)) > 0)
         call dodash (lowalf, array, i, set, j, maxset)
      else if (index (upalf, set (j - 1)) > 0)
         call dodash (upalf, array, i, set, j, maxset)
      else
         junk = addset (DASH, set, j, maxset)
   return
   end
#-t-  filset         1102  local  09/22/80  15:38:54
#-h-  error          144  local  09/22/80  15:38:54
# error - print message and terminate execution

   subroutine error (line)
   character line (ARB)

   call remark (line)
   call endst
   end
#-t-  error          144  local  09/22/80  15:38:54
#-h-  locate          345  local  09/22/80  15:38:54
# locate --- look for c in char class at pat (offset)

   integer function locate (c, pat, offset)
   character c, pat (MAXPAT)
   integer offset

   integer i

   # size of class is at pat (offset), characters follow
   for (i = offset + pat (offset); i > offset; i = i - 1)
      if (c == pat (i))
         return (YES)

   return (NO)
   end
#-t-  locate          345  local  09/22/80  15:38:54
#-h-  clower          274  local  09/22/80  15:38:55
# clower - change letter to lower case

   character function clower(c)
   character c

   character k

   if (c >= BIGA & c <= BIGZ) {
      k = LETA - BIGA   # avoid integer overflow in byte machines
      clower = c + k
      }
   else
      clower = c

   return
   end
#-t-  clower          274  local  09/22/80  15:38:55
#-h-  dsdbiu          839  local  09/22/80  15:38:55
# dsdbiu --- dump contents of block-in-use

   subroutine dsdbiu (b, form)
   pointer b
   character form

   DS_DECL(Mem, 1)

   integer l, s, lmax

   string blanks "          "

   call putint (b, 5, ERROUT)
   call putch (BLANK, ERROUT)
   call putint (Mem (b + DS_SIZE), 0, ERROUT)
   call remark (" words in use.")

   l = 0
   s = b + Mem (b + DS_SIZE)
   if (form == DIGIT)
      lmax = 5
   else
      lmax = 50

   for (b = b + DS_OHEAD; b < s; b = b + 1) {
      if (l == 0)
         call putlin (blanks, ERROUT)
      if (form == DIGIT)
         call putint (Mem (b), 10, ERROUT)
      elif (form == LETTER)
         call putch (Mem (b), ERROUT)
      l = l + 1
      if (l >= lmax) {
         l = 0
         call putch (NEWLINE, ERROUT)
         }
      }

   if (l != 0)
      call putch (NEWLINE, ERROUT)

   return
   end
#-t-  dsdbiu          839  local  09/22/80  15:38:55
#-h-  getch         1419  local  09/22/80  15:38:55
# getch - get characters from file f

   character function getch (c, int)
   character c
   filedes int

   integer f, n, count
   integer getr

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   n = lastc (int)

   if (n == 0 | buffer (n, int) == NEWLINE | n >= MAXLINE) {
      count = getr (unit (int), buffer (1, int), MAXCARD)
      if (count == EOF) {
         c = EOF
         return (EOF)
         }
      lastc (int) = 0
      }

   lastc (int) = lastc (int) + 1
   ccnt (int) = ccnt (int) + 1
   c = buffer (lastc (int), int)
   return (c)
   end
#-t-  getch         1419  local  09/22/80  15:38:55
#-h-  scopy          298  local  09/22/80  15:38:56
# scopy - copy string at from (i) to to (j)

   subroutine scopy (from, i, to, j)
   character from (ARB), to (ARB)
   integer i, j

   integer k1, k2

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

   return
   end
#-t-  scopy          298  local  09/22/80  15:38:56
#-h-  dodash          466  local  09/22/80  15:38:56
# dodash --- expand array (i-1)-array (i+1) into set (j)... from valid

   subroutine dodash (valid, array, i, set, j, maxset)
   integer i, j, maxset
   character valid (ARB), array (ARB), set (maxset)

   character esc

   integer junk, k, limit
   integer addset, index

   i = i + 1
   j = j - 1
   limit = index (valid, esc (array, i))
   for (k = index (valid, set (j)); k <= limit; k = k + 1)
      junk = addset (valid (k), set, j, maxset)

   return
   end
#-t-  dodash          466  local  09/22/80  15:38:56
#-h-  endst         1090  local  09/22/80  15:38:56
# endst -- close all files and terminate rat4 program

   subroutine endst

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   integer int

   for (int = 1; int <= MAXOFILES; int = int + 1)
      call close (int)

   stop
   end
#-t-  endst         1090  local  09/22/80  15:38:56
#-h-  putlin          233  local  09/22/80  15:38:57
# putlin - put out line by repeated calls to putch

   subroutine putlin (line, int)
   character line (ARB)
   filedes int

   integer i

   for (i = 1; line (i) != EOS; i = i + 1)
      call putch (line (i), int)

   return
   end
#-t-  putlin          233  local  09/22/80  15:38:57
#-h-  remark         1395  local  09/22/80  15:38:57
# remark - print message; assure NEWLINE

   subroutine remark (line)
   integer line (ARB)

   # Transportable version assumes line is coming in as hollerith array
   # The definition CHARS_PER_WORD should be set to the number of
   # hollerith characters stored in a word

   # No portable way to determine end of string, so just print 20 chars.

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   integer funit, i

   funit = unit (ERROUT)
   write (funit, 90) (line (i), i = 1, 20)
90 format (20A CHARS_PER_WORD)
   return
   end
#-t-  remark         1395  local  09/22/80  15:38:57
#-h-  putint          257  local  09/22/80  15:38:57
# putint - output integer in specified field

   subroutine putint (n, w, fd)
   integer n, w
   filedes fd

   character chars (MAXCHARS)

   integer junk
   integer itoc

   junk = itoc (n, chars, MAXCHARS)
   call putstr (chars, w, fd)

   return
   end
#-t-  putint          257  local  09/22/80  15:38:57
#-h-  getr          821  local  09/22/80  15:38:57
# getr - get next record from unit f
   # Portable version (Fortran IO)

   integer function getr (f, buf, maxsiz)
   integer f, maxsiz
   character buf (ARB)

   character inmap

   integer i

#----------------------------------------------------------------
#
# Alter this read statement if it is not standard on your system:
#
#----------------------------------------------------------------

   read (f, 1, end = 10) (buf (i), i = 1, maxsiz)
1  format (MAXCARD a1)
   for (i = 1; i <= MAXCARD; i = i + 1)   # convert characters to ASCII
      buf (i) = inmap (buf (i))
   for (i = MAXCARD; i > 0; i = i - 1)    # remove trailing blanks
      if (buf (i) != BLANK)
         break
   buf (i + 1) = NEWLINE  #mark end-of-line with NEWLINE character
   getr = i + 1
   return

10 continue
   getr = EOF
   return
   end
#-t-  getr          821  local  09/22/80  15:38:57
#-h-  addset          279  local  09/22/80  15:38:58
# addset - put c in string (j) if it fits, increment j

   integer function addset (c, str, j, maxsiz)
   integer j, maxsiz
   character c, str (maxsiz)

   if (j > maxsiz)
      addset = NO
   else {
      str(j) = c
      j = j + 1
      addset = YES
      }

   return
   end
#-t-  addset          279  local  09/22/80  15:38:58
#-h-  esc          497  local  09/22/80  15:38:58
# esc - map array (i) into escaped character if appropriate

   character function esc (array, i)
   character array (ARB)
   integer i

   if (array (i) != ESCAPE)
      esc = array (i)
   else if (array (i+1) == EOS)    # @ not special at end
      esc = ESCAPE
   else {
      i = i + 1
      if (array (i) == LETN | array (i) == BIGN)
         esc = NEWLINE
      else if (array (i) == LETT | array (i) == BIGT)
         esc = TAB
      else
         esc = array (i)
      }

   return
   end
#-t-  esc          497  local  09/22/80  15:38:58
#-h-  index          240  local  09/22/80  15:38:58
# index - find character  c  in string  str

   integer function index (str, c)
   character str (ARB), c

   for (index = 1; str (index) != EOS; index = index + 1)
      if (str (index) == c)
         return

   index = 0
   return
   end
#-t-  index          240  local  09/22/80  15:38:58
#-h-  close         1379  local  09/22/80  15:38:59
# close - close file associated with unit 'int'
   #  PORTABLE version - just mark unit as unattached and rewind file


   subroutine close (int)
   filedes int

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   if (filenm (1, int) == EOS)             # error, file not really open
      return
   if (lastc (int) > 0 & filacc (int) != READ)  # flush buffer
      call putch (NEWLINE, int)
   if (mode (int) == DISK)
      call rwind (int)                     # rewind file
   filenm (1, int) = EOS

   return
   end
#-t-  close         1379  local  09/22/80  15:38:59
#-h-  putstr          427  local  09/22/80  15:38:59
# putstr - output character string in specified field

   subroutine putstr (str, w, fd)
   character str (ARB)
   integer w
   filedes fd

   character length

   integer i, len

   len = length (str)
   for (i = len + 1; i <= w; i = i + 1)
      call putch (BLANK, fd)
   for (i = 1; i <= len; i = i + 1)
      call putch (str (i), fd)
   for (i = (-w) - len; i > 0; i = i - 1)
      call putch (BLANK, fd)

   return
   end
#-t-  putstr          427  local  09/22/80  15:38:59
#-h-  itoc         1033  local  09/22/80  15:38:59
# itoc - convert integer  int  to char string in  str

   integer function itoc (int, str, size)
   integer int, size
   character str (ARB)

   integer mod
   integer d, i, intval, j, k

   # string digits "0123456789"
   character digits (11)
   data digits (1) /DIG0/,
      digits (2) /DIG1/,
      digits (3) /DIG2/,
      digits (4) /DIG3/,
      digits (5) /DIG4/,
      digits (6) /DIG5/,
      digits (7) /DIG6/,
      digits (8) /DIG7/,
      digits (9) /DIG8/,
      digits (10) /DIG9/,
      digits (11) /EOS/

   intval = iabs (int)
   str (1) = EOS
   i = 1
   repeat {                          # generate digits
      i = i + 1
      d = mod (intval, 10)
      str (i) = digits (d+1)
      intval = intval / 10
      } until (intval == 0 | i >= size)

   if (int < 0 & i < size) {         # then sign
      i = i + 1
      str (i) = MINUS
      }
   itoc = i - 1

   for (j = 1; j < i; j = j + 1) {   # then reverse
      k = str (i)
      str (i) = str (j)
      str (j) = k
      i = i - 1
      }

   return
   end
#-t-  itoc         1033  local  09/22/80  15:38:59
#-h-  inmap          237  local  09/22/80  15:39:00
# inmap - convert hollerith characters to ascii

   character function inmap (c)
   character c

   # You must supply your own version of INMAP here, or
   #    use the Fortran version developed in the test of COPY

   return (c)
   end
#-t-  inmap          237  local  09/22/80  15:39:00
#-h-  rwind         1101  local  09/22/80  15:39:00
# rwind - rewind file (Fortran version)

   subroutine rwind (int)
   integer int

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit

   integer funit

   ccnt (int) = 0
   lastc (int) = 0
   funit = unit (int)
   rewind funit
   return
   end
#-t-  rwind         1101  local  09/22/80  15:39:00
#-h-  putch         1497  local  09/22/80  15:39:00
# putch - put character 'c' onto file 'int'
   # Portable version - fortran IO


   subroutine putch (c, int)
   character c
   filedes int

   character outmap

   integer  i, n

   # include io

 ## io - common block holding I/O information for portable primitives
 # put on a file called 'io'

 common /io/  unit (MAXOFILES), lastc (MAXOFILES), ccnt (MAXOFILES),
              filacc (MAXOFILES), mode (MAXOFILES), ftype (MAXOFILES),
              filenm (FILENAMESIZE, MAXOFILES),
              buffer (MAXLINE, MAXOFILES)

    integer unit        # fortran unit number
    integer lastc       # pointer to last character in unit's buffer
    integer ccnt        # number characters read/written in file
                        # (used only by seek)
    integer filacc      # access used to open file
                        # (READ, WRITE, READWRITE, or APPEND)
    integer mode        # device mode (DISK or TERMINAL)
    integer ftype       # file type (LOCAL, ASCII, BINARY)
    character filenm    # file name associated with unit
    character buffer    # line buffer for unit


   if (int <= 0)
      return
   n = lastc (int)
   if (n >= MAXLINE | c == NEWLINE) {     # time to write out record
      call putr (unit (int), buffer (1,int), n)
      lastc (int) = 0
      }
   if (c != NEWLINE) {
      lastc (int) = lastc (int) + 1
      n = lastc (int)
      buffer (n, int) = outmap (c)
      }
   ccnt (int) = ccnt (int) + 1      #keep count of characters written

   return
   end
#-t-  putch         1497  local  09/22/80  15:39:00
#-h-  length          184  local  09/22/80  15:39:01
# length - compute length of string

   integer function length (str)
   character str (ARB)

   for (length = 0; str (length+1) != EOS; length = length + 1)
      ;

   return
   end
#-t-  length          184  local  09/22/80  15:39:01
#-h-  outmap          238  local  09/22/80  15:39:01
# outmap - convert ascii characters to hollerith

   character function outmap (c)
   character c

   # You must supply your own version of OUTMAP here, or
   #    use the Fortran code developed for the test of COPY

   return (c)
   end
#-t-  outmap          238  local  09/22/80  15:39:01
#-h-  putr          279  local  09/22/80  15:39:01
# putr - write record of length 'n' to unit f

   subroutine putr (f, buf, n)
   integer f, n
   character buf (ARB)

   integer i

   if (n <= 0)
      write (f, 2)
   else
      write (f, 1) (buf (i), i = 1, n)

1       format (MAXCARD a1)
2       format (/)

   return
   end
#-t-  putr          279  local  09/22/80  15:39:01
