C ACM ALGORITHM 568
C
C PDS - A PORTABLE FILE DIRECTORY SYSTEM
C
C BY DAVID HANSON
C
C ACM TRANSACTIONS ON PROGRAMMING LANGUAGES AND SYSTEMS, APRIL 1981
C
#========== TAPE INFORMATION ==========
#
#  THIS TAPE CONTAINS ONE FILE SEGMENTED INTO SEVERAL PIECES.  EACH
#  SEGMENT IS PRECEDED BY A LINE BEGINNING WITH #==========.  WITHIN EACH
#  SEGMENT, INDIVIDUAL FILES BEGIN WITH A HEADER LINE OF THE FORM
#
#     #-H- NAME
#
#  WHERE "NAME" IS THE FILE NAME USED ON THE DEC-10.  OTHER INFORMATION ON
#  THE HEADER LINE INCLUDES FILE SIZE AND DATE AND TIME INDICATORS, BUT IS
#  NOT REQUIRED FOR THE USE OF THE FILES.
#
#  THE FOLLOWING SEQMENTS ARE INCLUDED.
#
#     PDS IN RATFOR AND FORTRAN
#     RATFOR PREPROCESSOR AND I/O SYSTEM IN RATFOR AND FORTRAN
#     DEC-10 I/O SYSTEM
#     CYBER I/O SYSTEM
#     LIBRARY OF USEFUL RATFOR ROUTINES
#
#========== PDS IN RATFOR AND FORTRAN ==========
#-H- PDS.DOC 12610 1980 103 2200
# NAME
#    PDS - PORTABLE FILE DIRECTORY SYSTEM
#
# FILES
#    C*            LABELED COMMONS
#    PDSDEF        DEFINITIONS
#    RATDEF        STANDARD RATFOR DEFINITIONS
#    PDS[1-6].RAT  PDS CODE IN RATFOR
#    PDS.FOR       PDS CODE IN FORTRAN
#
# DESCRIPTION
#    THE PDS IS A SET OF SUBROUTINES AND FUNCTIONS THAT PROVIDE A
#    MACHINE-INDEPENDENT DIRECTORY STRUCTURE FOR ACCESSING
#    MACHINE-DEPENDENT FILES.  IN THE SIMPLEST TERMS, THE PDS PROVIDES
#    A MAPPING FROM MACHINE-INDEPENDENT FILE NAMES TO MACHINE-DEPENDENT
#    NAMES.
#
#    THE BASIC TECHNIQUE USED IN THE PDS IS THE SEPARATION OF THE
#    INFORMATION DESCRIBING A FILE FROM THE FILE ITSELF.  THE PDS DEALS
#    ONLY WITH THE FORMER; IT DOES NOT USE OR MANIPULATE, IN ANY WAY,
#    THE ACTUAL FILES.  THE PDS IS USED TO SPECIFY A FILE BUT DOES NOT
#    PARTICIPATE IN THE ACTUAL I/O TO THAT FILE.  AS A RESULT, THERE IS
#    NO IMPACT ON I/O EFFICIENCY WHEN THE PDS IS USED.  USE OF THE PDS
#    IMPLIES USE OF A MACHINE-INDEPENDENT DIRECTORY SYSTEM TO LOCATE
#    FILES, AND A MACHINE-DEPENDENT I/O SYSTEM TO ACCESS THEM.
#
#    THE DIRECTORY STRUCTURE PROVIDED BY THE PDS IS ESSENTIALLY THE
#    ROOTED TREE SYSTEM FOUND IN UNIX.  PDS NAMES SPECIFY A "PATH" TO
#    THE INDICATED FILE.  A PATH NAMES SPECIFIES THE PATH IN TERMS OF
#    DIRECTORIES, AND ENDS IN THE NAME OF THE FILE.  COMPONENTS ARE
#    SEPARATED BY SLASHES.  FOR EXAMPLE, "/USER/SOURCE/PDS.RAT" MIGHT
#    BE USED TO SPECIFY A FILE NAMED "PDS.RAT" IN THE DIRECTORY
#    "SOURCE", WHICH RESIDES IN "USER", WHICH RESIDES THE ROOT (DENOTED
#    "/").  IN THE SUBROUTINES AND FUNCTIONS DESCRIBED BELOW, THE TERM
#    "PATH" REFERS TO A PDS PATH SPECIFICATION AND THE TERM "HOST NAME"
#    REFERS TO A NAME FOR A FILE ON THE HOST SYSTEM.  THE PRIMARY
#    FUNCTION OF THE PDS IS TO MAP PATH NAMES TO HOST NAMES.
#
#    THE NOTION OF A "WORKING DIRECTORY" IS ALSO SUPPORTED.  IF A PATH
#    NAME DOES NOT BEGIN WITH A "/", IT IS TAKEN TO BE ROOTED AT THE
#    CURRENT WORKING DIRECTORY.  INITIALLY, THE WORKING DIRECTORY IS
#    "/".
#
#    THE NAMES "." AND ".." REFER TO THE CURRENT DIRECTORY AND TO THE
#    IMMEDIATE ANCESTOR OF THE CURRENT DIRECTORY, RESPECTIVELY.  THESE
#    NAMES MAY BE USED AS COMPONENTS OF A PATH NAME, E.G. "../FOO".
#
#    INTEGER CHDIR
#    CHARACTER PATH(ARB)
#    INTEGER STATUS
#    STATUS = CHDIR(PATH)
#       CHDIR CHANGES THE CURRENT WORKING DIRECTORY TO THE DIRECTORY
#       SPECIFIED IN "PATH".  IF SUCCESSFUL, CHDIR RETURNS NOERR.  IF
#       THE SPECIFIED PATH CANNOT BE FOUND, OR DOES NOT REFER TO A
#       DIRECTORY, CHDIR RETURNS ERR.
#
#    INTEGER CHDS
#    CHARACTER ROOT(ARB), ILIST(ARB)
#    INTEGER STATUS
#    STATUS = CHDS(ROOT, ILIST)
#       CHDS IS USED TO DIRECT THE ATTENTION OF THE PDS TO A COMPLETELY
#       DIFFERENT DIRECTORY SYSTEM.  THE ARGUMENTS SPECIFY THE HOST
#       NAMES OF THE TWO FILES THAT CHARACTERIZE A DIRECTORY SYSTEM
#       (KNOWN AS THE ROOT AND ILIST).  THESE FILES MUST EXIST; SEE
#       MKDS.  IF THE CHANGE WAS SUCCESSFUL, CHDS RETURNS NOERR.  IF
#       EITHER OF THE FILES COULD NOT BE OPENED, NO CHANGE OF ATTENTION
#       IS MADE AND CHDS RETURNS ERR.  INITIALLY, THE PDS ATTEMPTS TO
#       ACCESS THE DIRECTORY SYSTEM WHOSE ROOT AND ILIST FILES ARE
#       GIVEN BY THE HOST NAMES "ROOT" AND "ILIST".
#
#    INTEGER CREATF
#    CHARACTER PATH(ARB)
#    INTEGER FD, MODE
#    FD = CREATF(PATH, MODE)
#       CREATF CREATES THE FILE INDICATED BY THE CONTENTS OF "PATH" AND
#       OPENS IT FOR I/O ACCORDING TO THE VALUE OF "MODE".  A HOST NAME
#       FOR THE FILE IS GENERATED AND THAT FILE IS CREATED.  THE VALUE
#       OF "MODE" IS WHATEVER IS APPROPRIATE FOR OPENING A FILE ON THE
#       HOST SYSTEM; SEE OPENF.  IF THE FILE CREATION AND OPENING WAS
#       SUCCESSFUL, CREATF RETURNS A "FILE DESCRIPTOR", WHICH IS
#       WHATEVER IS APPROPRIATE AS AN ARGUMENT TO I/O FUNCTIONS (E.G. A
#       FORTRAN UNIT NUMBER).  IF THE CREATION WAS UNSUCCESSFUL, CREATF
#       RETURNS ERR.
#
#    INTEGER LINK
#    CHARACTER PATH1(ARB), PATH2(ARB)
#    INTEGER STATUS
#    STATUS = LINK(PATH1, PATH2)
#       LINK MAKES THE PATH SPECIFIED BY THE CONTENTS OF "PATH1" REFER
#       TO THE SAME FILE SPECIFIED BY THE CONTENTS OF "PATH2".  THE
#       FILE SPECIFIED BY "PATH2" MUST EXIST AND MUST NOT BE A
#       DIRECTORY.  THE PATH GIVEN IN "PATH1" MUST NOT EXIST.  IF ANY
#       OF THESE CONDITIONS ARE NOT MET, LINK RETURNS ERR.  IF THE
#       LINKING WAS SUCCESSFUL, LINK RETURNS NOERR.
#
#    INTEGER MKDIR
#    CHARACTER PATH(ARB)
#    INTEGER STATUS
#    STATUS = MKDIR(PATH)
#       MKDIR IS USED TO MAKE DIRECTORIES.  THE ARGUMENT SPECIFIES THE
#       NAME OF THE DIRECTORY TO BE CREATED.  IF THE SPECIFIED FILE
#       ALREADY EXISTS, MKDIR RETURNS ERR.  IF THE DIRECTORY CREATION
#       WAS SUCCESSFUL, MKDIR RETURNS THE "I-NUMBER" OF THE NEW
#       DIRECTORY.
#
#    INTEGER MKDS
#    CHARACTER ROOT(ARB), ILIST(ARB)
#    INTEGER STATUS
#    STATUS = MKDS(ROOT, ILIST)
#       MKDS IS USED TO MAKE DIRECTORY SYSTEMS.  THE ARGUMENTS SPECIFY
#       THE HOST FILE NAMES TO BE USED AS THE ROOT AND ILIST,
#       RESPECTIVELY.  IF EITHER THE ROOT OR ILIST CANNOT BE
#       INITIALIZED, MKDS RETURNS ERR.  IF THE DIRECTORY SYSTEM WAS
#       SUCCESSFULLY CREATED, MKDS RETURNS NOERR.
#
#    INTEGER MKFILE
#    CHARACTER PATH(ARB), HNAME(ARB)
#    INTEGER STATUS
#    STATUS = MKFILE(PATH, HNAME)
#       MKFILE MAKES AN ENTRY THE DIRECTORY SYSTEM WHOSE PATH IS
#       DESCRIBED BY THE CONTENTS OF "PATH" AND THAT CORRESPONDS TO THE
#       HOST NAME GIVEN BY THE CONTENTS OF "HNAME".  SUBSEQUENT
#       REFERENCES TO THE GIVEN PATH ARE MAPPED INTO THE HOST NAME.  IF
#       THE HOST NAME IS NULL, ONE IS GENERATED.  IF THE SPECIFIED PATH
#       ALREADY EXISTS, MKFILE RETURNS ERR.  IF THE PATH WAS ENTERED
#       SUCCESSFULLY, MKFILE RETURNS THE I-NUMBER OF THE NEW FILE.
#       MKFILE IS CALLED DIRECTLY BY THE USED RARELY; CALLS TO CREATF
#       OR MKDIR ARE THE USUAL MEANS OF ESTABLISHING NEW FILES.
#
#    INTEGER OPENF
#    CHARACTER PATH(ARB)
#    INTEGER FD, MODE
#    FD = OPENF(PATH, MODE)
#       OPENF OPENS AN EXISTING FILE REFERRED BY THE PATH CONTAINED IN
#       "PATH" FOR I/O ACCORDING TO THE VALUE OF "MODE".  THE VALUE OF
#       "MODE" IS WHATEVER IS APPROPRIATE FOR OPENING A FILE ON THE
#       HOST SYSTEM.  IF THE INDICATED FILE CAN BE OPENED, OPENF
#       RETURNS A "FILE DESCRIPTOR", WHICH IS WHATEVER IS APPROPRIATE
#       AS AN ARGUMENT TO I/O FUNCTIONS (E.G. A FORTRAN UNIT NUMBER).
#       IF THE FILE CANNOT BE OPENED ACCORDING TO "MODE", OPENF RETURNS
#       ERR.
#
#    INTEGER STAT
#    CHARACTER PATH(ARB)
#    INTEGER STATUS, ARRAY(37)
#    STATUS = STAT(PATH, ARRAY)
#       STAT IS USED TO OBTAIN INFORMATION CONCERNING THE FILE WHOSE
#       PATH IS THE CONTENTS OF "PATH".  THE INFORMATION RETURNED IN
#       "ARRAY" IS THE CONTENTS OF THE "I-NODE" FOR THAT FILE.  IF THE
#       INDICATED FILE EXISTS, STAT RETURNS ERR AND FILLS "ARRAY" WITH
#       THE FOLLOWING INFORMATION.
#
#          ARRAY(1)    SYSTEM INFORMATION
#          ARRAY(2)    I-NUMBER OF THIS FILE
#          ARRAY(3)    FILE TYPE: "D" IF DIRECTORY, "P" IF PLAIN FILE
#          ARRAY(4)    NUMBER OF LINKS
#          ARRAY(5)    CREATION TIME (INTEGER OF FORM HHMM)
#          ARRAY(6)    CREATION DATE (INTEGER OF FORM MMDD)
#          ARRAY(7)    CREATION YEAR (INTEGER OF FORM YYYY)
#          ARRAY(8)    TIME OF LAST ACCESS (INTEGER OF FORM HHMM)
#          ARRAY(9)    DATE OF LAST ACCESS (INTEGER OF FORM MMDD)
#          ARRAY(10)   YEAR OF LAST ACCESS (INTEGER OF FORM YYYY)
#          ARRAY(11..37)   HOST NAME AS RIGHT-JUSTIFIED ASCII STRING
#                          TERMINATED BY AN EOS
#
#       IF THE FILE DOES NOT EXIST, STAT RETURNS ERR.
#
#    INTEGER SYNC
#    INTEGER JUNK, STATUS
#    STATUS = SYNC(JUNK)
#       SYNC CAUSES VARIOUS TABLES INTERNAL TO THE PDS TO BE WRITTEN TO
#       THE APPROPRIATE FILES.  SYNC ALWAYS RETURNS NOERR.
#
#    INTEGER UNLINK
#    CHARACTER PATH(ARB)
#    INTEGER STATUS
#    STATUS = UNLINK(PATH)
#       UNLINK REMOVES THE PATH NAME GIVEN BY THE CONTENTS OF "PATH"
#       AND DECREMENTS THE LINK CODE OF THE ASSOCIATED I-NODE.  IF THE
#       RESULTING COUNT IS 0, THE I-NODE IS MADE AVAILABLE FOR REUSE.
#       IF THE FILE INDICATED BY "PATH" IS A DIRECTORY, IT MUST BE
#       EMPTY.  IF THE FILE DOES NOT EXIST, OR IS A NON-EMPTY
#       DIRECTORY, UNLINK RETURNS ERR.  IF THE FILE WAS SUCCESSFULLY
#       UNLINKED, UNLINK RETURNS NOERR.
#
# SEE ALSO
#    DAVID R. HANSON, "A PORTABLE FILE DIRECTORY SYSTEM", TECH. REP.
#    TR79-3A, DEPT. OF COMPUTER SCIENCE, UNIV. ARIZONA, TUCSON, SEP.
#    1979.
#
# DIAGNOSTICS
#    ALL OF THE FOLLOWING ERRORS INDICATE AN INTERNAL INCONSISTENCY
#    WITHIN THE PDS OR ARE THE RESULT OF EXCEEDING A LIMIT.
#
#    UNLINK: ILL-FORMED DIRECTORY
#    ENTER: OUT OF DIRECTORY SPACE
#    RDDIR: NOT A DIRECTORY
#    RDDIR: CAN'T READ DIRECTORY
#    WRDIR: CAN'T CREATE DIRECTORY
#    IALLOC: CAN'T READ ILIST
#    IGET: CAN'T READ ILIST
#    IGET: BAD INUMBER
#    IGET: FREE INODE
#    IREAD: BAD INUMBER
#    IUPDAT: CAN'T READ ILIST
#    IUPDAT: CAN'T CREATE TEMPORARY ILIST
#
# INSTALLATION
#    THE INSTALLATION OF PDS IS STRAIGHTFORWARD, PROVIDING THAT RATFOR
#    AND A RATFOR I/O SYSTEM HAS BEEN INSTALLED.  A TYPICAL APPROACH IS
#    TO SET THE VARIOUS PARAMETERS IN PDS TO THE DESIRED VALUES,
#    COMPILE THE RATFOR CODE, AND PLACE THE OBJECT IN A LIBRARY THAT
#    CAN BE SEARCHED WHEN THE PDS IS TO BE USED.
#
#    THE PARAMETERS ARE DEFINED IN THE DEFINITIONS FILE PDSDEF AND CONSIST
#    MAINLY OF VARIOUS SIZES.  THE IMPORTANT PARAMETERS ARE AS FOLLOWS;
#    THE DEFAULT SIZES ARE GIVEN IN PARENTHESES.
#
#    MAXINODES (30)
#       IS THE SIZE OF THE I-NODE CACHE.  IT SHOULD BE LARGE ENOUGH SO
#       THAT READING THE ILIST CAN BE KEPT TO A MINIMUM.  IF MAXINODES
#       IS CHANGED, INODESSIZE MUST ALSO BE CHANGED SINCE IT IS THE
#       PRODUCT OF I_SIZE AND MAXINODES (SEE PDSDEF).
#
#    MAXINUM (15)
#       IS THE SIZE OF THE I-NODE FREE LIST.  WHEN THE FREE LIST IS
#       EXHAUSTED, THE ENTIRE ILIST IS READ, SO MAXINUM SHOULD NOT BE
#       SMALL.
#
#    MAXDENTRY (250)
#       IS THE MAXIMUM SIZE OF A DIRECTORY IN FILES.  THE PDS HANDLES
#       DIRECTORIES BY READING THEM INTO MEMORY ON THE ASSUMPTION THAT
#       DIRECTORIES ARE NOT VERY LARGE.  THIS PARAMETER MUST BE
#       INCREASED TO HANDLE LARGER DIRECTORIES.  IF MAXDENTRY IS
#       CHANGED, WDIRSIZE MUST BE CHANGED SINCE IT IS THE PRODUCT OF
#       D_SIZE AND MAXDENTRY (SEE PDSDEF).
#
#    MAXFNAME (20)
#       IS THE MAXIMUM SIZE PLUS ONE OF A PATH COMPONENT IN
#       CHARACTERS.
#
#    MAXPATH (80)
#       IS THE MAXIMUM SIZE PLUS ONE OF A PATH.
#
#    MAXTNAME (26)
#       IS THE MAXIMUM SIZE PLUS ONE OF A HOST FILE NAME.  IT THIS IS
#       CHANGED, THE SIZE OF THE I-NODE, GIVEN BY I_SIZE, MUST BE
#       CHANGED AS MUST INODESSIZE (SEE PDSDEF).
#
#    THERE ARE OTHER PARAMETERS; SEE PDSDEF.
#
#    PDS RELIES ON THE STANDARD RATFOR I/O ROUTINES OPEN, CREATE,
#    GETCH, PUTCH, AND CLOSE.  A FORTRAN VERSION OF THESE ROUTINES IS
#    SUPPLIED WITH RATFOR.
#
#    THE FILE PDS6.RAT CONTAINS A NUMBER OF SUPPORT ROUTINES.  SOME OF
#    THESE MAY BE REPLACED BY INSTALLATION-DEPENDENT VERSIONS IF
#    DESIRED.  IN PARTICULAR, AMOVE IS USED TO MOVE A FILE.  THIS IS
#    DONE BY COPYING IT, BUT COULD BE DONE BY A RENAME OPERATION IF
#    THAT IS SUPPORTED ON THE LOCAL SYSTEM.
#
#    BEFORE PDS CAN BE RUN, A STANDARD RATFOR DATE FUNCTION MUST BE
#    PROVIDED.  THE CALL IS
#
#       INTEGER DATE, YEAR, TIME, SECS
#
#       CALL DATE4(DATE, YEAR, TIME, SECS)
#
#    DATE4 RETURNS THE CURRENT DATE AND TIME.  THE CURRENT DATE IS
#    RETURNED IN "DATE" AS AN INTEGER OF THE FORM MMDD (E.G. 1022).
#    THE CURRENT YEAR IS RETURNED IN "YEAR" AS AN INTEGER OF THE FORM
#    YYYY (E.G. 1979).  THE CURRENT TIME IS RETURNED IN "TIME" AS AN
#    INTEGER OF THE FORM HHMM (E.G. 1525, 24-HOUR TIME).  THE NUMBER OF
#    SECONDS PAST THE CURRENT MINUTE IS RETURNED IN "SECS" AS AN
#    INTEGER OF THE FORM SS (E.G. 31).
#
#    FINALLY, THE GENERATION OF HOST NAMES MAY NEED TO BE MODIFIED TO
#    CONFORM TO LOCAL USAGE.  THE DEFAULT NAME IS ILIST.N, WHERE
#    "ILIST" IS THE HOST NAME OF THE ILIST FILE, AND "N" IS THE INUMBER
#    OF THE FILE.  IF THIS CONVENTION IS UNSATISFACTORY, CHANGE THE
#    LAST FEW LINES IN THE FUNCTION IALLOC, WHICH IS IN PDS4.RAT.
#
#-H- PDSDEF 1651 1980 103 2058
INCLUDE RATDEF
 
# PDSDEF: GLOBAL PDS DEFINITIONS
 
# INODE STRUCTURE; I_MOD AND I_INUM ARE ONLY USED FOR IN-CORE COPIES
DEFINE(I_MOD,1)%%# 1 IF MODIFIED
DEFINE(I_INUM,2)%# I-NUMBER OF THIS INODE
DEFINE(I_TYPE,3)%# F FILE TYPE: 0=FREE, D=DIRECTORY, P=PLAIN FILE
DEFINE(I_NLINK,4)%# NUMBER OF LINKS
DEFINE(I_CTIME,5)%# CREATION TIME (INTEGER OF THE FORM HHMM)
DEFINE(I_CDATE,6)%# CREATION DATE (INTEGER OF THE FORM MMDD)
DEFINE(I_CYEAR,7)%# CREATION YEAR (INTEGER OF THE FORM YYYY)
DEFINE(I_ATIME,8)%# LAST ACCESS TIME (INTEGER OF THE FORM HHMM)
DEFINE(I_ADATE,9)%# LAST ACCESS DATE (INTEGER OF THE FORM MMDD)
DEFINE(I_AYEAR,10)%# LAST ACCESS YEAR (INTEGER OF THE FORM YYYY)
DEFINE(I_TNAME,11)%# FILE NAME ON TARGET SYSTEM
DEFINE(I_SIZE,37)%# SIZE OF INODE
DEFINE(I_SAVE,10)%# NUMBER OF ILIST MODIFICATIONS BEFORE UPDATE
 
# DIRECTORY STRUCTURE
DEFINE(D_INUM,1)%# I-NUMBER
DEFINE(D_NAME,2)%# START OF NAME
DEFINE(D_SIZE,21)%# SIZE OF DIRECTORY ENTRY
DEFINE(D_SAVE,10)%# NUMBER OF WDIR MODIFICATIONS BEFORE UPDATE
 
# FLAGS
DEFINE(PLAIN,LETP)%# FILE IS A "PLAIN OLD FILE"
DEFINE(DIRECTORY,LETD)%# FILE IS A DIRECTORY
DEFINE(UNUSED,DIG0)%# INODE IS FREE
 
# CONSTANTS
DEFINE(ROOTDIR,1)%# INODE NUMBER OF THE ROOT DIRECTORY
 
# SIZES
DEFINE(MAXINODES,30)%# NUMBER OF IN-CORE INODES (MUST BE >= 4)
DEFINE(MAXINUM,15)%# SIZE OF INODE FREE LIST
DEFINE(MAXDENTRY,250)%# NUMBER OF ENTRIES IN A DIRECTORY
DEFINE(MAXFNAME,20)%# MAXIMUM SIZE OF A PDS FILE NAME
DEFINE(MAXPATH,80)%# MAXIMUM LENGTH OF A PATH NAME
DEFINE(MAXTNAME,26)%# MAXIMUM LENGTH OF A HOST FILE NAME
DEFINE(WDIRSIZE,5250)%# MUST BE D_SIZE*MAXDENTRY
DEFINE(INODESSIZE,1110)%# MUST BE I_SIZE*MAXINODES
#-H- CINODE 584 1980 103 2058
COMMON /CINODE/ NINODE, INUM(MAXINUM), INODES(INODESSIZE), IMOD,
   INAME(MAXTNAME), RNAME(MAXTNAME), IBUF(MAXLINE), IFD, IPOS
   INTEGER NINODE%# NUMBER OF FREE INODES, INIT = 0
   INTEGER INUM%%# CONTAINS FREE INODE NUMBERS
   CHARACTER INODES%# IN-CORE INODES
   INTEGER IMOD%%# TIMES ILIST HAS BEEN MODIFIED, INIT = 0
   CHARACTER INAME%# NAME OF THE ILIST FILE
   CHARACTER RNAME%# NAME OF THE ROOT FILE
   CHARACTER IBUF%# USED TO READ ILIST FILE
   INTEGER IFD%%# FILE DESCRIPTOR FOR READING ILIST, INIT = EOF
   INTEGER IPOS%%# CURRENT POSITION IN OPENED ILIST FILE, INIT = 0
#-H- CUWDIR 95 1980 103 2058
COMMON /CUWDIR/ IUWDIR
   INTEGER IUWDIR%# INUMBER OF USER'S WORKING DIRECTORY, INIT = ROOTDIR
#-H- CWDIR 269 1980 103 2058
COMMON /CWDIR/ IWDIR, WSIZE, WDIR(WDIRSIZE), WMOD
   INTEGER IWDIR%# INODE NUMBER FOR WORKING DIRECTORY, INIT = 0
   INTEGER WSIZE%# LENGTH OF WORKING DIRECTORY
   CHARACTER WDIR%# CONTENTS OF WORKING DIRECTORY
   INTEGER WMOD%%# TIMES WDIR HAS BEEN MODIFIED, INIT = 0
#-H- PDS1.RAT 808 1980 103 2058
# PDS1: DATA INITIALIZATION
 
INCLUDE PDSDEF
 
   BLOCK DATA
   INCLUDE CINODE
   INCLUDE CWDIR
   INCLUDE CUWDIR
 
   # INODE STRUCTURE
   DATA NINODE /0/%# NO FREE INODES INITIALLY
   DATA INODES /INODESSIZE*0/   # EMPTY CACHE INITIALLY
   DATA IMOD /0/%# NO MODIFICATIONS INITIALLY
   DATA INAME(1), INAME(2), INAME(3), INAME(4), INAME(5), INAME(6) /_
      LETI, LETL, LETI, LETS, LETT, EOS/%# DEFAULT ILIST NAME
   DATA RNAME(1), RNAME(2), RNAME(3), RNAME(4), RNAME(5) /_
      LETR, LETO, LETO, LETT, EOS/
   DATA IFD /EOF/%# ILIST NOT OPENED INITIALLY
   DATA IPOS /0/%#  "
 
   # WORKING DIRECTORY STRUCTURE
   DATA IWDIR /0/%# NO WORKING DIRECTORY INITIALLY
   DATA WMOD /0/%# NO MODIFICATIONS INITIALLY
 
   # USER'S WORKING DIRECTORY STRUCTURE
   DATA IUWDIR /ROOTDIR/%# / IS INITIAL DIRECTORY
 
   END
#-H- PDS2.RAT 6413 1980 103 2058
# PDS2: PDS USER PRIMITIVES
 
INCLUDE PDSDEF
 
# CHDIR(PATH) - CHANGE USER'S WORKING DIRECTORY TO  PATH
   INTEGER FUNCTION CHDIR(PATH)
   CHARACTER PATH(MAXPATH)
   INTEGER IP, ISCAN, INODE(I_SIZE)
   INCLUDE CUWDIR
 
   IF (ISCAN(PATH, IP) == ERR)
      RETURN(ERR)
   CALL IGET(IP, INODE)
   IF (INODE(I_TYPE) ^= DIRECTORY)
      RETURN(ERR)
   IUWDIR = IP  # SET NEW WORKING DIRECTORY
   RETURN(NOERR)
   END
 
# CHDS(ROOT, ILST) - CHANGE TO ANOTHER DIRECTORY SYSTEM
   INTEGER FUNCTION CHDS(ROOT, ILST)
   CHARACTER ROOT(MAXTNAME), ILST(MAXTNAME)
   INTEGER FD
   INTEGER OPEN
   INCLUDE CINODE
 
   IF (ILST(1) ^= EOS) <
      FD = OPEN(ILST, READ)
      IF (FD == ERR)
         RETURN(ERR)
      CALL CLOSE(FD)
      !
   IF (ROOT(1) ^= EOS) <
      FD = OPEN(ROOT, READ)
      IF (FD == ERR)
         RETURN(ERR)
      CALL CLOSE(FD)
      !
   CALL NEWDIR(0)%# SAVE CURRENT SYSTEM AND CLEAR FOR NEW ONE
   CALL ICLEAR(YES)
   IF (ROOT(1) ^= EOS)
      CALL SCOPY(ROOT, 1, RNAME, 1)   # UPDATE NAMES OF ROOT AND ILIST
   IF (ILST(1) ^= EOS)
      CALL SCOPY(ILST, 1, INAME, 1)
   RETURN(NOERR)
   END
 
# CREATF(PATH, MODE) - CREATE FILE  PATH  AND OPEN IT ACCORDING TO MODE
   INTEGER FUNCTION CREATF(PATH, MODE)
   CHARACTER PATH(MAXPATH)
   INTEGER MODE
   CHARACTER INODE(I_SIZE)
   INTEGER IP, FD, MKFILE, CREATE
   STRING EOSS ""
 
   IP = MKFILE(PATH, EOSS)
   IF (IP == ERR)
      RETURN(ERR)
   CALL IGET(IP, INODE)  # NEED TO GET TARGET NAME
   FD = CREATE(INODE(I_TNAME), MODE)
   IF (FD == ERR)
      CALL IFREE(IP)  # DON'T NEED INODE ANYMORE
   RETURN(FD)
   END
 
# LINK(PATH1, PATH2) - LINK  PATH1  TO  PATH2
   INTEGER FUNCTION LINK(PATH1, PATH2)
   CHARACTER PATH1(MAXPATH), PATH2(MAXPATH)
   CHARACTER INODE(I_SIZE)
   INTEGER I, J, IP, ISCAN, CSCAN, CTOI, ITOC
 
   IF (ISCAN(PATH2, IP) == ERR)
      RETURN(ERR)
   CALL IGET(IP, INODE)
   IF (INODE(I_TYPE) == DIRECTORY)  # CAN'T LINK TO DIRECTORIES
      RETURN(ERR)
   I = 1
   IF (CSCAN(PATH1, I) == ERR)  # CAN'T EXIST ALREADY
      RETURN(ERR)
   CALL ENTER(PATH1(I), IP)  # MAKE ENTRY TO PATH2'S INODE
   INODE(I_NLINK) = INODE(I_NLINK) + 1  # INCREMENT PATH2'S LINK COUNT
   CALL IPUT(IP, INODE)
   RETURN(NOERR)
   END
 
# MKDIR(PATH) - MAKE A NEW DIRECTORY
   INTEGER FUNCTION MKDIR(PATH)
   CHARACTER PATH(MAXPATH)
   INTEGER IP, IIP, MKFILE, INODE(I_SIZE)
   INCLUDE CWDIR
   STRING DOTDOT ".."
   STRING EOSS ""
 
   IP = MKFILE(PATH, EOSS)  # MAKE A FILE
   IF (IP == ERR)
      RETURN(ERR)
   IIP = IWDIR  # SAVE INUMBER OF PARENT
   CALL IGET(IP, INODE)
   INODE(I_TYPE) = DIRECTORY   # THIS IS A DIRECTORY
   INODE(I_NLINK) = INODE(I_NLINK) + 1%# FOR .
   CALL IPUT(IP, INODE)
   CALL NEWDIR(IP)  # PREPARE TO MAKE A NEW DIRECTORY
   CALL ENTER(DOTDOT(2), IP)  # ENTER . AND ..
   CALL ENTER(DOTDOT(1), IIP)
   CALL WRDIR   # MAKE SURE IT GETS WRITTEN
   CALL IGET(IIP, INODE)%# INCREMENT LINK COUNT OF PARENT
   INODE(I_NLINK) = INODE(I_NLINK) + 1
   CALL IPUT(IIP, INODE)
   RETURN(IP)
   END
 
# MKDS(ROOT, ILST) - MAKE A DIRECTORY SYSTEM
   INTEGER FUNCTION MKDS(ROOT, ILST)
   CHARACTER ROOT(MAXTNAME), ILST(MAXTNAME)
   INTEGER JUNK, FD, CREATE
   CHARACTER INODE(I_SIZE)
   STRING DOTDOT ".."
   STRING RNAME "ROOT"
   STRING INAME "ILIST"
 
   INODE(I_MOD) = 1%# BUILD AN INODE FOR THE ROOT
   INODE(I_INUM) = 1
   INODE(I_TYPE) = DIRECTORY
   INODE(I_NLINK) = 2
   CALL DATE4(INODE(I_CDATE), INODE(I_CYEAR), INODE(I_CTIME), JUNK)
   CALL DATE4(INODE(I_ADATE), INODE(I_AYEAR), INODE(I_ATIME), JUNK)
   INODE(I_TNAME) = EOS
   IF (ROOT(1) ^= EOS)
      CALL SCOPY(ROOT, 1, INODE, I_TNAME)
   ELSE
      CALL SCOPY(RNAME, 1, INODE, I_TNAME)
   IF (ILST(1) ^= EOS)
      FD = CREATE(ILST, WRITE)
   ELSE
      FD = CREATE(INAME, WRITE)
   IF (FD == ERR)
      RETURN(ERR)
   CALL IWRITE(INODE, FD)
   CALL CLOSE(FD)
   FD = CREATE(INODE(I_TNAME), WRITE)
   IF (FD == ERR)
      RETURN(ERR)
   CALL PUTINT(ROOTDIR, 5, FD)
   CALL PUTCH(BLANK, FD)
   CALL PUTLIN(DOTDOT(2), FD)
   CALL PUTCH(NEWLINE, FD)
   CALL PUTINT(ROOTDIR, 5, FD)
   CALL PUTCH(BLANK, FD)
   CALL PUTLIN(DOTDOT(1), FD)
   CALL PUTCH(NEWLINE, FD)
   CALL CLOSE(FD)
   RETURN(NOERR)
   END
 
# MKFILE(PATH, TNAME) - MAKE A FILE POINTING TO  TNAME
   INTEGER FUNCTION MKFILE(PATH, TNAME)
   CHARACTER PATH(MAXPATH), TNAME(MAXTNAME)
   INTEGER I, IP, CSCAN, IALLOC, INODE(I_SIZE), JUNK
 
   I = 1
   IF (CSCAN(PATH, I) == ERR)   # CHECK PATH, MUST NOT EXIST
      RETURN(ERR)
   IP = IALLOC(INODE)
   IF (TNAME(1) ^= EOS)
      CALL SCOPY(TNAME, 1, INODE, I_TNAME)
   CALL IPUT(IP, INODE)
   CALL ENTER(PATH(I), IP)
   RETURN(IP)
   END
 
# OPENF(PATH, MODE) - OPEN  PATH  FOR READING OR WRITING
   INTEGER FUNCTION OPENF(PATH, MODE)
   CHARACTER PATH(MAXPATH)
   INTEGER MODE
   INTEGER IP, ISCAN, OPEN, INODE(I_SIZE)
 
   IF (ISCAN(PATH, IP) == ERR)
      RETURN(ERR)
   CALL IGET(IP, INODE)
   RETURN(OPEN(INODE(I_TNAME), MODE))
   END
 
# STAT(PATH, ARRAY) - GET INFO CONCERNING  PATH  INTO  ARRAY
   INTEGER FUNCTION STAT(PATH, ARRAY)
   CHARACTER PATH(MAXPATH)
   INTEGER ARRAY(I_SIZE)
   INTEGER IP, ISCAN
 
   IF (ISCAN(PATH, IP) == ERR)
      RETURN(ERR)
   CALL IGET(IP, ARRAY)
   RETURN(NOERR)
   END
 
# SYNC - UPDATE DISK COPIES OF ILIST AND WORKING DIRECTORY
   INTEGER FUNCTION SYNC(JUNK)
   INTEGER JUNK
 
   CALL IUPDAT
   CALL WRDIR
   RETURN(NOERR)
   END
 
# UNLINK(PATH) - UNLINK  PATH  FROM ITS INODE
   INTEGER FUNCTION UNLINK(PATH)
   CHARACTER PATH(MAXPATH)
   CHARACTER INODE(I_SIZE)
   INTEGER I, IP, N, SCAN, LOOKUP
   INCLUDE CUWDIR
   INCLUDE CWDIR
   STRING DOT ".."
 
   I = 1
   IF (SCAN(PATH, I) == ERR)
      RETURN(ERR)
   IF (LOOKUP(PATH(I), IP) == ERR)
      RETURN(ERR)
   CALL IGET(IP, INODE)
   IF (INODE(I_TYPE) == DIRECTORY) <  # DIRECTORY
      IF (IP == IUWDIR)
         RETURN(ERR)%# CAN'T DELETE WORKING DIRECTORY
      N = IWDIR
      CALL RDDIR(IP)
      IF (WSIZE ^= 2*D_SIZE)  # MUST BE EMPTY
         RETURN(ERR)
      IF (INODE(I_NLINK) ^= 2 \ LOOKUP(DOT, IIP) == ERR)
         CALL ERROR("UNLINK: ILL-FORMED DIRECTORY.")
      CALL IGET(IIP, INODE)
      INODE(I_NLINK) = INODE(I_NLINK) - 1
      CALL IPUT(IIP, INODE)
      CALL RDDIR(N)
      CALL DELETE(PATH(I))
      CALL IFREE(IP)
      RETURN(NOERR)
      !
   CALL DELETE(PATH(I))
   INODE(I_NLINK) = INODE(I_NLINK) - 1
   IF (INODE(I_NLINK) > 0)
      CALL IPUT(IP, INODE)
   ELSE   # LINK COUNT = 0, FREE INODE
      CALL IFREE(IP)
   RETURN(NOERR)
   END
#-H- PDS3.RAT 3369 1980 103 2058
# PDS3: DIRECTORY HANDLING
 
INCLUDE PDSDEF
 
# DELETE - DELETE  NAME  FROM CURRENT DIRECTORY
   SUBROUTINE DELETE(NAME)
   CHARACTER NAME(MAXFNAME)
   INTEGER I, EQUAL
   INCLUDE CWDIR
 
   IF (IWDIR == 0)
      CALL RDDIR(ROOTDIR)  # GET ROOT
   FOR (I = 0; I < WSIZE; I = I + D_SIZE)
      IF (EQUAL(NAME, WDIR(I+D_NAME)) == YES) <
         WDIR(I+D_INUM) = 0%# MARK ENTRY AS EMPTY
         WDIR(I+D_NAME) = EOS
         WMOD = WMOD + 1
         IF (WMOD >= D_SAVE)
            CALL WRDIR
         RETURN
         !
   RETURN
   END
 
# ENTER - INSERT  NAME  INTO WORKING DIRECTORY WITH I-NUMBER N.
   SUBROUTINE ENTER(NAME, N)
   CHARACTER NAME(MAXTNAME)
   INTEGER N
   INTEGER I
   INCLUDE CWDIR
 
   IF (IWDIR == 0)
      CALL RDDIR(ROOTDIR)  # GET ROOT
   FOR (I = 0; I < WSIZE; I = I + D_SIZE)
      IF (WDIR(I+D_INUM) == 0)    # FOUND EMPTY ENTRY
         BREAK
   IF (I >= WSIZE) <   # NEED TO EXPAND WORKING DIRECTORY SIZE
      IF (I + D_SIZE > MAXDENTRY*D_SIZE)
         CALL ERROR("ENTER: OUT OF DIRECTORY SPACE.")
      WSIZE = I + D_SIZE
      !
   WDIR(I+D_INUM) = N
   CALL SCOPY(NAME, 1, WDIR, I + D_NAME)
   WMOD = WMOD + 1
   IF (WMOD >= D_SAVE)
      CALL WRDIR
   RETURN
   END
 
# LOOKUP - GET I-NUMBER FOR  NAME  IN  N.
   INTEGER FUNCTION LOOKUP(NAME, N)
   CHARACTER NAME(MAXFNAME)
   INTEGER N
   INTEGER I, EQUAL
   INCLUDE CWDIR
 
   IF (IWDIR == 0)
      CALL RDDIR(ROOTDIR)  # GET ROOT
   FOR (I = 0; I < WSIZE; I = I + D_SIZE)
      IF (WDIR(I+D_INUM) ^= 0 & EQUAL(NAME, WDIR(I+D_NAME)) == YES) <
         N = WDIR(I+D_INUM)
         RETURN(NOERR)
         !
   RETURN(ERR)
   END
 
# NEWDIR - CHANGE WORKING DIRECTORY TO AN EMPTY DIRECTORY WITH INODE  N
   SUBROUTINE NEWDIR(N)
   INTEGER N
   INCLUDE CWDIR
   INCLUDE CUWDIR
 
   CALL WRDIR  # FLUSH CURRENT DIRECTORY
   IWDIR = N
   WSIZE = 0  # DIRECTORY IS EMPTY
   IF (N == 0)  # RESET USER'S WORKING DIRECTORY
      IUWDIR = ROOTDIR
   RETURN
   END
 
# RDDIR - READ DIRECTORY ASSOCIATED WITH INODE  N.
   SUBROUTINE RDDIR(N)
   INTEGER N
   INTEGER I, FD, OPEN, INODE(I_SIZE), CTOI, GETLIN, WBUF(MAXLINE), LENGTH
   INCLUDE CWDIR
 
   IF (N == IWDIR)  # MAY ALREADY HAVE IT
      RETURN
   IF (WMOD > 0)
      CALL WRDIR  # WRITE OUT CURRENT DIRECTORY
   CALL IGET(N, INODE)
   IF (INODE(I_TYPE) ^= DIRECTORY)
      CALL ERROR("RDDIR: NOT A DIRECTORY.")
   FD = OPEN(INODE(I_TNAME), READ)
   IF (FD == ERR)
      CALL ERROR("RDDIR: CAN'T READ DIRECTORY.")
   FOR (WSIZE = 0; GETLIN(WBUF, FD) ^= EOF; WSIZE = WSIZE + D_SIZE) <
      I = LENGTH(WBUF)
      IF (WBUF(I) == NEWLINE)
         WBUF(I) = EOS
      I = 1
      WDIR(WSIZE+D_INUM) = CTOI(WBUF, I)
      CALL SCOPY(WBUF, I + 1, WDIR, WSIZE + D_NAME)
      !
   CALL CLOSE(FD)
   IWDIR = N
   WMOD = 0
   RETURN
   END
 
# WRDIR - WRITE OUT CURRENT DIRECTORY; SET WMOD = 0
   SUBROUTINE WRDIR
   INTEGER I, FD, CREATE, INODE(I_SIZE)
   INCLUDE CWDIR
 
   IF (WMOD == 0)  # DON'T WRITE IF WE DON'T HAVE TO
      RETURN
   CALL IGET(IWDIR, INODE)
   FD = CREATE(INODE(I_TNAME), WRITE)
   IF (FD == ERR)
      CALL ERROR("WRDIR: CAN'T CREATE DIRECTORY.")
   FOR (I = 0; I < WSIZE; I = I + D_SIZE)
      IF (WDIR(I+D_INUM) ^= 0) <
         CALL PUTINT(WDIR(I+D_INUM), 5, FD)
         CALL PUTCH(BLANK, FD)
         CALL PUTLIN(WDIR(I+D_NAME), FD)
         CALL PUTCH(NEWLINE, FD)
         !
   CALL CLOSE(FD)
   WMOD = 0
   RETURN
   END
#-H- PDS4.RAT 6690 1980 103 2058
# PDS4: INODE HANDLING
 
INCLUDE PDSDEF
 
# IALLOC - ALLOCATE AN INODE AND COPY INITIAL VALUE INTO  ARRAY
   INTEGER FUNCTION IALLOC(ARRAY)
   CHARACTER ARRAY(I_SIZE)
   INTEGER I, J, FD
   INTEGER OPEN, GETLIN, UALLOC, LENGTH
   INCLUDE CINODE
 
   IF (NINODE == 0) <  # SWEEP ILIST LOOKING FOR MORE FREE INODES
      CALL IUPDAT  # INSURE UP TO DATE ILIST
      FD = OPEN(INAME, READ)
      IF (FD == ERR)
         CALL ERROR("IALLOC: CAN'T READ ILIST.")
      NINODE = MAXINUM
      FOR (I = 1; GETLIN(IBUF, FD) ^= EOF; I = I + 1)
         IF (IBUF(1) == UNUSED) <  # FOUND ONE
            INUM(NINODE) = I
            NINODE = NINODE - 1
            IF (NINODE == 0)%# QUIT IF WE HAVE ENOUGH
               BREAK
            !
      WHILE (NINODE > 0) <
         INUM(NINODE) = I
         I = I + 1
         NINODE = NINODE - 1
         !
      NINODE = MAXINUM
      CALL CLOSE(FD)
      !
   IALLOC = INUM(NINODE)
   NINODE = NINODE - 1
   I = UALLOC(I)
   INODES(I+I_MOD) = 0
   INODES(I+I_INUM) = IALLOC
   INODES(I+I_TYPE) = PLAIN
   INODES(I+I_NLINK) = 1
   CALL DATE4(INODES(I+I_CDATE), INODES(I+I_CYEAR), INODES(I+I_CTIME), JUNK)
   CALL DATE4(INODES(I+I_ADATE), INODES(I+I_AYEAR), INODES(I+I_ATIME), JUNK)
   CALL SCOPY(INAME, 1, INODES(I+I_TNAME), 1)  # MAKE DEFAULT HOST NAME
   J = LENGTH(INAME)                         # (DEC-10 VERSION)
   KK = I + I_TNAME + J
   INODES(KK) = PERIOD
   J = ITOC(IALLOC, INODES(KK+1), I_SIZE-I_TNAME-J-1)
   CALL SCOPY(INODES, I + 1, ARRAY, 1)
   RETURN
   END
 
# ICLEAR - CLEAR INODE DATA STRUCTURE; UPDATE IF FLAG == YES
   SUBROUTINE ICLEAR(FLAG)
   INTEGER FLAG
   INTEGER I
   INCLUDE CINODE
 
   IF (FLAG == YES)
      CALL IUPDAT
   NINODE = 0    # SET NO INODES AND CLEAR THE CACHE
   FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE)
      INODES(I+I_INUM) = 0
   RETURN
   END
 
# ICMP - COMPARE I-NUMBERS OF TWO INODES; CALLED BY QSORT
   INTEGER FUNCTION ICMP(X, Y)
   INTEGER X, Y
   INCLUDE CINODE
 
   RETURN (INODES(X+I_INUM) - INODES(Y+I_INUM))
   END
 
# IFREE - FREE INODE  N.
   SUBROUTINE IFREE(N)
   INTEGER N
   INTEGER INODE(I_SIZE)
   INCLUDE CINODE
 
   IF (NINODE < MAXINUM) <
      NINODE = NINODE + 1
      INUM(NINODE) = N
      !
   INODE(I_INUM) = N    # MAKE A FREE INODE AND PUT IT OUT
   INODE(I_TYPE) = UNUSED
   CALL IPUT(N, INODE)
   RETURN
   END
 
# IGET - COPY INODE  N  INTO  ARRAY.
   SUBROUTINE IGET(N, ARRAY)
   INTEGER N
   CHARACTER ARRAY(I_SIZE)
   INTEGER I, J, OPEN, UALLOC, GETLIN
   INCLUDE CINODE
 
   FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE)
      IF (INODES(I+I_INUM) == N)
         BREAK
   IF (I >= MAXINODES*I_SIZE) <%# GET INODE FROM ILIST FILE
      I = UALLOC(I)
      IF (IFD ^= EOF & N < IPOS) <   # NEED TO REREAD ILIST
         CALL CLOSE(IFD)
         IFD = EOF
         !
      IF (IFD == EOF) <
         IFD = OPEN(INAME, READ)
         IPOS = 0
         !
      IF (IFD == ERR)
         CALL ERROR("IGET: CAN'T READ ILIST.")
      FOR ( ; IPOS < N; IPOS = IPOS + 1)
         IF (GETLIN(IBUF, IFD) == EOF)
            CALL ERROR("IGET: BAD INUMBER.")
      CALL IREAD(INODES(I+I_MOD))
      INODES(I+I_INUM) = N
      !
   IF (INODES(I+I_TYPE) == UNUSED)
      CALL ERROR("IGET: FREE INODE.")
   CALL SCOPY(INODES, I + 1, ARRAY, 1)
   RETURN
   END
 
# IPUT - COPY  ARRAY  TO INODE  N  AND UPDATE INODE FILE IF NECESSARY.
   SUBROUTINE IPUT(N, ARRAY)
   INTEGER N
   CHARACTER ARRAY(I_SIZE)
   INTEGER I, UALLOC
   INCLUDE CINODE
 
   FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE)
      IF (INODES(I+I_INUM) == N)
         BREAK
   IF (I >= MAXINODES*I_SIZE)    # NEED A SLOT
      I = UALLOC(I)
   CALL SCOPY(ARRAY, 1, INODES, I + I_MOD)
   INODES(I+I_MOD) = 1
   IMOD = IMOD + 1
   IF (IMOD >= I_SAVE)
      CALL IUPDAT
   RETURN
   END
 
# IREAD - CONVERT DATA IN IBUF TO INTERNAL INODE IN  INODE
   SUBROUTINE IREAD(INODE)
   INTEGER INODE(I_SIZE)
   INTEGER I, LENGTH, CTOI
   INCLUDE CINODE
 
   I = LENGTH(IBUF)
   IF (IBUF(I) == NEWLINE)%# ZAP THE NEWLINE
      IBUF(I) = EOS
   INODE(I_MOD) = 0
   INODE(I_INUM) = 0
   INODE(I_TYPE) = IBUF(1)
   I = 3
   INODE(I_NLINK) = CTOI(IBUF, I)
   INODE(I_CTIME) = CTOI(IBUF, I)
   INODE(I_CDATE) = CTOI(IBUF, I)
   INODE(I_CYEAR) = CTOI(IBUF, I)
   INODE(I_ATIME) = CTOI(IBUF, I)
   INODE(I_ADATE) = CTOI(IBUF, I)
   INODE(I_AYEAR) = CTOI(IBUF, I)
   CALL SCOPY(IBUF, I+1, INODE, I_TNAME)
   RETURN
   END
 
# IUPDAT - UPDATE THE ILIST FILE IF MODIFIED; SET IMOD = 0
   SUBROUTINE IUPDAT
   INTEGER I, J, N, FDI, FDO, IP(MAXINODES), JUNK, CREATE, OPEN, GETLIN
   EXTERNAL ICMP
   INCLUDE CINODE
   STRING TMPNAM "I.TMP"
 
   IF (IFD ^= EOF) <
      CALL CLOSE(IFD)
      IFD = EOF
      !
   IF (IMOD == 0)
      RETURN
   IMOD = 0
   J = 0
   FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE)
      IF (INODES(I+I_INUM) > 0 & INODES(I+I_MOD) ^= 0) <
         INODES(I+I_MOD) = 0
         J = J + 1
         IP(J) = I
         !
   IF (J == 0)
      RETURN
   IP(J+1) = -1
   CALL QSORT(J, IP, ICMP)
   FDI = OPEN(INAME, READ)
   IF (FDI == ERR)
      CALL ERROR("IUPDAT: CAN'T READ ILIST.")
   FDO = CREATE(TMPNAM, WRITE)
   IF (FDO == ERR)
      CALL ERROR("IUPDAT: CAN'T CREATE TEMPORARY ILIST.")
   I = 0
   FOR (J = 1; IP(J) >= 0; J = J + 1) <
      N = IP(J)
      N = INODES(N+I_INUM)
      FOR (I = I + 1; I < N; I = I + 1)
         IF (GETLIN(IBUF, FDI) ^= EOF)
            CALL PUTLIN(IBUF, FDO)
      JUNK = GETLIN(IBUF, FDI)%# THROW AWAY DISK COPY
      N = IP(J)
      CALL IWRITE(INODES(N+I_MOD), FDO)
      !
   WHILE (GETLIN(IBUF, FDI) ^= EOF)
      CALL PUTLIN(IBUF, FDO)
   CALL CLOSE(FDI)
   CALL CLOSE(FDO)
   CALL AMOVE(TMPNAM, INAME)
   RETURN
   END
 
# IWRITE - WRITE  INODE  TO FD IN PROPER FORMAT
   SUBROUTINE IWRITE(INODE, FD)
   INTEGER INODE(I_SIZE), FD
 
   CALL PUTCH(INODE(I_TYPE), FD)
   IF (INODE(I_TYPE) ^= UNUSED) <
      CALL PUTINT(INODE(I_NLINK), 4, FD)
      CALL PUTINT(INODE(I_CTIME), 5, FD)
      CALL PUTINT(INODE(I_CDATE), 5, FD)
      CALL PUTINT(INODE(I_CYEAR), 5, FD)
      CALL PUTINT(INODE(I_ATIME), 5, FD)
      CALL PUTINT(INODE(I_ADATE), 5, FD)
      CALL PUTINT(INODE(I_AYEAR), 5, FD)
      CALL PUTCH(BLANK, FD)
      CALL PUTLIN(INODE(I_TNAME), FD)
      !
   CALL PUTCH(NEWLINE, FD)
   RETURN
   END
 
# UALLOC - ALLOCATE A SLOT IN INODES
   INTEGER FUNCTION UALLOC(I)
   INTEGER I
   INTEGER LAST
   INCLUDE CINODE
 
   REPEAT <
      LAST = 0
      FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE)
         IF (INODES(I+I_INUM) == 0)
            RETURN (I)
         ELSE IF (INODES(I+I_MOD) == 0)
            LAST = I + 1
      IF (LAST ^= 0) <
         I = LAST - 1
         RETURN (I)
         !
      CALL IUPDAT%# DUMP THE CURRENT ILIST
      !
   RETURN
   END
#-H- PDS5.RAT 1834 1980 103 2058
# PDS5: PATH SCANNING
 
INCLUDE PDSDEF
 
# CSCAN - SEARCH DIRECTORY HIERARCHY FOR CREATION OF PATH(I), INCREMENT I
   INTEGER FUNCTION CSCAN(PATH, I)
   CHARACTER PATH(MAXPATH)
   INTEGER I
   INTEGER N, SCAN
 
   I = 1
   IF (SCAN(PATH, I) == ERR)
      RETURN(ERR)
   IF (PATH(1) == SLASH & PATH(2) == EOS)   # SPECIAL CASE THE ROOT
      RETURN(ERR)
   IF (LOOKUP(PATH(I), JUNK) == NOERR)
      RETURN(ERR)%# MUST NOT EXIST
   RETURN(NOERR)
   END
 
# ISCAN - SEARCH DIRECTORY HIERARCHY FOR INPUT FILE PATH, RETURN INODE N
   INTEGER FUNCTION ISCAN(PATH, N)
   CHARACTER PATH(MAXPATH)
   INTEGER N
   INTEGER I, SCAN, LOOKUP
 
   I = 1
   IF (SCAN(PATH, I) == ERR)
      RETURN(ERR)
   IF (PATH(1) == SLASH & PATH(2) == EOS) <  # SPECIAL CASE THE ROOT
      N = ROOTDIR
      RETURN(NOERR)
      !
   ELSE
      RETURN(LOOKUP(PATH(I), N))
   RETURN
   END
 
# SCAN - SEARCH DIRECTORY HIERARCHY ACCORDING TO  PATH(I), INCREMENT I
   INTEGER FUNCTION SCAN(PATH, I)
   CHARACTER PATH(MAXPATH)
   INTEGER I
   CHARACTER INODE(I_SIZE), NAME(MAXFNAME)
   INTEGER IP, J, LENGTH, LOOKUP
   INCLUDE CWDIR
   INCLUDE CUWDIR
 
   IF (PATH(I) == SLASH \ IWDIR == 0)
      IP = ROOTDIR  # START AT ROOT
   ELSE
      IP = IUWDIR
   REPEAT <
      WHILE (PATH(I) == SLASH)  # GET OVER SLASHES
         I = I + 1
      CALL IGET(IP, INODE)
      IF (INODE(I_TYPE) ^= DIRECTORY)  # MUST BE A DIRECTORY
         RETURN(ERR)
      CALL RDDIR(IP)
      FOR (J = 1; PATH(I) ^= SLASH & PATH(I) ^= EOS; I = I + 1)
         IF (J < MAXFNAME) <
            NAME(J) = PATH(I)
            J = J + 1
            !
      NAME(J) = EOS
      IF (PATH(I) == EOS) <   # FOUND THE END
         I = I - LENGTH(NAME)    # BACKUP I
         RETURN(IP)
         !
      IF (LOOKUP(NAME, IP) == ERR)  # SEARCH FOR NEXT COMPONENT
         RETURN(ERR)
      !
   RETURN
   END
#-H- PDS6.RAT 5298 1980 103 2058
# PDS6:  SUPPORT ROUTINES
 
INCLUDE RATDEF
 
# AMOVE - MOVE NAME1 TO NAME2
   SUBROUTINE AMOVE(NAME1, NAME2)
   CHARACTER NAME1(ARB), NAME2(ARB)
   INTEGER CREATE, OPEN
   CHARACTER GETCH, C
   INTEGER FD1, FD2
 
   FD1 = OPEN(NAME1, READ)
   IF (FD1 == ERR)
      CALL CANT(NAME1)
   FD2 = CREATE(NAME2, WRITE)
   IF (FD2 == ERR)
      CALL CANT(NAME2)
   WHILE (GETCH(C, FD1) ^= EOF)
      CALL PUTCH(C, FD2)
   CALL CLOSE(FD1)
   CALL CLOSE(FD2)
   RETURN
   END
 
# CANT - PRINT CANT OPEN FILE MESSAGE AND DIE
   SUBROUTINE CANT(BUF)
   INTEGER BUF(MAXLINE)
 
   CALL PUTLIN(BUF, ERROUT)
   CALL REMARK(": CAN'T OPEN.")
   STOP
   RETURN
   END
 
# CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I
   INTEGER FUNCTION CTOI(IN, I)
   CHARACTER IN(ARB)
   INTEGER I, S
 
   WHILE (IN(I) == BLANK \ IN(I) == TAB)
      I = I + 1
   IF (IN(I) == MINUS \ IN(I) == PLUS) <
      S = IN(I)
      I = I + 1
      !
   ELSE
      S = NO
   FOR (CTOI = 0; IN(I) ^= EOS; I = I + 1) <
      IF (IN(I) < DIG0 \ IN(I) > DIG9)      # NON-DIGIT
         BREAK
      CTOI = 10 * CTOI + IN(I) - DIG0
      !
   IF (S == MINUS)
      CTOI = -CTOI
   RETURN
   END
 
# 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) <
         EQUAL = YES
         RETURN
         !
   EQUAL = NO
   RETURN
   END
 
# GETLIN - GET NEXT LINE FROM  F  INTO  LINE
   INTEGER FUNCTION GETLIN(LINE, F)
   CHARACTER LINE(MAXLINE), C, GETCH
   INTEGER F
 
   FOR (GETLIN = 0; GETCH(C, F) ^= EOF; ) <
      IF (GETLIN < MAXLINE - 1) <
         GETLIN = GETLIN + 1
         LINE(GETLIN) = C
         !
      IF (C == NEWLINE)
         BREAK
      !
   LINE(GETLIN+1) = EOS
   IF (GETLIN == 0 & C == EOF)
      GETLIN = EOF
   RETURN
   END
 
DEFINE(ABS,IABS)
# ITOC - CONVERT INTEGER  INT  TO CHAR STRING IN  STR
   INTEGER FUNCTION ITOC(INT, STR, SIZE)
   INTEGER ABS, MOD
   INTEGER I, INT, INTVAL, J, K, SIZE
   CHARACTER STR(ARB)
 
   INTVAL = ABS(INT)
   STR(1) = EOS
   I = 1
   REPEAT <            # GENERATE DIGITS
      I = I + 1
      STR(I) = DIG0 + MOD(INTVAL,10)
      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
 
# LENGTH - COMPUTE LENGTH OF STRING
   INTEGER FUNCTION LENGTH(STR)
   INTEGER STR(ARB)
 
   FOR (LENGTH = 0; STR(LENGTH+1) ^= EOS; LENGTH = LENGTH + 1)
      ;
   RETURN
   END
 
# PUTINT - WRITE DECIMAL INTEGER  N  IN FIELD WIDTH >= W  TO  F
   SUBROUTINE PUTINT(N, W, F)
   INTEGER N, W, F
   CHARACTER CHARS(MAXCHARS)
   INTEGER ITOC
   INTEGER JUNK
 
   JUNK = ITOC(N, CHARS, MAXCHARS)
   CALL PUTSTR(CHARS, W, F)
   RETURN
   END
 
# PUTLIN - WRITE STRING  LINE  TO FILE  F
   SUBROUTINE PUTLIN(LINE, F)
   CHARACTER LINE(MAXLINE)
   INTEGER F, I
 
   FOR (I = 1; LINE(I) ^= EOS; I = I + 1)
      CALL PUTCH(LINE(I), F)
   RETURN
   END
 
# PUTSTR - WRITE STRING  STR  TO FILE  F  IN FIELD WIDTH >= W
   SUBROUTINE PUTSTR(STR, W, F)
   CHARACTER STR(MAXLINE)
   INTEGER W, F, LEN, I, LENGTH, NW
 
   LEN = LENGTH(STR)
   FOR (I = LEN; I < W; I = I + 1)%# OUTPUT LEFT PADDING
      CALL PUTCH(BLANK, F)
   FOR (I = 1; STR(I) ^= EOS; I = I + 1)
      CALL PUTCH(STR(I), F)
   NW = -W
   FOR (I = LEN; I < NW; I = I + 1)%# OUTPUT RIGHT PADDING
      CALL PUTCH(BLANK, F)
   RETURN
   END
 
# QSORT - SORTS A INTO ASCENDING ORDER; COMPARISONS ARE DONE BY COMPAR
# COMPAR(X,Y) MUST RETURN <0 IF X < Y, 0 IF X == Y, AND >0 IF X > Y.
   SUBROUTINE QSORT(N, A, COMPAR)
   INTEGER N, A(ARB)
   EXTERNAL COMPAR
   INTEGER COMPAR
   INTEGER I, J, LV(20), P, PIVOT, UV(20), T
 
   LV(1) = 1
   UV(1) = N
   P = 1
   WHILE (P > 0)
      IF (LV(P) >= UV(P))      # ONLY ONE ELEMENT IN THIS SUBSET
         P = P - 1      # POP STACK
      ELSE <
         I = LV(P) - 1
         J = UV(P)
         PIVOT = A(J)    # PIVOT ELEMENT
         WHILE (I < J) <
            FOR (I=I+1; COMPAR(A(I), PIVOT) < 0; I=I+1)
               ;
            FOR (J = J - 1; J > I; J = J - 1)
               IF (COMPAR(A(J), PIVOT) <= 0)
                  BREAK
            IF (I < J) <     # OUT OF ORDER PAIR
               T = A(I)%%# EXCHANGE A(I) AND A(J)
               A(I) = A(J)
               A(J) = T
               !
            !
         J = UV(P)         # MOVE PIVOT TO POSITION I
         T = A(I)%# EXCHANGE A(I) AND A(J)
         A(I) = A(J)
         A(J) = T
         IF (I-LV(P) < UV(P)-I) <   # STACK SO SHORTER DONE FIRST
            LV(P+1) = LV(P)
            UV(P+1) = I - 1
            LV(P) = I + 1
            !
         ELSE <
            LV(P+1) = I + 1
            UV(P+1) = UV(P)
            UV(P) = I - 1
            !
         P = P + 1         # PUSH ONTO STACK
         !
   RETURN
   END
 
# SCOPY - COPY STRING AT FROM(I) TO TO(J)
   SUBROUTINE SCOPY(FROM, I, TO, J)
   CHARACTER FROM(ARB), TO(ARB)
   INTEGER I, J, K1, K2
 
   K2 = J
   FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) <
      TO(K2) = FROM(K1)
      K2 = K2 + 1
      !
   TO(K2) = EOS
   RETURN
   END
#-H- PDS.FOR 29930 1980 103 2201
      BLOCK DATA
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      COMMON /CUWDIR/ IUWDIR
      INTEGER IUWDIR
      DATA NINODE /0/
      DATA INODES /1110*0/
      DATA IMOD /0/
      DATA INAME(1), INAME(2), INAME(3), INAME(4), INAME(5), INAME(6) /
     *105, 108, 105, 115, 116, 10002/
      DATA RNAME(1), RNAME(2), RNAME(3), RNAME(4), RNAME(5) / 114, 111,
     *111, 116, 10002/
      DATA IFD /10003/
      DATA IPOS /0/
      DATA IWDIR /0/
      DATA WMOD /0/
      DATA IUWDIR /1/
      END
      INTEGER FUNCTION CHDIR(PATH)
      INTEGER PATH(80)
      INTEGER IP, ISCAN, INODE(37)
      COMMON /CUWDIR/ IUWDIR
      INTEGER IUWDIR
      IF(.NOT.(ISCAN(PATH, IP) .EQ. 10001))GOTO 23000
      CHDIR=(10001)
      RETURN
23000 CONTINUE
      CALL IGET(IP, INODE)
      IF(.NOT.(INODE(3) .NE. 100))GOTO 23002
      CHDIR=(10001)
      RETURN
23002 CONTINUE
      IUWDIR = IP
      CHDIR=(0)
      RETURN
      END
      INTEGER FUNCTION CHDS(ROOT, ILST)
      INTEGER ROOT(26), ILST(26)
      INTEGER FD
      INTEGER OPEN
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      IF(.NOT.(ILST(1) .NE. 10002))GOTO 23004
      FD = OPEN(ILST, 0)
      IF(.NOT.(FD .EQ. 10001))GOTO 23006
      CHDS=(10001)
      RETURN
23006 CONTINUE
      CALL CLOSE(FD)
23004 CONTINUE
      IF(.NOT.(ROOT(1) .NE. 10002))GOTO 23008
      FD = OPEN(ROOT, 0)
      IF(.NOT.(FD .EQ. 10001))GOTO 23010
      CHDS=(10001)
      RETURN
23010 CONTINUE
      CALL CLOSE(FD)
23008 CONTINUE
      CALL NEWDIR(0)
      CALL ICLEAR(1)
      IF(.NOT.(ROOT(1) .NE. 10002))GOTO 23012
      CALL SCOPY(ROOT, 1, RNAME, 1)
23012 CONTINUE
      IF(.NOT.(ILST(1) .NE. 10002))GOTO 23014
      CALL SCOPY(ILST, 1, INAME, 1)
23014 CONTINUE
      CHDS=(0)
      RETURN
      END
      INTEGER FUNCTION CREATF(PATH, MODE)
      INTEGER PATH(80)
      INTEGER MODE
      INTEGER INODE(37)
      INTEGER IP, FD, MKFILE, CREATE
      INTEGER EOSS(1)
      DATA EOSS(1)/10002/
      IP = MKFILE(PATH, EOSS)
      IF(.NOT.(IP .EQ. 10001))GOTO 23016
      CREATF=(10001)
      RETURN
23016 CONTINUE
      CALL IGET(IP, INODE)
      FD = CREATE(INODE(11), MODE)
      IF(.NOT.(FD .EQ. 10001))GOTO 23018
      CALL IFREE(IP)
23018 CONTINUE
      CREATF=(FD)
      RETURN
      END
      INTEGER FUNCTION LINK(PATH1, PATH2)
      INTEGER PATH1(80), PATH2(80)
      INTEGER INODE(37)
      INTEGER I, J, IP, ISCAN, CSCAN, CTOI, ITOC
      IF(.NOT.(ISCAN(PATH2, IP) .EQ. 10001))GOTO 23020
      LINK=(10001)
      RETURN
23020 CONTINUE
      CALL IGET(IP, INODE)
      IF(.NOT.(INODE(3) .EQ. 100))GOTO 23022
      LINK=(10001)
      RETURN
23022 CONTINUE
      I = 1
      IF(.NOT.(CSCAN(PATH1, I) .EQ. 10001))GOTO 23024
      LINK=(10001)
      RETURN
23024 CONTINUE
      CALL ENTER(PATH1(I), IP)
      INODE(4) = INODE(4) + 1
      CALL IPUT(IP, INODE)
      LINK=(0)
      RETURN
      END
      INTEGER FUNCTION MKDIR(PATH)
      INTEGER PATH(80)
      INTEGER IP, IIP, MKFILE, INODE(37)
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      INTEGER DOTDOT(3)
      INTEGER EOSS(1)
      DATA DOTDOT(1)/46/,DOTDOT(2)/46/,DOTDOT(3)/10002/
      DATA EOSS(1)/10002/
      IP = MKFILE(PATH, EOSS)
      IF(.NOT.(IP .EQ. 10001))GOTO 23026
      MKDIR=(10001)
      RETURN
23026 CONTINUE
      IIP = IWDIR
      CALL IGET(IP, INODE)
      INODE(3) = 100
      INODE(4) = INODE(4) + 1
      CALL IPUT(IP, INODE)
      CALL NEWDIR(IP)
      CALL ENTER(DOTDOT(2), IP)
      CALL ENTER(DOTDOT(1), IIP)
      CALL WRDIR
      CALL IGET(IIP, INODE)
      INODE(4) = INODE(4) + 1
      CALL IPUT(IIP, INODE)
      MKDIR=(IP)
      RETURN
      END
      INTEGER FUNCTION MKDS(ROOT, ILST)
      INTEGER ROOT(26), ILST(26)
      INTEGER JUNK, FD, CREATE
      INTEGER INODE(37)
      INTEGER DOTDOT(3)
      INTEGER RNAME(5)
      INTEGER INAME(6)
      DATA DOTDOT(1)/46/,DOTDOT(2)/46/,DOTDOT(3)/10002/
      DATA RNAME(1)/114/,RNAME(2)/111/,RNAME(3)/111/,RNAME(4)/116/,RNAME
     *(5)/10002/
      DATA INAME(1)/105/,INAME(2)/108/,INAME(3)/105/,INAME(4)/115/,INAME
     *(5)/116/,INAME(6)/10002/
      INODE(1) = 1
      INODE(2) = 1
      INODE(3) = 100
      INODE(4) = 2
      CALL DATE4(INODE(6), INODE(7), INODE(5), JUNK)
      CALL DATE4(INODE(9), INODE(10), INODE(8), JUNK)
      INODE(11) = 10002
      IF(.NOT.(ROOT(1) .NE. 10002))GOTO 23028
      CALL SCOPY(ROOT, 1, INODE, 11)
      GOTO 23029
23028 CONTINUE
      CALL SCOPY(RNAME, 1, INODE, 11)
23029 CONTINUE
      IF(.NOT.(ILST(1) .NE. 10002))GOTO 23030
      FD = CREATE(ILST, 1)
      GOTO 23031
23030 CONTINUE
      FD = CREATE(INAME, 1)
23031 CONTINUE
      IF(.NOT.(FD .EQ. 10001))GOTO 23032
      MKDS=(10001)
      RETURN
23032 CONTINUE
      CALL IWRITE(INODE, FD)
      CALL CLOSE(FD)
      FD = CREATE(INODE(11), 1)
      IF(.NOT.(FD .EQ. 10001))GOTO 23034
      MKDS=(10001)
      RETURN
23034 CONTINUE
      CALL PUTINT(1, 5, FD)
      CALL PUTCH(32, FD)
      CALL PUTLIN(DOTDOT(2), FD)
      CALL PUTCH(10, FD)
      CALL PUTINT(1, 5, FD)
      CALL PUTCH(32, FD)
      CALL PUTLIN(DOTDOT(1), FD)
      CALL PUTCH(10, FD)
      CALL CLOSE(FD)
      MKDS=(0)
      RETURN
      END
      INTEGER FUNCTION MKFILE(PATH, TNAME)
      INTEGER PATH(80), TNAME(26)
      INTEGER I, IP, CSCAN, IALLOC, INODE(37), JUNK
      I = 1
      IF(.NOT.(CSCAN(PATH, I) .EQ. 10001))GOTO 23036
      MKFILE=(10001)
      RETURN
23036 CONTINUE
      IP = IALLOC(INODE)
      IF(.NOT.(TNAME(1) .NE. 10002))GOTO 23038
      CALL SCOPY(TNAME, 1, INODE, 11)
23038 CONTINUE
      CALL IPUT(IP, INODE)
      CALL ENTER(PATH(I), IP)
      MKFILE=(IP)
      RETURN
      END
      INTEGER FUNCTION OPENF(PATH, MODE)
      INTEGER PATH(80)
      INTEGER MODE
      INTEGER IP, ISCAN, OPEN, INODE(37)
      IF(.NOT.(ISCAN(PATH, IP) .EQ. 10001))GOTO 23040
      OPENF=(10001)
      RETURN
23040 CONTINUE
      CALL IGET(IP, INODE)
      OPENF=(OPEN(INODE(11), MODE))
      RETURN
      END
      INTEGER FUNCTION STAT(PATH, ARRAY)
      INTEGER PATH(80)
      INTEGER ARRAY(37)
      INTEGER IP, ISCAN
      IF(.NOT.(ISCAN(PATH, IP) .EQ. 10001))GOTO 23042
      STAT=(10001)
      RETURN
23042 CONTINUE
      CALL IGET(IP, ARRAY)
      STAT=(0)
      RETURN
      END
      INTEGER FUNCTION SYNC(JUNK)
      INTEGER JUNK
      CALL IUPDAT
      CALL WRDIR
      SYNC=(0)
      RETURN
      END
      INTEGER FUNCTION UNLINK(PATH)
      INTEGER PATH(80)
      INTEGER INODE(37)
      INTEGER I, IP, N, SCAN, LOOKUP
      COMMON /CUWDIR/ IUWDIR
      INTEGER IUWDIR
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      INTEGER DOT(3)
      DATA DOT(1)/46/,DOT(2)/46/,DOT(3)/10002/
      I = 1
      IF(.NOT.(SCAN(PATH, I) .EQ. 10001))GOTO 23044
      UNLINK=(10001)
      RETURN
23044 CONTINUE
      IF(.NOT.(LOOKUP(PATH(I), IP) .EQ. 10001))GOTO 23046
      UNLINK=(10001)
      RETURN
23046 CONTINUE
      CALL IGET(IP, INODE)
      IF(.NOT.(INODE(3) .EQ. 100))GOTO 23048
      IF(.NOT.(IP .EQ. IUWDIR))GOTO 23050
      UNLINK=(10001)
      RETURN
23050 CONTINUE
      N = IWDIR
      CALL RDDIR(IP)
      IF(.NOT.(WSIZE .NE. 2*21))GOTO 23052
      UNLINK=(10001)
      RETURN
23052 CONTINUE
      IF(.NOT.(INODE(4) .NE. 2 .OR. LOOKUP(DOT, IIP) .EQ. 10001))GOTO 23
     *054
      CALL ERROR(29HUNLINK: ILL-FORMED DIRECTORY.)
23054 CONTINUE
      CALL IGET(IIP, INODE)
      INODE(4) = INODE(4) - 1
      CALL IPUT(IIP, INODE)
      CALL RDDIR(N)
      CALL DELETE(PATH(I))
      CALL IFREE(IP)
      UNLINK=(0)
      RETURN
23048 CONTINUE
      CALL DELETE(PATH(I))
      INODE(4) = INODE(4) - 1
      IF(.NOT.(INODE(4) .GT. 0))GOTO 23056
      CALL IPUT(IP, INODE)
      GOTO 23057
23056 CONTINUE
      CALL IFREE(IP)
23057 CONTINUE
      UNLINK=(0)
      RETURN
      END
      SUBROUTINE DELETE(NAME)
      INTEGER NAME(20)
      INTEGER I, EQUAL
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      IF(.NOT.(IWDIR .EQ. 0))GOTO 23000
      CALL RDDIR(1)
23000 CONTINUE
      I = 0
23002 IF(.NOT.(I .LT. WSIZE))GOTO 23004
      IF(.NOT.(EQUAL(NAME, WDIR(I+2)) .EQ. 1))GOTO 23005
      WDIR(I+1) = 0
      WDIR(I+2) = 10002
      WMOD = WMOD + 1
      IF(.NOT.(WMOD .GE. 10))GOTO 23007
      CALL WRDIR
23007 CONTINUE
      RETURN
23005 CONTINUE
23003 I = I + 21
      GOTO 23002
23004 CONTINUE
      RETURN
      END
      SUBROUTINE ENTER(NAME, N)
      INTEGER NAME(26)
      INTEGER N
      INTEGER I
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      IF(.NOT.(IWDIR .EQ. 0))GOTO 23009
      CALL RDDIR(1)
23009 CONTINUE
      I = 0
23011 IF(.NOT.(I .LT. WSIZE))GOTO 23013
      IF(.NOT.(WDIR(I+1) .EQ. 0))GOTO 23014
      GOTO 23013
23014 CONTINUE
23012 I = I + 21
      GOTO 23011
23013 CONTINUE
      IF(.NOT.(I .GE. WSIZE))GOTO 23016
      IF(.NOT.(I + 21 .GT. 250*21))GOTO 23018
      CALL ERROR(30HENTER: OUT OF DIRECTORY SPACE.)
23018 CONTINUE
      WSIZE = I + 21
23016 CONTINUE
      WDIR(I+1) = N
      CALL SCOPY(NAME, 1, WDIR, I + 2)
      WMOD = WMOD + 1
      IF(.NOT.(WMOD .GE. 10))GOTO 23020
      CALL WRDIR
23020 CONTINUE
      RETURN
      END
      INTEGER FUNCTION LOOKUP(NAME, N)
      INTEGER NAME(20)
      INTEGER N
      INTEGER I, EQUAL
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      IF(.NOT.(IWDIR .EQ. 0))GOTO 23022
      CALL RDDIR(1)
23022 CONTINUE
      I = 0
23024 IF(.NOT.(I .LT. WSIZE))GOTO 23026
      IF(.NOT.(WDIR(I+1) .NE. 0 .AND. EQUAL(NAME, WDIR(I+2)) .EQ. 1))GOT
     *O 23027
      N = WDIR(I+1)
      LOOKUP=(0)
      RETURN
23027 CONTINUE
23025 I = I + 21
      GOTO 23024
23026 CONTINUE
      LOOKUP=(10001)
      RETURN
      END
      SUBROUTINE NEWDIR(N)
      INTEGER N
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      COMMON /CUWDIR/ IUWDIR
      INTEGER IUWDIR
      CALL WRDIR
      IWDIR = N
      WSIZE = 0
      IF(.NOT.(N .EQ. 0))GOTO 23029
      IUWDIR = 1
23029 CONTINUE
      RETURN
      END
      SUBROUTINE RDDIR(N)
      INTEGER N
      INTEGER I, FD, OPEN, INODE(37), CTOI, GETLIN, WBUF(120), LENGTH
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      IF(.NOT.(N .EQ. IWDIR))GOTO 23031
      RETURN
23031 CONTINUE
      IF(.NOT.(WMOD .GT. 0))GOTO 23033
      CALL WRDIR
23033 CONTINUE
      CALL IGET(N, INODE)
      IF(.NOT.(INODE(3) .NE. 100))GOTO 23035
      CALL ERROR(23HRDDIR: NOT A DIRECTORY.)
23035 CONTINUE
      FD = OPEN(INODE(11), 0)
      IF(.NOT.(FD .EQ. 10001))GOTO 23037
      CALL ERROR(28HRDDIR: CAN'T READ DIRECTORY.)
23037 CONTINUE
      WSIZE = 0
23039 IF(.NOT.(GETLIN(WBUF, FD) .NE. 10003))GOTO 23041
      I = LENGTH(WBUF)
      IF(.NOT.(WBUF(I) .EQ. 10))GOTO 23042
      WBUF(I) = 10002
23042 CONTINUE
      I = 1
      WDIR(WSIZE+1) = CTOI(WBUF, I)
      CALL SCOPY(WBUF, I + 1, WDIR, WSIZE + 2)
23040 WSIZE = WSIZE + 21
      GOTO 23039
23041 CONTINUE
      CALL CLOSE(FD)
      IWDIR = N
      WMOD = 0
      RETURN
      END
      SUBROUTINE WRDIR
      INTEGER I, FD, CREATE, INODE(37)
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      IF(.NOT.(WMOD .EQ. 0))GOTO 23044
      RETURN
23044 CONTINUE
      CALL IGET(IWDIR, INODE)
      FD = CREATE(INODE(11), 1)
      IF(.NOT.(FD .EQ. 10001))GOTO 23046
      CALL ERROR(30HWRDIR: CAN'T CREATE DIRECTORY.)
23046 CONTINUE
      I = 0
23048 IF(.NOT.(I .LT. WSIZE))GOTO 23050
      IF(.NOT.(WDIR(I+1) .NE. 0))GOTO 23051
      CALL PUTINT(WDIR(I+1), 5, FD)
      CALL PUTCH(32, FD)
      CALL PUTLIN(WDIR(I+2), FD)
      CALL PUTCH(10, FD)
23051 CONTINUE
23049 I = I + 21
      GOTO 23048
23050 CONTINUE
      CALL CLOSE(FD)
      WMOD = 0
      RETURN
      END
      INTEGER FUNCTION IALLOC(ARRAY)
      INTEGER ARRAY(37)
      INTEGER I, J, FD
      INTEGER OPEN, GETLIN, UALLOC, LENGTH
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      IF(.NOT.(NINODE .EQ. 0))GOTO 23000
      CALL IUPDAT
      FD = OPEN(INAME, 0)
      IF(.NOT.(FD .EQ. 10001))GOTO 23002
      CALL ERROR(25HIALLOC: CAN'T READ ILIST.)
23002 CONTINUE
      NINODE = 15
      I = 1
23004 IF(.NOT.(GETLIN(IBUF, FD) .NE. 10003))GOTO 23006
      IF(.NOT.(IBUF(1) .EQ. 48))GOTO 23007
      INUM(NINODE) = I
      NINODE = NINODE - 1
      IF(.NOT.(NINODE .EQ. 0))GOTO 23009
      GOTO 23006
23009 CONTINUE
23007 CONTINUE
23005 I = I + 1
      GOTO 23004
23006 CONTINUE
23011 IF(.NOT.(NINODE .GT. 0))GOTO 23012
      INUM(NINODE) = I
      I = I + 1
      NINODE = NINODE - 1
      GOTO 23011
23012 CONTINUE
      NINODE = 15
      CALL CLOSE(FD)
23000 CONTINUE
      IALLOC = INUM(NINODE)
      NINODE = NINODE - 1
      I = UALLOC(I)
      INODES(I+1) = 0
      INODES(I+2) = IALLOC
      INODES(I+3) = 112
      INODES(I+4) = 1
      CALL DATE4(INODES(I+6), INODES(I+7), INODES(I+5), JUNK)
      CALL DATE4(INODES(I+9), INODES(I+10), INODES(I+8), JUNK)
      CALL SCOPY(INAME, 1, INODES(I+11), 1)
      J = LENGTH(INAME)
      KK = I + 11 + J
      INODES(KK) = 46
      J = ITOC(IALLOC, INODES(KK+1), 37-11-J-1)
      CALL SCOPY(INODES, I + 1, ARRAY, 1)
      RETURN
      END
      SUBROUTINE ICLEAR(FLAG)
      INTEGER FLAG
      INTEGER I
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      IF(.NOT.(FLAG .EQ. 1))GOTO 23013
      CALL IUPDAT
23013 CONTINUE
      NINODE = 0
      I = 0
23015 IF(.NOT.(I .LT. 30*37))GOTO 23017
      INODES(I+2) = 0
23016 I = I + 37
      GOTO 23015
23017 CONTINUE
      RETURN
      END
      INTEGER FUNCTION ICMP(X, Y)
      INTEGER X, Y
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      ICMP=(INODES(X+2) - INODES(Y+2))
      RETURN
      END
      SUBROUTINE IFREE(N)
      INTEGER N
      INTEGER INODE(37)
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      IF(.NOT.(NINODE .LT. 15))GOTO 23018
      NINODE = NINODE + 1
      INUM(NINODE) = N
23018 CONTINUE
      INODE(2) = N
      INODE(3) = 48
      CALL IPUT(N, INODE)
      RETURN
      END
      SUBROUTINE IGET(N, ARRAY)
      INTEGER N
      INTEGER ARRAY(37)
      INTEGER I, J, OPEN, UALLOC, GETLIN
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      I = 0
23020 IF(.NOT.(I .LT. 30*37))GOTO 23022
      IF(.NOT.(INODES(I+2) .EQ. N))GOTO 23023
      GOTO 23022
23023 CONTINUE
23021 I = I + 37
      GOTO 23020
23022 CONTINUE
      IF(.NOT.(I .GE. 30*37))GOTO 23025
      I = UALLOC(I)
      IF(.NOT.(IFD .NE. 10003 .AND. N .LT. IPOS))GOTO 23027
      CALL CLOSE(IFD)
      IFD = 10003
23027 CONTINUE
      IF(.NOT.(IFD .EQ. 10003))GOTO 23029
      IFD = OPEN(INAME, 0)
      IPOS = 0
23029 CONTINUE
      IF(.NOT.(IFD .EQ. 10001))GOTO 23031
      CALL ERROR(23HIGET: CAN'T READ ILIST.)
23031 CONTINUE
23033 IF(.NOT.(IPOS .LT. N))GOTO 23035
      IF(.NOT.(GETLIN(IBUF, IFD) .EQ. 10003))GOTO 23036
      CALL ERROR(18HIGET: BAD INUMBER.)
23036 CONTINUE
23034 IPOS = IPOS + 1
      GOTO 23033
23035 CONTINUE
      CALL IREAD(INODES(I+1))
      INODES(I+2) = N
23025 CONTINUE
      IF(.NOT.(INODES(I+3) .EQ. 48))GOTO 23038
      CALL ERROR(17HIGET: FREE INODE.)
23038 CONTINUE
      CALL SCOPY(INODES, I + 1, ARRAY, 1)
      RETURN
      END
      SUBROUTINE IPUT(N, ARRAY)
      INTEGER N
      INTEGER ARRAY(37)
      INTEGER I, UALLOC
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      I = 0
23040 IF(.NOT.(I .LT. 30*37))GOTO 23042
      IF(.NOT.(INODES(I+2) .EQ. N))GOTO 23043
      GOTO 23042
23043 CONTINUE
23041 I = I + 37
      GOTO 23040
23042 CONTINUE
      IF(.NOT.(I .GE. 30*37))GOTO 23045
      I = UALLOC(I)
23045 CONTINUE
      CALL SCOPY(ARRAY, 1, INODES, I + 1)
      INODES(I+1) = 1
      IMOD = IMOD + 1
      IF(.NOT.(IMOD .GE. 10))GOTO 23047
      CALL IUPDAT
23047 CONTINUE
      RETURN
      END
      SUBROUTINE IREAD(INODE)
      INTEGER INODE(37)
      INTEGER I, LENGTH, CTOI
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      I = LENGTH(IBUF)
      IF(.NOT.(IBUF(I) .EQ. 10))GOTO 23049
      IBUF(I) = 10002
23049 CONTINUE
      INODE(1) = 0
      INODE(2) = 0
      INODE(3) = IBUF(1)
      I = 3
      INODE(4) = CTOI(IBUF, I)
      INODE(5) = CTOI(IBUF, I)
      INODE(6) = CTOI(IBUF, I)
      INODE(7) = CTOI(IBUF, I)
      INODE(8) = CTOI(IBUF, I)
      INODE(9) = CTOI(IBUF, I)
      INODE(10) = CTOI(IBUF, I)
      CALL SCOPY(IBUF, I+1, INODE, 11)
      RETURN
      END
      SUBROUTINE IUPDAT
      INTEGER I, J, N, FDI, FDO, IP(30), JUNK, CREATE, OPEN, GETLIN
      EXTERNAL ICMP
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
      INTEGER TMPNAM(6)
      DATA TMPNAM(1)/105/,TMPNAM(2)/46/,TMPNAM(3)/116/,TMPNAM(4)/109/,TM
     *PNAM(5)/112/,TMPNAM(6)/10002/
      IF(.NOT.(IFD .NE. 10003))GOTO 23051
      CALL CLOSE(IFD)
      IFD = 10003
23051 CONTINUE
      IF(.NOT.(IMOD .EQ. 0))GOTO 23053
      RETURN
23053 CONTINUE
      IMOD = 0
      J = 0
      I = 0
23055 IF(.NOT.(I .LT. 30*37))GOTO 23057
      IF(.NOT.(INODES(I+2) .GT. 0 .AND. INODES(I+1) .NE. 0))GOTO 23058
      INODES(I+1) = 0
      J = J + 1
      IP(J) = I
23058 CONTINUE
23056 I = I + 37
      GOTO 23055
23057 CONTINUE
      IF(.NOT.(J .EQ. 0))GOTO 23060
      RETURN
23060 CONTINUE
      IP(J+1) = -1
      CALL QSORT(J, IP, ICMP)
      FDI = OPEN(INAME, 0)
      IF(.NOT.(FDI .EQ. 10001))GOTO 23062
      CALL ERROR(25HIUPDAT: CAN'T READ ILIST.)
23062 CONTINUE
      FDO = CREATE(TMPNAM, 1)
      IF(.NOT.(FDO .EQ. 10001))GOTO 23064
      CALL ERROR(37HIUPDAT: CAN'T CREATE TEMPORARY ILIST.)
23064 CONTINUE
      I = 0
      J = 1
23066 IF(.NOT.(IP(J) .GE. 0))GOTO 23068
      N = IP(J)
      N = INODES(N+2)
      I = I + 1
23069 IF(.NOT.(I .LT. N))GOTO 23071
      IF(.NOT.(GETLIN(IBUF, FDI) .NE. 10003))GOTO 23072
      CALL PUTLIN(IBUF, FDO)
23072 CONTINUE
23070 I = I + 1
      GOTO 23069
23071 CONTINUE
      JUNK = GETLIN(IBUF, FDI)
      N = IP(J)
      CALL IWRITE(INODES(N+1), FDO)
23067 J = J + 1
      GOTO 23066
23068 CONTINUE
23074 IF(.NOT.(GETLIN(IBUF, FDI) .NE. 10003))GOTO 23075
      CALL PUTLIN(IBUF, FDO)
      GOTO 23074
23075 CONTINUE
      CALL CLOSE(FDI)
      CALL CLOSE(FDO)
      CALL AMOVE(TMPNAM, INAME)
      RETURN
      END
      SUBROUTINE IWRITE(INODE, FD)
      INTEGER INODE(37), FD
      CALL PUTCH(INODE(3), FD)
      IF(.NOT.(INODE(3) .NE. 48))GOTO 23076
      CALL PUTINT(INODE(4), 4, FD)
      CALL PUTINT(INODE(5), 5, FD)
      CALL PUTINT(INODE(6), 5, FD)
      CALL PUTINT(INODE(7), 5, FD)
      CALL PUTINT(INODE(8), 5, FD)
      CALL PUTINT(INODE(9), 5, FD)
      CALL PUTINT(INODE(10), 5, FD)
      CALL PUTCH(32, FD)
      CALL PUTLIN(INODE(11), FD)
23076 CONTINUE
      CALL PUTCH(10, FD)
      RETURN
      END
      INTEGER FUNCTION UALLOC(I)
      INTEGER I
      INTEGER LAST
      COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R
     *NAME(26), IBUF(120), IFD, IPOS
      INTEGER NINODE
      INTEGER INUM
      INTEGER INODES
      INTEGER IMOD
      INTEGER INAME
      INTEGER RNAME
      INTEGER IBUF
      INTEGER IFD
      INTEGER IPOS
23078 CONTINUE
      LAST = 0
      I = 0
23081 IF(.NOT.(I .LT. 30*37))GOTO 23083
      IF(.NOT.(INODES(I+2) .EQ. 0))GOTO 23084
      UALLOC=(I)
      RETURN
23084 CONTINUE
      IF(.NOT.(INODES(I+1) .EQ. 0))GOTO 23086
      LAST = I + 1
23086 CONTINUE
23085 CONTINUE
23082 I = I + 37
      GOTO 23081
23083 CONTINUE
      IF(.NOT.(LAST .NE. 0))GOTO 23088
      I = LAST - 1
      UALLOC=(I)
      RETURN
23088 CONTINUE
      CALL IUPDAT
23079 GOTO 23078
23080 CONTINUE
      RETURN
      END
      INTEGER FUNCTION CSCAN(PATH, I)
      INTEGER PATH(80)
      INTEGER I
      INTEGER N, SCAN
      I = 1
      IF(.NOT.(SCAN(PATH, I) .EQ. 10001))GOTO 23000
      CSCAN=(10001)
      RETURN
23000 CONTINUE
      IF(.NOT.(PATH(1) .EQ. 47 .AND. PATH(2) .EQ. 10002))GOTO 23002
      CSCAN=(10001)
      RETURN
23002 CONTINUE
      IF(.NOT.(LOOKUP(PATH(I), JUNK) .EQ. 0))GOTO 23004
      CSCAN=(10001)
      RETURN
23004 CONTINUE
      CSCAN=(0)
      RETURN
      END
      INTEGER FUNCTION ISCAN(PATH, N)
      INTEGER PATH(80)
      INTEGER N
      INTEGER I, SCAN, LOOKUP
      I = 1
      IF(.NOT.(SCAN(PATH, I) .EQ. 10001))GOTO 23006
      ISCAN=(10001)
      RETURN
23006 CONTINUE
      IF(.NOT.(PATH(1) .EQ. 47 .AND. PATH(2) .EQ. 10002))GOTO 23008
      N = 1
      ISCAN=(0)
      RETURN
23008 CONTINUE
      ISCAN=(LOOKUP(PATH(I), N))
      RETURN
23009 CONTINUE
      RETURN
      END
      INTEGER FUNCTION SCAN(PATH, I)
      INTEGER PATH(80)
      INTEGER I
      INTEGER INODE(37), NAME(20)
      INTEGER IP, J, LENGTH, LOOKUP
      COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD
      INTEGER IWDIR
      INTEGER WSIZE
      INTEGER WDIR
      INTEGER WMOD
      COMMON /CUWDIR/ IUWDIR
      INTEGER IUWDIR
      IF(.NOT.(PATH(I) .EQ. 47 .OR. IWDIR .EQ. 0))GOTO 23010
      IP = 1
      GOTO 23011
23010 CONTINUE
      IP = IUWDIR
23011 CONTINUE
23012 CONTINUE
23015 IF(.NOT.(PATH(I) .EQ. 47))GOTO 23016
      I = I + 1
      GOTO 23015
23016 CONTINUE
      CALL IGET(IP, INODE)
      IF(.NOT.(INODE(3) .NE. 100))GOTO 23017
      SCAN=(10001)
      RETURN
23017 CONTINUE
      CALL RDDIR(IP)
      J = 1
23019 IF(.NOT.(PATH(I) .NE. 47 .AND. PATH(I) .NE. 10002))GOTO 23021
      IF(.NOT.(J .LT. 20))GOTO 23022
      NAME(J) = PATH(I)
      J = J + 1
23022 CONTINUE
23020 I = I + 1
      GOTO 23019
23021 CONTINUE
      NAME(J) = 10002
      IF(.NOT.(PATH(I) .EQ. 10002))GOTO 23024
      I = I - LENGTH(NAME)
      SCAN=(IP)
      RETURN
23024 CONTINUE
      IF(.NOT.(LOOKUP(NAME, IP) .EQ. 10001))GOTO 23026
      SCAN=(10001)
      RETURN
23026 CONTINUE
23013 GOTO 23012
23014 CONTINUE
      RETURN
      END
      SUBROUTINE AMOVE(NAME1, NAME2)
      INTEGER NAME1(100), NAME2(100)
      INTEGER CREATE, OPEN
      INTEGER GETCH, C
      INTEGER FD1, FD2
      FD1 = OPEN(NAME1, 0)
      IF(.NOT.(FD1 .EQ. 10001))GOTO 23000
      CALL CANT(NAME1)
23000 CONTINUE
      FD2 = CREATE(NAME2, 1)
      IF(.NOT.(FD2 .EQ. 10001))GOTO 23002
      CALL CANT(NAME2)
23002 CONTINUE
23004 IF(.NOT.(GETCH(C, FD1) .NE. 10003))GOTO 23005
      CALL PUTCH(C, FD2)
      GOTO 23004
23005 CONTINUE
      CALL CLOSE(FD1)
      CALL CLOSE(FD2)
      RETURN
      END
      SUBROUTINE CANT(BUF)
      INTEGER BUF(120)
      CALL PUTLIN(BUF, 2)
      CALL REMARK(13H: CAN'T OPEN.)
      STOP
      RETURN
      END
      INTEGER FUNCTION CTOI(IN, I)
      INTEGER IN(100)
      INTEGER I, S
23006 IF(.NOT.(IN(I) .EQ. 32 .OR. IN(I) .EQ. 9))GOTO 23007
      I = I + 1
      GOTO 23006
23007 CONTINUE
      IF(.NOT.(IN(I) .EQ. 45 .OR. IN(I) .EQ. 43))GOTO 23008
      S = IN(I)
      I = I + 1
      GOTO 23009
23008 CONTINUE
      S = 0
23009 CONTINUE
      CTOI = 0
23010 IF(.NOT.(IN(I) .NE. 10002))GOTO 23012
      IF(.NOT.(IN(I) .LT. 48 .OR. IN(I) .GT. 57))GOTO 23013
      GOTO 23012
23013 CONTINUE
      CTOI = 10 * CTOI + IN(I) - 48
23011 I = I + 1
      GOTO 23010
23012 CONTINUE
      IF(.NOT.(S .EQ. 45))GOTO 23015
      CTOI = -CTOI
23015 CONTINUE
      RETURN
      END
      INTEGER FUNCTION EQUAL(STR1, STR2)
      INTEGER STR1(100), STR2(100)
      INTEGER I
      I = 1
23017 IF(.NOT.(STR1(I) .EQ. STR2(I)))GOTO 23019
      IF(.NOT.(STR1(I) .EQ. 10002))GOTO 23020
      EQUAL = 1
      RETURN
23020 CONTINUE
23018 I = I + 1
      GOTO 23017
23019 CONTINUE
      EQUAL = 0
      RETURN
      END
      INTEGER FUNCTION GETLIN(LINE, F)
      INTEGER LINE(120), C, GETCH
      INTEGER F
      GETLIN = 0
23022 IF(.NOT.(GETCH(C, F) .NE. 10003))GOTO 23024
      IF(.NOT.(GETLIN .LT. 120 - 1))GOTO 23025
      GETLIN = GETLIN + 1
      LINE(GETLIN) = C
23025 CONTINUE
      IF(.NOT.(C .EQ. 10))GOTO 23027
      GOTO 23024
23027 CONTINUE
23023 GOTO 23022
23024 CONTINUE
      LINE(GETLIN+1) = 10002
      IF(.NOT.(GETLIN .EQ. 0 .AND. C .EQ. 10003))GOTO 23029
      GETLIN = 10003
23029 CONTINUE
      RETURN
      END
      INTEGER FUNCTION ITOC(INT, STR, SIZE)
      INTEGER IABS, MOD
      INTEGER I, INT, INTVAL, J, K, SIZE
      INTEGER STR(100)
      INTVAL = IABS(INT)
      STR(1) = 10002
      I = 1
23031 CONTINUE
      I = I + 1
      STR(I) = 48 + MOD(INTVAL,10)
      INTVAL = INTVAL / 10
23032 IF(.NOT.(INTVAL .EQ. 0 .OR. I .GE. SIZE))GOTO 23031
23033 CONTINUE
      IF(.NOT.(INT .LT. 0 .AND. I .LT. SIZE))GOTO 23034
      I = I + 1
      STR(I) = 45
23034 CONTINUE
      ITOC = I - 1
      J = 1
23036 IF(.NOT.(J .LT. I))GOTO 23038
      K = STR(I)
      STR(I) = STR(J)
      STR(J) = K
      I = I - 1
23037 J = J + 1
      GOTO 23036
23038 CONTINUE
      RETURN
      END
      INTEGER FUNCTION LENGTH(STR)
      INTEGER STR(100)
      LENGTH = 0
23039 IF(.NOT.(STR(LENGTH+1) .NE. 10002))GOTO 23041
23040 LENGTH = LENGTH + 1
      GOTO 23039
23041 CONTINUE
      RETURN
      END
      SUBROUTINE PUTINT(N, W, F)
      INTEGER N, W, F
      INTEGER CHARS(10)
      INTEGER ITOC
      INTEGER JUNK
      JUNK = ITOC(N, CHARS, 10)
      CALL PUTSTR(CHARS, W, F)
      RETURN
      END
      SUBROUTINE PUTLIN(LINE, F)
      INTEGER LINE(120)
      INTEGER F, I
      I = 1
23042 IF(.NOT.(LINE(I) .NE. 10002))GOTO 23044
      CALL PUTCH(LINE(I), F)
23043 I = I + 1
      GOTO 23042
23044 CONTINUE
      RETURN
      END
      SUBROUTINE PUTSTR(STR, W, F)
      INTEGER STR(120)
      INTEGER W, F, LEN, I, LENGTH, NW
      LEN = LENGTH(STR)
      I = LEN
23045 IF(.NOT.(I .LT. W))GOTO 23047
      CALL PUTCH(32, F)
23046 I = I + 1
      GOTO 23045
23047 CONTINUE
      I = 1
23048 IF(.NOT.(STR(I) .NE. 10002))GOTO 23050
      CALL PUTCH(STR(I), F)
23049 I = I + 1
      GOTO 23048
23050 CONTINUE
      NW = -W
      I = LEN
23051 IF(.NOT.(I .LT. NW))GOTO 23053
      CALL PUTCH(32, F)
23052 I = I + 1
      GOTO 23051
23053 CONTINUE
      RETURN
      END
      SUBROUTINE QSORT(N, A, COMPAR)
      INTEGER N, A(100)
      EXTERNAL COMPAR
      INTEGER COMPAR
      INTEGER I, J, LV(20), P, PIVOT, UV(20), T
      LV(1) = 1
      UV(1) = N
      P = 1
23054 IF(.NOT.(P .GT. 0))GOTO 23055
      IF(.NOT.(LV(P) .GE. UV(P)))GOTO 23056
      P = P - 1
      GOTO 23057
23056 CONTINUE
      I = LV(P) - 1
      J = UV(P)
      PIVOT = A(J)
23058 IF(.NOT.(I .LT. J))GOTO 23059
      I=I+1
23060 IF(.NOT.(COMPAR(A(I), PIVOT) .LT. 0))GOTO 23062
23061 I=I+1
      GOTO 23060
23062 CONTINUE
      J = J - 1
23063 IF(.NOT.(J .GT. I))GOTO 23065
      IF(.NOT.(COMPAR(A(J), PIVOT) .LE. 0))GOTO 23066
      GOTO 23065
23066 CONTINUE
23064 J = J - 1
      GOTO 23063
23065 CONTINUE
      IF(.NOT.(I .LT. J))GOTO 23068
      T = A(I)
      A(I) = A(J)
      A(J) = T
23068 CONTINUE
      GOTO 23058
23059 CONTINUE
      J = UV(P)
      T = A(I)
      A(I) = A(J)
      A(J) = T
      IF(.NOT.(I-LV(P) .LT. UV(P)-I))GOTO 23070
      LV(P+1) = LV(P)
      UV(P+1) = I - 1
      LV(P) = I + 1
      GOTO 23071
23070 CONTINUE
      LV(P+1) = I + 1
      UV(P+1) = UV(P)
      UV(P) = I - 1
23071 CONTINUE
      P = P + 1
23057 CONTINUE
      GOTO 23054
23055 CONTINUE
      RETURN
      END
      SUBROUTINE SCOPY(FROM, I, TO, J)
      INTEGER FROM(100), TO(100)
      INTEGER I, J, K1, K2
      K2 = J
      K1 = I
23072 IF(.NOT.(FROM(K1) .NE. 10002))GOTO 23074
      TO(K2) = FROM(K1)
      K2 = K2 + 1
23073 K1 = K1 + 1
      GOTO 23072
23074 CONTINUE
      TO(K2) = 10002
      RETURN
      END
#========== RATFOR PREPROCESSOR AND I/O SYSTEM IN RATFOR AND FORTRAN ==========
#-H- RATFOR.DOC 15977 1980 103 2140
# NAME
#    RATFOR - RATFOR PREPROCESSOR
#
# FILES
#    RATDEF     STANDARD RATFOR DEFINITIONS
#    C[A-Z]*    LABELED COMMONS
#    RATFOR.RAT MACHINE INDEPENDENT PART OF RATFOR
#    MAIN.RAT   TRIVIAL MAIN PROGRAM FOR RATFOR
#    RATIO.RAT  MACHINE INDEPENDENT I/O SYSTEM
#    EBCDIC.RAT EBCDIC-ASCII TRANSLATION TABLES
#    MBOOT      BOOTSTRAP
#
# INSTALLATION
#    THE MACHINE-INDEPENDENT VERSION OF THE RATFOR PREPROCESSOR IS
#    INSTALLED BY A "BOOTSTRAPPING" PROCESS.  THE RELEVANT FILES ARE
#    LISTED IN THE PREVIOUS SECTION.  MBOOT IS A COMPLETE
#    MACHINE-INDEPENDENT RATFOR PREPROCESSOR WRITTEN IN FORTRAN.  WITH
#    THE EXCEPTION OF HOLLERITH LITERALS, THE FORTRAN CODE IN MBOOT IS
#    IN UPPER CASE.  IT WAS PRODUCED BY PREPROCESSING MAIN.RAT,
#    RATIO.RAT, AND RATFOR.RAT, AND CONCATENATING THE RESULTS.  THIS
#    FILE IS READY FOR COMPILATION.
#
#    CONCEPTUALLY, THE BOOTSTRAPPING PROCESS IS SIMPLE.  MBOOT IS
#    COMPILED, TESTED, AND INSTALLED AS "VERSION 0" OF RATFOR.
#    MODIFICATIONS NECESSARY TO ACCOMODATE LOCAL CONVENTIONS AND USAGE
#    ARE MADE TO MAIN.RAT, RATIO.RAT, AND RATFOR.RAT.  THE VERSION 0
#    RATFOR IS USED TO PRODUCE A NEW, PRESUMABLY BETTER, VERSION 1
#    RATFOR USING THE MODIFIED FILES.  THIS PROCESS CAN CONTINUE UNTIL
#    FURTHER MODIFICATIONS ARE UNNECESSARY.
#
#    IN PRACTICE, HOWEVER, OBTAINING VERSION 0 CANNOT BE ACCOMPLISHED
#    BY SIMPLY COMPILING MBOOT.  A MORE TYPICAL SCENARIO IS THAT MBOOT
#    ITSELF MUST BE MODIFIED BEFORE IT IS USABLE AS A VERSION 0
#    RATFOR.  IN ADDITION, RATIO.RAT IS NOT MEANT TO BE USED IN THE
#    FINAL VERSION OF RATFOR; FORTRAN I/O IS SIMPLY TOO SLOW.  THE
#    MAJOR STEP THAT MUST BE MADE IN ORDER TO MAKE ANY REAL USE OF
#    RATFOR IS THE IMPLEMENTATION OF A SYSTEM-SPECIFIC I/O SYSTEM.
#    WHAT FOLLOWS IS A DESCRIPTION OF HOW TO MODIFY MBOOT TO GET A
#    VERSION 0 RATFOR AND SOME SUGGESTIONS CONCERNING THE
#    IMPLEMENTATION OF AN I/O SYSTEM.
#
#    THE MODIFICATIONS TO MBOOT ARE ESSENTIALLY THOSE NECESSARY TO MAKE
#    RATIO.RAT (AND PERHAPS MAIN.RAT) CONFORM TO LOCAL USAGE.
#    RATIO.RAT IS AN IMPLEMENTATION OF THE I/O PRIMITIVES DESCRIBED IN
#    SOFTWARE TOOLS USING FORTRAN I/O.  THE PRIMITIVES ARE BASED ON THE
#    ASCII CHARACTER SET.  CHARACTERS MUST BE MAPPED FROM THE HOST
#    CHARACTER SET TO ASCII ON INPUT AND VICE-VERSA ON OUTPUT.  AS
#    DESCRIBED IN SOFTWARE TOOLS, STRINGS ARE IMPLEMENTED AS ARRAYS OF
#    ASCII CHARACTERS, ONE RIGHT-JUSTIFIED CHARACTER PER WORD,
#    TERMINATED BY THE VALUE OF THE PARAMETER EOS (SEE RATDEF).  THE
#    IMPORTANT PRIMITIVES ARE AS FOLLOWS.
#
#    INTERNAL-NAME = OPEN(EXTERNAL-NAME, MODE)
#       OPENS A FILE.  THE SYSTEM-DEPENDENT NAME IS A CHARACTER STRING
#       PASSED IN THE ARRAY EXTERNAL-NAME; MODE IS 0 FOR READING, 1 FOR
#       WRITING, AND 2 FOR READING AND WRITING.  THESE ARE THE VALUES
#       OF THE PARAMETERS READ, WRITE, AND READWRITE, RESPECTIVELY.
#       THE READWRITE MODE IS NOT USED BY RATFOR AND IS NOT IMPLEMENTED
#       IN RATIO.RAT.  OPEN RETURNS AN INTERNAL-NAME, WHICH IS SIMPLY A
#       SMALL INTEGER.  THESE INTEGERS ARE USUALLY CALLED FILE
#       DESCRIPTORS; THE VARIABLE FD IS OFTEN USED FOR A FILE
#       DESCRIPTOR.  IF THE FILE CANNOT BE OPENED OR DOES NOT EXISTS,
#       OPEN RETURNS ERR, WHICH IS A SYMBOLIC PARAMETER WHOSE VALUE IS
#       NOT A VALID FILE DESCRIPTOR.
#
#    INTERNAL-NAME = CREATE(EXTERNAL-NAME, MODE)
#       IS MUCH LIKE OPEN EXCEPT THAT THE INDICATED FILE IS CREATED AND
#       THEN OPENED ACCORDING TO MODE.
#
#    CALL CLOSE(INTERNAL-NAME)
#       BREAKS THE CONNECTION BETWEEN THE INTERNAL-NAME AND THE OPENED
#       EXTERNAL FILE.
#
#    C = GETCH(C, FD)
#       READS ONE CHARACTER FROM THE FILE OPENED ON FILE DESCRIPTOR
#       FD.  THE RIGHT-JUSTIFIED ASCII CHARACTER IS RETURNED IN C AND
#       AS THE VALUE OF THE FUNCTION GETCH.  GETCH PERFORMS THE
#       TRANSLATION FROM THE HOST MACHINE CHARACTER SET TO ASCII.  IF
#       END OF FILE IS REACHED, GETCH RETURNS EOF (A SYMBOLIC
#       PARAMETER).  AT THE END OF A LINE, GETCH MUST RETURN A NEWLINE
#       CHARACTER (SEE RATDEF) EVEN IF NO SUCH CHARACTER EXISTS IN THE
#       FILE.  (SEE GETCH IN RATIO.RAT).
#
#    CALL PUTCH(C, FD)
#       OUTPUTS THE RIGHT-JUSTIFIED ASCII CHARACTER C TO THE FILE
#       OPENED ON FILE DESCRIPTOR FD.  PUTCH PERFORMS THE TRANSLATION
#       FROM ASCII TO THE HOST MACHINE CHARACTER SET.
#
#    THERE ARE OTHER LESS IMPORTANT PRIMITIVES; SEE RATIO.RAT.
#
#    BY CONVENTION, FILE DESCRIPTOR 0 IS THE "STANDARD INPUT", 1 IS
#    STANDARD OUTPUT, AND 2 IS ERROR OUTPUT.  THESE FILES ARE ASSUMED
#    TO BE OPENED WHEN PROGRAM EXECUTION BEGINS.
#
#    USING RATIO.RAT AS A GUIDE, MAKE THE FOLLOWING MODIFICATIONS TO
#    MBOOT AND TO RATIO.RAT AND MAIN.RAT.
#
#    1.  THE MAPPING FROM ASCII TO THE HOST CHARACTER SET AND
#    VICE-VERSA IS CONTROLLED BY THE ARRAYS EXTCHR AND INTCHR.  THESE
#    ARRAYS ARE INITIALIZED IN THE BLOCK DATA SUBPROGRAM IN RATIO.RAT.
#    CHECK THAT THE TRANSLATIONS ARE SATISFACTORY.
#
#    2.  RATIO.RAT IS INITIALIZED SO THAT STANDARD INPUT CORRESPONDS TO
#    FORTRAN UNIT 5 AND STANDARD OUTPUT AND ERROR OUTPUT BOTH
#    CORRESPOND TO FORTRAN UNIT 6.  THIS IS ACCOMPLISHED BY THE
#    INITIALIZATION OF SPECIFIC ELEMENTS OF THE ARRAY FILTAB IN THE
#    BLOCK DATA SUBPROGRAM.  IF THESE CORRESPONDENCES ARE NOT
#    SATISFACTORY, CHANGE THE INITIAL VALUE OF FILTAB(4), FILTAB(144),
#    OR FILTAB(284) AS APPROPRIATE (FOR DESCRIPTORS 0, 1, OR 2,
#    RESPECTIVELY).
#
#    3.  IF NECESSARY, CHANGE MAIN.RAT SO THAT STANDARD INPUT, STANDARD
#    OUTPUT, AND ERROR OUTPUT ARE OPENED.
#
#    4.  THERE IS A FORMAT STATEMENT IN REMARK (RATIO.RAT) THAT
#    CONTAINS AN A5 CODE.  IT APPEARS AT ABOUT LINE 413 IN MBOOT.  THIS
#    SHOULD BE CHANGED TO WHATEVER IS APPROPRIATE; THE 5 REPRESENTS THE
#    NUMBER OF CHARACTERS PER WORD ON THE HOST COMPUTER.
#
#    5.  CALLS TO OPEN AND CREATE RESULT IN CALLS TO OPNFIL (SEE
#    RATIO.RAT).  OPNFIL MUST DO THE ACTUAL OPEN AND RETURN THE FORTRAN
#    UNIT NUMBER ON WHICH THE FILE IS OPENED.  THE ASSOCIATION OF A
#    FORTRAN UNIT NUMBER IS DETERMINED BY OPNFIL.  THE CALL IS
#
#       UNIT = OPNFIL(NAME, MODE, FD)
#
#    WHERE NAME IS THE EXTERNAL NAME OF THE FILE IN RIGHT-JUSTIFIED
#    ASCII, MODE IS THE I/O MODE (READ, WRITE, OR READWRITE), AND FD IS
#    THE FILE DESCRIPTOR THAT IS ULTIMATELY RETURNED BY OPEN OR
#    CREATE.  THE LAST ARGUMENT IS USEFUL IN ASSIGNING FORTRAN UNIT
#    NUMBERS.  IF THE FILE CANNOT BE OPENED, OPNFIL SHOULD RETURN ERR
#    (SEE RATDEF).  THE DISTRIBUTED VERSION OF OPNFIL ASSUMES THAT THE
#    EXTERNAL NAME IS THE FORTRAN UNIT NUMBER AND SIMPLY CONVERTS THE
#    NAME TO AN INTEGER.  THUS INCLUDE STATEMENTS ARE OF THE FORM
#    INCLUDE N.  IN ORDER TO OBTAIN A USABLE VERSION 0, IT IS USUALLY
#    NECESSARY TO CHANGE OPNFIL SO THAT MEANINGFUL NAMES (LIKE RATDEF,
#    CDEFIO, ETC.) CAN BE USED.  THIS IS NOT NECESSARY IF THE HOST
#    OPERATING SYSTEM PERMITS THE ASSOCIATION OF FORTRAN UNIT NUMBERS
#    WITH NAMED FILES BEFORE PROGRAM EXECUTION; THE IBM DD JCL
#    STATEMENT IS AN EXAMPLE OF A SUFFICIENT CAPABILITY.
#
#    6.  CLSFIL IS SIMILAR TO OPNFIL; IT IS CALLED WHENEVER A FILE IS
#    CLOSED.  SEE RATIO.RAT FOR DETAILS.  THE IMPORTANT EFFECT OF
#    CLOSING A FILE IS THAT IT MUST BE POSSIBLE TO RE-OPEN IT AND READ
#    IT FROM THE BEGINNING.  THIS IS NECESSARY, FOR EXAMPLE, TO INCLUDE
#    LABELED COMMONS IN SEVERAL PLACES.
#
#    AFTER THESE MODIFICATIONS HAVE BEEN MADE, MBOOT CAN BE COMPILED.
#    RATFOR SOURCE IS READ FROM STANDARD INPUT AND THE GENERATED
#    FORTRAN IS WRITTEN TO STANDARD OUTPUT; ERRORS ARE WRITTEN TO ERROR
#    OUTPUT.  THE PREPROCESSOR DOES NOT PRODUCE A LISTING.  IN A BATCH
#    ENVIRONMENT, THE USUAL APPROACH IS TO USE A LOCAL UTILITY TO
#    PRODUCE A SOURCE LISTING ON THE PRINTER AND THEN ARRANGE THAT THE
#    ERROR OUTPUT IS ALSO DIRECTED TO THE PRINTER.  RATFOR ERROR
#    MESSAGES ARE KEYED TO LINE NUMBERS; IT IS CONVENIENT IF THE
#    LISTING INCLUDES LINE NUMBERS IN INCREMENTS OF ONE.  IN A
#    TIMESHARING ENVIRONMENT, THE LISTING IS USUALLY USELESS.
#
#    AT THIS POINT, MBOOT CAN SERVE AS VERSION 0 RATFOR.
#
#    TEST VERSION 0 WITH SEVERAL SMALL TEST PROGRAMS; MAIN.RAT IS A
#    GOOD TEST AS ARE SOME OF THE SHORTER PROGRAMS IN SOFTWARE TOOLS.
#    AFTER IT CAN CORRECTLY PROCESS SMALL TEST PROGRAMS, RATIO.RAT AND
#    THE APPROPRIATE INCLUDE FILES (RATDEF AND CRATIO) CAN BE USED AS A
#    TEST.  THIS WILL TEST THE INCLUDE FACILITY, WHICH WILL TEST OPNFIL
#    AND CLSFIL.
#
#    ALL OF THE MODIFICATIONS MADE TO MBOOT SHOULD ALSO BE APPLIED TO
#    THE RATFOR.RAT, RATIO.RAT, AND MAIN.RAT SO THEY STAY "IN PHASE"
#    WITH MBOOT.  DO NOT DISCARD THE FIRST RUNNING VERSION OF MBOOT; IT
#    IS EASY TO ACCIDENTLY DELETE MBOOT AND BE LEFT STRANDED WITH ONLY
#    THE RATFOR SOURCE CODE.
#
#    AS MENTIONED ABOVE, THE BEST WAY TO IMPROVE THE PERFORMANCE OF
#    RATFOR IS TO MAKE THE I/O MORE EFFICIENT.  OTHER INEFFICIENCIES
#    ARE INSIGNIFICANT WHEN COMPARED TO THE I/O PROCESSING, WHICH
#    ACCOUNTS FOR OVER 50% OF THE PROCESSING TIME.
#
#    ALTHOUGH RATIO.RAT IS TOO SLOW FOR PRODUCTION USE, THERE SEVERAL
#    IMPROVEMENTS CAN BE MADE THAT WILL MAKE IT SUITABLE FOR CASUAL
#    USE.
#
#    1.  THE TRANSLATION FROM THE HOST CHARACTER SET TO ASCII AND
#    VICE-VERSA IS PERFORMED BY THE FUNCTIONS INMAP AND OUTMAP,
#    RESPECTIVELY.  THE TRANSLATION IS ACCOMPLISHED BY SEARCHING EITHER
#    INTCHR OR EXTCHR FOR THE APPROPRIATE CHARACTER AND RETURNING THE
#    CORRESPONDING VALUE IN THE OTHER ARRAY.  THESE FUNCTIONS SHOULD BE
#    REPLACED BY ARRAYS THAT SIMPLY USE THE VALUE OF THE CHARACTER PLUS
#    ONE AS AN INDEX, E.G. OUTMAP(BLANK+1) SHOULD BE INITIALIZED TO THE
#    HOST CHARACTER CODE FOR A BLANK.  AS AN EXAMPLE, EBCDIC.RAT
#    CONTAINS AN ASCII-EBCDIC AND EBCDIC-ASCII TRANSLATION TABLE.  THIS
#    MODIFICATION ALSO REQUIRES THAT RDLIN AND WRLIN BE CHANGED TO
#    HANDLE RIGHT-JUSTIFIED CHARACTERS INSTEAD OF THE A1 FORMAT
#    CURRENTLY USED.  SOME FORTRAN IMPLEMENTATIONS HAVE A R1 FORMAT FOR
#    THIS PURPOSE; A SIMPLE SHIFT FUNCTION CAN ALSO BE USED.  IF THIS
#    CHANGE IS MADE, THE ARRAYS INTCHR AND EXTCHR ARE NO LONGER
#    NEEDED.
#
#    2.  IN RATIO.RAT, CREATE AND OPEN ARE EQUIVALENT.  CREATE SHOULD
#    BE MODIFIED TO DO WHATEVER IS MOST APPROPRIATE IN THE LOCAL
#    ENVIRONMENT.  A TYPICAL SCHEME IS TO CREATE AN EMPTY FILE AND THEN
#    CALL OPEN TO OPEN IT ACCORDING TO MODE.  READING AN EMPTY FILE IS
#    NOT UNUSUAL.
#
#    IF RATFOR AND THE PROGRAMS IN SOFTWARE TOOLS ARE TO BE USED
#    HEAVILY, IT IS WORTH THE EFFORT TO IMPLEMENT A SYSTEM-SPECIFIC I/O
#    SYSTEM.  THE FOLLOWING SUGGESTIONS ARE BASED ON EXPERIENCE WITH
#    I/O SYSTEMS FOR THE DEC-10, PDP-11/70, ECLIPSE, AND THE CDC CYBER
#    175.
#
#    1.  OPEN, CREATE, AND CLOSE DO NOT HAVE TO BE EFFICIENT; GETCH AND
#    PUTCH DO.  IF IT IS EASY TO MIX FORTRAN AND ASSEMBLY LANGUAGE
#    SUBROUTINES AND FUNCTIONS, IMPLEMENT GETCH AND PUTCH IN ASSEMBLY
#    LANGUAGE AND THE REST IN RATFOR.
#
#    2.  ANOTHER PRIMITIVE DESCRIBED IN SOFTWARE TOOLS IS SEEK(N,FD),
#    WHICH "POSITIONS" THE FILE OPENED ON FD SO THAT THE NEXT READ OR
#    WRITE WILL ACCESS THE NTH CHARACTER.  THIS PRIMITIVE IS
#    ESSENTIALLY IMPOSSIBLE TO IMPLEMENT ON SOME SYSTEMS IN ANY
#    EFFICIENT MANNER.  IT ALSO SEEMS TO HAVE AN ENORMOUS INFLUENCE ON
#    THE IMPLEMENTATION OF THE REST OF THE PRIMITIVES.  IF SEEK IS TO
#    BE IMPLEMENTED, ITS INFLUENCE SHOULD BE CONSIDERED FROM THE
#    ONSET.
#
#    3.  GETCH AND PUTCH READ AND WRITE SINGLE CHARACTERS.  THEY ARE
#    SPECIAL CASES OF MORE PRIMITIVE OPERATIONS.  IN THE DEC-10 AND CDC
#    CYBER SYSTEMS, THE BASIC I/O PRIMITIVES ARE
#
#       COUNT = READF(BUF, COUNT, FD)
#
#    AND
#
#       COUNT = WRITEF(BUF, COUNT, FD)
#
#    READF READS AT MOST COUNT CHARACTERS FROM FD INTO BUF AND RETURNS
#    THE NUMBER OF CHARACTERS ACTUALLY READ, WHICH MIGHT BE LESS THAN
#    THE NUMBER REQUESTED.  READF RETURNS EOF AT END OF FILE.  WRITEF
#    WRITES COUNT CHARACTERS FROM BUF TO FILE FD AND RETURNS THE NUMBER
#    ACTUALLY WRITTEN (THIS IS ALMOST ALWAYS COUNT; THE FORM OF THE
#    CALL WAS CHOSEN TO BE SIMILAR TO READF).  IN BOTH PRIMITIVES, BUF
#    HOLDS ONE RIGHT-JUSTIFIED CHARACTER PER WORD.
#
#    4.  IT IS WORTH THE EFFORT TO MAKE OPEN AND CREATE ACCEPT THE MOST
#    GENERAL FILE NAME SPECIFICATION USED IN THE LOCAL INSTALLATION.
#    THIS WILL INSURE THAT PROGRAMS CAN ACCEPT FILE NAMES FROM COMMANDS
#    AND CALL OPEN OR CREATE WITHOUT HAVING TO EXAMINE THE ACTUAL
#    NAME.  IF SEVERAL FILE FORMATS ARE AVAILABLE, IT APPEARS BEST TO
#    ADD ADDITIONAL SYNTAX TO FILE NAMES TO INDICATE FILE FORMATS ETC.
#    FOR EXAMPLE, ON THE CDC CYBER 175, A /A APPENDED TO A FILE NAME
#    INDICATES THAT THE FILE IS 12-BIT ASCII.  THE POINT HERE IS THAT
#    ALL OF THE SYSTEM-DEPENDENT INFORMATION SHOULD BE PASSED IN THE
#    NAME SO THAT PROGRAMS DO NOT HAVE SYSTEM-DEPENDENCIES BUILT INTO
#    THEM; MAKE THE I/O SYSTEM HANDLE SUCH IDIOSYNCRACIES.
#
#    5.  IF ADDITIONAL INFORMATION IS REQUIRED BY OPEN AND CREATE, ADD
#    OPTIONS TO THE SECOND ARGUMENT; DO NOT ADD MORE ARGUMENTS.  FOR
#    EXAMPLE, ON THE DEC-10 AND CDC CYBER 175 I/O SYSTEMS, THE MODE IS
#    REALLY
#
#       BYTESIZE*8 + MODE
#
#    IF BYTESIZE IS OMITTED, IT DEFAULTS TO THE CORRECT SIZE FOR
#    CHARACTERS.
#
#    6.  IT IS CONVENIENT IF OPEN AND CREATE ACCEPT EITHER AN UNPACKED
#    ASCII NAME OR A PACKED NAME IN THE HOST CHARACTER SET.
#
#    7.  THE PRIMITIVES GETLIN AND PUTLIN, DESCRIBED IN SOFTWARE TOOLS,
#    CAN BE IMPLEMENTED IN TERMS OF GETCH AND PUTCH (OR READF AND
#    WRITEF).  IT MAY BE NECESSARY, HOWEVER, TO WRITE THESE ROUTINES IN
#    ASSEMBLY LANGUAGE IF THE BASIC UNIT OF INFORMATION IN FILES IS THE
#    LINE OR RECORD.
#
#    8.  AS MENTIONED ABOVE, THE "STANDARD" FILES ARE ASSUMED TO BE
#    OPENED WHEN PROGRAM EXECUTION BEGINS.  TRY TO ARRANGE THIS WITHOUT
#    REQUIRING ANYTHING EXPLICIT IN THE MAIN PROGRAM.  IF THIS IS NOT
#    POSSIBLE, ANOTHER APPROACH IS TO MAKE ALL RATFOR PROGRAMS
#    SUBROUTINES WITH THE "MAIN PROGRAM" AS A SUBROUTINE NAMED MAIN.
#    SUPPLY A STANDARD MAIN PROGRAM WHOSE SOLE PURPOSE IS TO OPEN THE
#    STANDARD FILES, GET ARGUMENTS IF PRESENT, AND CALL MAIN.
#
#    9.  SOME ASCII-BASED SYSTEMS (SUCH AS THE DEC-10) INSIST ON USING
#    A TWO-CHARACTER SEQUENCE TO TERMINATE A LINE; A CARRIAGE RETURN
#    AND A LINEFEED IS TYPICAL.  RATFOR PROGRAMS EXPECT A SINGLE
#    CHARACTER TO INDICATE THE END OF A LINE.  ALTHOUGH IT IS POSSIBLE
#    TO RECOGNIZE THE TWO-CHARACTER SEQUENCE AND RETURN A SINGLE
#    CHARACTER, THE SIMPLER SOLUTION IS TO IGNORE ONE OF THE CHARACTERS
#    COMPLETELY AND RETURN THE OTHER AS THE NEWLINE CHARACTER.  THE
#    IGNORED CHARACTER IS RESTORED WHENEVER A NEWLINE IS OUTPUT.  FOR
#    EXAMPLE, ON THE DEC-10 CARRIAGE RETURNS ARE IGNORED AND LINEFEEDS
#    ARE TREATED AS NEWLINE CHARACTERS.  PUTCH OUTPUTS A CARRIAGE
#    RETURN WHENEVER A LINEFEED IS OUTPUT.  OF COURSE, THIS CONVENTION
#    MEANS THAT "BARE" CARRIAGE RETURNS ARE LOST AND BARE LINEFEEDS
#    SIGNAL A LINE BOUNDARY.  THIS RESTRICTION HAS CAUSED FEW PROBLEMS
#    IN PRACTICE, HOWEVER.
#
#    10.  SOME INSTALLATIONS FIND IT NECESSARY TO PERFORM ADDITIONAL
#    PROCESSING ON THE INPUT OR OUTPUT OF RATFOR.  IF THIS IS
#    NECESSARY, MODIFY THE ROUTINES NGETCH AND OUTDON (FOR INPUT AND
#    OUTPUT, RESPECTIVELY).  ONE WAY TO DO THIS MODIFICATION IS TO
#    WRITE AN EDIT SCRIPT (SEE SOFTWARE TOOLS) THAT, WHEN APPLIED TO
#    RATFOR.RAT, PERFORMS THE APPROPRIATE CHANGES.  IF THE SCRIPT USES
#    ONLY CONTEXT EDITING COMMANDS (SEARCHES, ETC.), IT IS LIKELY THAT
#    IT CAN BE APPLIED TO SUBSEQUENT VERSIONS OF RATFOR WITHOUT
#    MODIFICATION.
#
#-H- RATDEF 2690 1980 103 2140
#========== STANDARD RATFOR DEFINITIONS ==========
 
DEFINE(ACCENT,96)
DEFINE(ALPHA,10100)
DEFINE(AND,38)
DEFINE(ANDIF,IF)
DEFINE(ARB,100)
DEFINE(ATSIGN,64)
DEFINE(BACKSLASH,92)
DEFINE(BACKSPACE,8)
DEFINE(BANG,33)
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(BLANK,32)
DEFINE(CARET,94)
DEFINE(COLON,58)
DEFINE(COMMA,44)
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(DIGIT,2)
DEFINE(DOLLAR,36)
DEFINE(DQUOTE,34)
DEFINE(EOF,10003)
DEFINE(EOS,10002)
DEFINE(EQUALS,61)
DEFINE(ERR,10001)
DEFINE(ERROUT,2)
DEFINE(GREATER,62)
DEFINE(HUGE,30000)
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(LETTER,1)
DEFINE(LETU,117)
DEFINE(LETV,118)
DEFINE(LETW,119)
DEFINE(LETX,120)
DEFINE(LETY,121)
DEFINE(LETZ,122)
DEFINE(LPAREN,40)
DEFINE(MAXCHARS,20)
DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH
DEFINE(MAXNAME,30)   %# TYPICAL FILE NAME SIZE
DEFINE(MINUS,45)
DEFINE(NEWLINE,10)
DEFINE(NO,0)
DEFINE(NOERR,0)
DEFINE(NOT,126)   # SAME AS TILDE
DEFINE(OK,-2)
DEFINE(OR,BAR)   # SAME AS BAR
DEFINE(PERCENT,37)
DEFINE(PERIOD,46)
DEFINE(PLUS,43)
DEFINE(QMARK,63)
DEFINE(RBRACE,125)
DEFINE(RBRACK,93)
DEFINE(READ,0)
DEFINE(READWRITE,2)
DEFINE(RPAREN,41)
DEFINE(SEMICOL,59)
DEFINE(SHARP,35)
DEFINE(SLASH,47)
DEFINE(SQUOTE,39)
DEFINE(STAR,42)
DEFINE(STDIN,0)
DEFINE(STDOUT,1)
DEFINE(STDERR,ERROUT)
DEFINE(TAB,9)
DEFINE(TILDE,126)
DEFINE(UNDERLINE,95)
DEFINE(WRITE,1)
DEFINE(YES,1)
DEFINE(ESCAPE,ATSIGN)
DEFINE(CHARACTER,INTEGER)
DEFINE(ABS,IABS)
DEFINE(MIN,MIN0)
DEFINE(MAX,MAX0)
 
# HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE
DEFINE(BPI,36)%%# BITS PER INTEGER
DEFINE(BPC,7)%%# BITS PER CHARACTER
DEFINE(CPI,5)%%# CHARACTERS PER INTEGER
DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER
DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN)
DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN)
DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL
#-H- CFNAME 87 1980 103 2140
 
COMMON /CFNAME/ FCNAME(MAXNAME)
   CHARACTER FCNAME   # TEXT OF CURRENT FUNCTION NAME
#-H- CFOR 144 1980 103 2140
 
COMMON /CFOR/ FORDEP, FORSTK(MAXFORSTK)
   INTEGER FORDEP   # CURRENT DEPTH OF FOR STATEMENTS
   CHARACTER FORSTK   # STACK OF REINIT STRINGS
#-H- CGOTO 84 1980 103 2140
 
COMMON /CGOTO/ XFER
   INTEGER XFER      # YES IF JUST MADE TRANSFER, NO OTHERWISE
#-H- CLABEL 75 1980 103 2140
 
COMMON /CLABEL/ LABEL
   INTEGER LABEL    # NEXT LABEL RETURNED BY LABGEN
#-H- CLINE 392 1980 103 2140
 
COMMON /CLINE/ LEVEL, LINECT(NFILES), INFILE(NFILES),
   FNAMP, FNAMES(MAXFNAMES)
   INTEGER LEVEL   # LEVEL OF FILE INCLUSION; INIT = 1
   INTEGER LINECT   # LINE COUNT ON INPUT FILE(LEVEL); INIT = 1
   INTEGER INFILE   # FILE NUMBER(LEVEL); INIT INFILE(1) = STDIN
   INTEGER FNAMP    # NEXT FREE SLOT IN FNAMES; INIT = 2
   CHARACTER FNAMES # STACK OF INCLUDE NAMES; INIT FNAMES(1) = EOS
#-H- CLOOK 212 1980 103 2140
 
COMMON /CLOOK/ AVAIL, TABPTR(127), TABLE(MAXTBL)
   INTEGER AVAIL   # FIRST FIRST LOCATION IN TABLE; INIT = 1
   INTEGER TABPTR   # NAME POINTERS; INIT = 0
   CHARACTER TABLE   # ACTUAL TEXT OF NAMES AND DEFNS
#-H- COUTLN 151 1980 103 2140
 
COMMON /COUTLN/ OUTP, OUTBUF(74)
   INTEGER OUTP      # LAST POSITION FILLED IN OUTBUF; INIT = 0
   CHARACTER OUTBUF   # OUTPUT LINES COLLECTED HERE
#-H- CSBUF 151 1980 103 2140
 
COMMON /CSBUF/ SBP, SBUF(SBUFSIZE)
   INTEGER SBP      # NEXT AVAILABLE CHARACTER POSITION; INIT = 1
   CHARACTER SBUF   # SAVED FOR DATA STATEMENTS
#-H- CRATIO 290 1980 103 2140
COMMON /CRATIO/ FDTAB(MAXFILES), FILTAB(FILTABSIZE), EXTCHR(NCHARS),
   INTCHR(NCHARS)
   INTEGER FDTAB%# POINTERS TO FILE BLOCKS
   INTEGER FILTAB%# FILE BLOCKS
   CHARACTER EXTCHR%# EXTERNAL REPRESENTATION OF CHARACTERS
   CHARACTER INTCHR%# INTERNAL (ASCII) REPRESENTATION OF CHARACTERS
#-H- RATIO.RAT 12226 1980 103 2140
# MACHINE-INDEPENDENT RATFOR I/O SYSTEM IN RATFOR
 
INCLUDE RATDEF
DEFINE(MAXFILES,8)      # NUMBER OF OPENED FILES PERMITTED
DEFINE(MAXLINE,80)      # MAXIMUM LINE SIZE ON INPUT
DEFINE(MAXBUF,132)      # MAXIMUM LINE SIZE ON OUTPUT
DEFINE(NCHARS,96)       # NUMBER OF CHARACTERS IN CHARACTER MAP
 
# FILE BLOCK FORMAT
DEFINE(USECNT,0)        # USE COUNT
DEFINE(MODE,1)          # OPEN MODE
DEFINE(EOFFLG,2)        # YES, IF AT END OF FILE
DEFINE(UNIT,3)          # FORTRAN UNIT NUMBER
DEFINE(LASTC,4)         # LAST CHARACTER GET/PUT IN BUFFER
DEFINE(BUF,5)           # START OF LINE BUFFER
DEFINE(FBLEN,140)       # SIZE OF FILE BLOCK;
                        # 7 + MAX(MAXLINE, MAXBUF)
DEFINE(FILTABSIZE,1120) # MUST BE MAXFILES*FBLEN
 
# BLOCK DATA
   BLOCK DATA
   INCLUDE CRATIO
 
   # THESE INITIALIZATIONS MUST BE CHANGED IF DEFINITIONS ARE CHANGED
   # INITIAL ASSIGNMENTS FOR DESCRIPTORS 0, 1, AND 2 REFLECT
   # ASSIGNMENTS OF STANDARD INPUT, OUTPUT, AND ERROR OUTPUT.
   DATA FDTAB(1) /1/
   DATA FILTAB(1), FILTAB(2), FILTAB(3), FILTAB(4), FILTAB(5)/_
      1, READ, NO, 5, 0/
   DATA FDTAB(2) /141/
   DATA FILTAB(141), FILTAB(142), FILTAB(143), FILTAB(144), FILTAB(145)/_
      1, WRITE, NO, 6, 146/
   DATA FDTAB(3) /281/
   DATA FILTAB(281), FILTAB(282), FILTAB(283), FILTAB(284), FILTAB(285)/_
      1, WRITE, NO, 6, 286/
   DATA FDTAB(4) /0/
   DATA FILTAB(421) /0/
   DATA FDTAB(5) /0/
   DATA FILTAB(561) /0/
   DATA FDTAB(6) /0/
   DATA FILTAB(701) /0/
   DATA FDTAB(7) /0/
   DATA FILTAB(841) /0/
   DATA FDTAB(8) /0/
   DATA FILTAB(981) /0/
 
   # CHARACTER MAP
   DATA EXTCHR( 1) /' '/, INTCHR( 1) /BLANK/
   DATA EXTCHR( 2) /'0'/, INTCHR( 2) /DIG0/
   DATA EXTCHR( 3) /'1'/, INTCHR( 3) /DIG1/
   DATA EXTCHR( 4) /'2'/, INTCHR( 4) /DIG2/
   DATA EXTCHR( 5) /'3'/, INTCHR( 5) /DIG3/
   DATA EXTCHR( 6) /'4'/, INTCHR( 6) /DIG4/
   DATA EXTCHR( 7) /'5'/, INTCHR( 7) /DIG5/
   DATA EXTCHR( 8) /'6'/, INTCHR( 8) /DIG6/
   DATA EXTCHR( 9) /'7'/, INTCHR( 9) /DIG7/
   DATA EXTCHR(10) /'8'/, INTCHR(10) /DIG8/
   DATA EXTCHR(11) /'9'/, INTCHR(11) /DIG9/
   DATA EXTCHR(12) /'A'/, INTCHR(12) /LETA/
   DATA EXTCHR(13) /'B'/, INTCHR(13) /LETB/
   DATA EXTCHR(14) /'C'/, INTCHR(14) /LETC/
   DATA EXTCHR(15) /'D'/, INTCHR(15) /LETD/
   DATA EXTCHR(16) /'E'/, INTCHR(16) /LETE/
   DATA EXTCHR(17) /'F'/, INTCHR(17) /LETF/
   DATA EXTCHR(18) /'G'/, INTCHR(18) /LETG/
   DATA EXTCHR(19) /'H'/, INTCHR(19) /LETH/
   DATA EXTCHR(20) /'I'/, INTCHR(20) /LETI/
   DATA EXTCHR(21) /'J'/, INTCHR(21) /LETJ/
   DATA EXTCHR(22) /'K'/, INTCHR(22) /LETK/
   DATA EXTCHR(23) /'L'/, INTCHR(23) /LETL/
   DATA EXTCHR(24) /'M'/, INTCHR(24) /LETM/
   DATA EXTCHR(25) /'N'/, INTCHR(25) /LETN/
   DATA EXTCHR(26) /'O'/, INTCHR(26) /LETO/
   DATA EXTCHR(27) /'P'/, INTCHR(27) /LETP/
   DATA EXTCHR(28) /'Q'/, INTCHR(28) /LETQ/
   DATA EXTCHR(29) /'R'/, INTCHR(29) /LETR/
   DATA EXTCHR(30) /'S'/, INTCHR(30) /LETS/
   DATA EXTCHR(31) /'T'/, INTCHR(31) /LETT/
   DATA EXTCHR(32) /'U'/, INTCHR(32) /LETU/
   DATA EXTCHR(33) /'V'/, INTCHR(33) /LETV/
   DATA EXTCHR(34) /'W'/, INTCHR(34) /LETW/
   DATA EXTCHR(35) /'X'/, INTCHR(35) /LETX/
   DATA EXTCHR(36) /'Y'/, INTCHR(36) /LETY/
   DATA EXTCHR(37) /'Z'/, INTCHR(37) /LETZ/
   DATA EXTCHR(38) /'A'/, INTCHR(38) /BIGA/
   DATA EXTCHR(39) /'B'/, INTCHR(39) /BIGB/
   DATA EXTCHR(40) /'C'/, INTCHR(40) /BIGC/
   DATA EXTCHR(41) /'D'/, INTCHR(41) /BIGD/
   DATA EXTCHR(42) /'E'/, INTCHR(42) /BIGE/
   DATA EXTCHR(43) /'F'/, INTCHR(43) /BIGF/
   DATA EXTCHR(44) /'G'/, INTCHR(44) /BIGG/
   DATA EXTCHR(45) /'H'/, INTCHR(45) /BIGH/
   DATA EXTCHR(46) /'I'/, INTCHR(46) /BIGI/
   DATA EXTCHR(47) /'J'/, INTCHR(47) /BIGJ/
   DATA EXTCHR(48) /'K'/, INTCHR(48) /BIGK/
   DATA EXTCHR(49) /'L'/, INTCHR(49) /BIGL/
   DATA EXTCHR(50) /'M'/, INTCHR(50) /BIGM/
   DATA EXTCHR(51) /'N'/, INTCHR(51) /BIGN/
   DATA EXTCHR(52) /'O'/, INTCHR(52) /BIGO/
   DATA EXTCHR(53) /'P'/, INTCHR(53) /BIGP/
   DATA EXTCHR(54) /'Q'/, INTCHR(54) /BIGQ/
   DATA EXTCHR(55) /'R'/, INTCHR(55) /BIGR/
   DATA EXTCHR(56) /'S'/, INTCHR(56) /BIGS/
   DATA EXTCHR(57) /'T'/, INTCHR(57) /BIGT/
   DATA EXTCHR(58) /'U'/, INTCHR(58) /BIGU/
   DATA EXTCHR(59) /'V'/, INTCHR(59) /BIGV/
   DATA EXTCHR(60) /'W'/, INTCHR(60) /BIGW/
   DATA EXTCHR(61) /'X'/, INTCHR(61) /BIGX/
   DATA EXTCHR(62) /'Y'/, INTCHR(62) /BIGY/
   DATA EXTCHR(63) /'Z'/, INTCHR(63) /BIGZ/
   DATA EXTCHR(64) /'!'/, INTCHR(64) /BANG/
   DATA EXTCHR(65) /'"'/, INTCHR(65) /DQUOTE/
   DATA EXTCHR(66) /"#"/, INTCHR(66) /SHARP/
   DATA EXTCHR(67) /'$'/, INTCHR(67) /DOLLAR/
   DATA EXTCHR(68) /'%'/, INTCHR(68) /PERCENT/
   DATA EXTCHR(69) /'&'/, INTCHR(69) /AND/
   DATA EXTCHR(70) /"'"/, INTCHR(70) /SQUOTE/
   DATA EXTCHR(71) /'('/, INTCHR(71) /LPAREN/
   DATA EXTCHR(72) /')'/, INTCHR(72) /RPAREN/
   DATA EXTCHR(73) /'*'/, INTCHR(73) /STAR/
   DATA EXTCHR(74) /'+'/, INTCHR(74) /PLUS/
   DATA EXTCHR(75) /','/, INTCHR(75) /COMMA/
   DATA EXTCHR(76) /'-'/, INTCHR(76) /MINUS/
   DATA EXTCHR(77) /'.'/, INTCHR(77) /PERIOD/
   DATA EXTCHR(78) /'/'/, INTCHR(78) /SLASH/
   DATA EXTCHR(79) /':'/, INTCHR(79) /COLON/
   DATA EXTCHR(80) /';'/, INTCHR(80) /SEMICOL/
   DATA EXTCHR(81) /'<'/, INTCHR(81) /LESS/
   DATA EXTCHR(82) /'='/, INTCHR(82) /EQUALS/
   DATA EXTCHR(83) /'>'/, INTCHR(83) /GREATER/
   DATA EXTCHR(84) /'?'/, INTCHR(84) /QMARK/
   DATA EXTCHR(85) /'@'/, INTCHR(85) /ATSIGN/
   DATA EXTCHR(86) /'['/, INTCHR(86) /LBRACK/
   DATA EXTCHR(87) /'\'/, INTCHR(87) /BACKSLASH/
   DATA EXTCHR(88) /']'/, INTCHR(88) /RBRACK/
   DATA EXTCHR(89) /'_'/, INTCHR(89) /UNDERLINE/
   DATA EXTCHR(90) /'<'/, INTCHR(90) /LBRACE/
   DATA EXTCHR(91) /'\'/, INTCHR(91) /BAR/
   DATA EXTCHR(92) /'!'/, INTCHR(92) /RBRACE/
   DATA EXTCHR(93) /'6'/, INTCHR(93) /BACKSPACE/
   DATA EXTCHR(94) /'%'/, INTCHR(94) /TAB/
   DATA EXTCHR(95) /'^'/, INTCHR(95) /CARET/
   DATA EXTCHR(96) /'^'/, INTCHR(96) /TILDE/
   # NCHARS IS LAST SUBSCRIPT IN THESE ARRAYS
   END
# CLOSE - CLOSE FILE ON FD
   SUBROUTINE CLOSE(FD)
   INTEGER FD
   INTEGER I, K
   INTEGER WRLIN, OUTMAP
   INCLUDE CRATIO
 
   I = FDTAB(FD+1)
   IF (I == 0)
      RETURN    # ALLOW CLOSE OF UNOPENED FILE
   FILTAB(I+USECNT) = FILTAB(I+USECNT) - 1
   IF (FILTAB(I+USECNT) <= 0) <
      IF (FILTAB(I+MODE) == WRITE & FILTAB(I+LASTC) > I + BUF) <
         K = FILTAB(I+LASTC)
         FOR (J = I + BUF; J < K; J = J + 1)
            FILTAB(J) = OUTMAP(FILTAB(J))
         K = WRLIN(FILTAB(I+BUF), K - (I + BUF), FILTAB(I+UNIT))
         FILTAB(I+LASTC) = I + BUF
         !
      CALL CLSFIL(FILTAB(I+UNIT), FILTAB(I+MODE))
      !
   FDTAB(FD+1) = 0      # FREE SLOT
   RETURN
   END
# CLSFIL - DO ACTUAL CLOSE OF FILE OPENED ON UNIT IN MODE MD
   SUBROUTINE CLSFIL(UNIT, MD)
   INTEGER UNIT, MD
 
   REWIND UNIT
   RETURN
   END
# CREATE - CREATE FILE NAME AND OPEN IN MODE MD
   INTEGER FUNCTION CREATE(NAME, MD)
   CHARACTER NAME(MAXNAME)
   INTEGER MD
   INTEGER OPEN
 
   CREATE = OPEN(NAME, MD)
   RETURN
   END
# DUP - DUPLICATE FILE DESCRIPTOR FD
   INTEGER FUNCTION DUP(FD)
   INTEGER FD
   INTEGER I
   INCLUDE CRATIO
 
   FOR (DUP = 0; DUP < MAXFILES; DUP = DUP + 1) # FIND A FREE DESCRIPTOR
      IF (FDTAB(DUP+1) == 0)
         BREAK
   IF (DUP >= MAXFILES)
      DUP = ERR
   ELSE <
      FDTAB(DUP+1) = FDTAB(FD+1)        # POINT TO SAME FILE BLOCK
      I = FDTAB(DUP+1)
      FILTAB(I+USECNT) = FILTAB(I+USECNT) + 1   # BUMP REFERENCE COUNT
      !
   RETURN
   END
# ERROR - ISSUE FATAL ERROR
   SUBROUTINE ERROR(MSG)
   INTEGER MSG(MAXLINE)
 
   CALL REMARK(MSG)
   CALL EXIT
   RETURN
   END
# EXIT - CLOSE ALL OPEN FILES AND STOP
   SUBROUTINE EXIT
   INTEGER FD
 
   FOR (FD = 0; FD < MAXFILES; FD = FD + 1)
      CALL CLOSE(FD)
   STOP
   RETURN
   END
# GETCH - GET NEXT CHARACTER FROM FILE FD INTO C
   CHARACTER FUNCTION GETCH(C, FD)
   CHARACTER C
   CHARACTER INMAP
   INTEGER FD, I, J, K, N
   INTEGER RDLIN
   INCLUDE CRATIO
 
   I = FDTAB(FD+1)
   IF (FILTAB(I+MODE) ^= READ)
      CALL ERROR(" INPUT ERROR: FILE NOT OPENED FOR READING.")
   IF (FILTAB(I+EOFFLG) == YES)
      GO TO 10
   K = FILTAB(I+LASTC)
   IF (K == 0) <                # READ NEXT LINE
      N = FILTAB(I+UNIT)
      K = RDLIN(FILTAB(I+BUF), N)
      IF (K == EOF)
         GO TO 10
      ELSE IF (K == ERR)
         CALL ERROR(" INPUT ERROR.")
      J = I + BUF + K
      FILTAB(J) = NEWLINE
      FOR (J = I + BUF; K > 0; J = J + 1) <     # TRANSLATE TO ASCII
         FILTAB(J) = INMAP(FILTAB(J))
         K = K - 1
         !
      K = I + BUF       # RESET READ POINTER
      FILTAB(I+LASTC) = K
      !
   C = FILTAB(K)
   GETCH = C
   IF (C == NEWLINE)
      FILTAB(I+LASTC) = 0       # CAUSES READ ON NEXT GETCH
   ELSE
      FILTAB(I+LASTC) = K + 1
   RETURN
   10   # HERE ON END OF FILE
      FILTAB(I+EOFFLG) = YES
      C = EOF
      GETCH = EOF
      RETURN
   END
# INMAP - CONVERT LEFT ADJUSTED EXTERNAL REP TO RIGHT ADJ ASCII
   INTEGER FUNCTION INMAP(C)
   CHARACTER C
   INTEGER I
   INCLUDE CRATIO
 
   DO I = 1, NCHARS
      IF (C == EXTCHR(I)) <
         INMAP = INTCHR(I)
         RETURN
         !
   INMAP = C
   RETURN
   END
# OPEN - OPEN FILE NAME ACCORDING TO MODE MD, RETURN DESCRIPTOR
   INTEGER FUNCTION OPEN(NAME, MD)
   CHARACTER NAME(MAXNAME)
   INTEGER MD
   INTEGER FD, I
   INTEGER OPNFIL
   INCLUDE CRATIO
 
   OPEN = ERR
   FOR (FD = 0; FD < MAXFILES; FD = FD + 1)  # FIND A DESCRIPTOR
      IF (FDTAB(FD+1) == 0)
         BREAK
   IF (FD >= MAXFILES)
      RETURN
   FOR (I = 1; I < FBLEN*MAXFILES; I = I + FBLEN)   # FIND A FILE BLOCK
      IF (FILTAB(I+USECNT) == 0)
         BREAK
   IF (I >= FBLEN*MAXFILES)
      RETURN
   FILTAB(I+UNIT) = OPNFIL(NAME, MD, FD)        # DO ACTUAL OPEN
   IF (FILTAB(I+UNIT) == ERR)
      RETURN
   FILTAB(I+USECNT) = 1         # INITIALIZE FILE BLOCK
   FILTAB(I+MODE) = MD
   FILTAB(I+EOFFLG) = NO
   IF (MD == READ)
      FILTAB(I+LASTC) = 0
   ELSE
         FILTAB(I+LASTC) = I + BUF
   FDTAB(FD+1) = I   # CONNECT FILE DESCRIPTOR TO FILE BLOCK
   OPEN = FD
   RETURN
   END
# OPNFIL - DO ACTUAL OPEN OF FILE NAME IN MODE; FD IS DESCRIPTOR
   INTEGER FUNCTION OPNFIL(NAME, MODE, FD)
   CHARACTER NAME(MAXNAME)
   INTEGER MODE, FD
   INTEGER I
   INTEGER CTOI
 
   I = 1
   RETURN (CTOI(NAME, I))
   END
# OUTMAP - CONVERT RIGHT ADJ ASCII TO LEFT ADJUSTED EXTERNAL REP
   INTEGER FUNCTION OUTMAP(C)
   CHARACTER C
   INTEGER I
   INCLUDE CRATIO
 
   DO I = 1, NCHARS
      IF (C == INTCHR(I)) <
         OUTMAP = EXTCHR(I)
         RETURN
         !
   OUTMAP = C
   RETURN
   END
# PUTCH - PUT CHARACTER C TO FILE FD
   SUBROUTINE PUTCH(C, FD)
   CHARACTER C
   INTEGER FD
   INTEGER I, J, K
   INTEGER OUTMAP, WRLIN
   INCLUDE CRATIO
 
   I = FDTAB(FD+1)
   IF (FILTAB(I+MODE) ^= WRITE)
      CALL ERROR(" OUTPUT ERROR: FILE NOT OPENED FOR WRITING.")
   K = FILTAB(I+LASTC)
   IF (C == NEWLINE \ K > I + BUF + MAXBUF - 1) < # WRITE A LINE
      FOR (J = I + BUF; J < K; J = J + 1)
         FILTAB(J) = OUTMAP(FILTAB(J))
      IF (WRLIN(FILTAB(I+BUF), K - (I + BUF), FILTAB(I+UNIT)) == ERR)
         CALL ERROR(" OUTPUT ERROR.")
      FILTAB(I+LASTC) = I + BUF
      !
   ELSE <
      FILTAB(K) = C
      FILTAB(I+LASTC) = K + 1
      !
   RETURN
   END
# RDLIN - READ A LINE IN A1 FORMAT INTO BUF FROM UNIT N
   INTEGER FUNCTION RDLIN(BUF, N)
   INTEGER BUF(MAXLINE), N
   INTEGER EXTBLK
   INTEGER I
   DATA EXTBLK /" "/
 
   READ(N, 100, END=10) BUF
   100 FORMAT(MAXLINE A1)
   FOR (RDLIN = MAXLINE; RDLIN > 0; RDLIN = RDLIN - 1)
      IF (BUF(RDLIN) ^= EXTBLK)
         BREAK
   RETURN
   10 RDLIN = EOF
      RETURN
   END
# REMARK - PRINT WARNING MESSAGE
   SUBROUTINE REMARK(BUF)
   INTEGER BUF(MAXBUF)
   INTEGER I, N
   INCLUDE CRATIO
 
   I = ERROUT
   I = FDTAB(I+1)
   N = FILTAB(I+UNIT)
   WRITE(N, 10) (BUF(I), I = 1, 10)
      10 FORMAT(10A CPI)    # FIX FOR YOUR MACHINE
   RETURN
   END
# REMOVE - REMOVE FILE NAME
   SUBROUTINE REMOVE(NAME)
   CHARACTER NAME(MAXNAME)
 
   RETURN
   END
# WRLIN - WRITE A K-CHARACTER LINE IN A1 FORMAT FROM BUF TO FORTRAN UNIT N
   INTEGER FUNCTION WRLIN(BUF, K, N)
   INTEGER BUF(MAXBUF), K, N
   INTEGER I
 
   IF (K > 0) <
      WRITE(N, 100) (BUF(I), I = 1, K)
      100 FORMAT(MAXBUF A1)
      !
   ELSE <
      WRITE(N, 200)
      200 FORMAT(/)
      !
   WRLIN = 0
   RETURN
   END
#-H- MAIN.RAT 68 1980 103 2140
# MAIN PROGRAM FOR RATFOR
   CALL PARSE
   CALL EXIT
   STOP
   END
#-H- RATFOR.RAT 35214 1980 103 2140
# RATFOR IN RATFOR
 
INCLUDE RATDEF
DEFINE(ALPHA,10100)
DEFINE(RADIX,PERCENT)  # % INDICATES ALTERNATE RADIX
DEFINE(BUFSIZE,300)   # PUSHBACK BUFFER FOR NGETCH AND PUTBAK
DEFINE(SBUFSIZE,500)  # BUFFER FOR STRING STATEMENTS
DEFINE(DEFTYPE,10010)
DEFINE(DIGIT,2)
DEFINE(LEXBREAK,10264)
DEFINE(LEXDIGITS,10260)
DEFINE(LEXDO,10266)
DEFINE(LEXELSE,10262)
DEFINE(LEXFOR,10268)
DEFINE(LEXIF,10261)
DEFINE(LEXNEXT,10265)
DEFINE(LEXOTHER,10267)
DEFINE(LEXREPEAT,10269)
DEFINE(LEXUNTIL,10270)
DEFINE(LEXWHILE,10263)
DEFINE(LEXRETURN,10271)
DEFINE(LEXEND,10272)
DEFINE(LEXSTOP,10273)
DEFINE(LEXSTRING,10274)
DEFINE(MAXCHARS,10)   # CHARACTERS FOR OUTNUM
DEFINE(MAXDEF,200)   # MAX CHARS IN A DEFN
DEFINE(MAXFORSTK,200)   # MAX SPACE FOR FOR REINIT CLAUSES
DEFINE(MAXFNAMES,150)  # MAX CHARS IN FILE NAME STACK = NFILES*MAXNAME
DEFINE(MAXNAME,30)   # FILE NAME SIZE IN GETTOK
DEFINE(MAXSTACK,100)   # MAX STACK DEPTH FOR PARSER
DEFINE(MAXTBL,7000)   # MAX CHARS IN ALL DEFINITIONS
DEFINE(MAXTOK,200)   # MAX CHARS IN A TOKEN
DEFINE(NFILES,5)   # MAX DEPTH OF FILE INCLUSION
DEFINE(OR,BAR)%# SAME AS \
 
# ADDCHR - PUT C IN BUF(BP) IF IT FITS, INCREMENT BP
   SUBROUTINE ADDCHR(C, BUF, BP, MAXSIZ)
   INTEGER BP, MAXSIZ
   CHARACTER C, BUF(ARB)
 
   IF (BP > MAXSIZ)
      CALL BADERR("BUFFER OVERFLOW.")
   BUF(BP) = C
   BP = BP + 1
   RETURN
   END
# ADDSTR - PUT S IN BUF(BP) BY REPEATED CALLS TO ADDCHR
   SUBROUTINE ADDSTR(S, BUF, BP, MAXSIZ)
   CHARACTER S(ARB), BUF(ARB)
   INTEGER BP, MAXSIZ
   INTEGER I
 
   FOR (I = 1; S(I) ^= EOS; I = I + 1)
      CALL ADDCHR(S(I), BUF, BP, MAXSIZ)
   RETURN
   END
# ALLDIG - RETURN YES IF STR IS ALL DIGITS
   INTEGER FUNCTION ALLDIG(STR)
   CHARACTER TYPE
   CHARACTER STR(ARB)
   INTEGER I
 
   ALLDIG = NO
   IF (STR(1) == EOS)
      RETURN
   FOR (I = 1; STR(I) ^= EOS; I = I + 1)
      IF (TYPE(STR(I)) ^= DIGIT)
         RETURN
   ALLDIG = YES
   RETURN
   END
# BADERR - PRINT ERROR MESSAGE, THEN DIE
   SUBROUTINE BADERR(MSG)
   INTEGER MSG(ARB)
 
   CALL SYNERR(MSG)
   CALL EXIT
   RETURN
   END
# BALPAR - COPY BALANCED PAREN STRING
   SUBROUTINE BALPAR
   CHARACTER GETTOK, GNBTOK
   CHARACTER T, TOKEN(MAXTOK)
   INTEGER NLPAR
 
   IF (GNBTOK(TOKEN, MAXTOK) ^= LPAREN) <
      CALL SYNERR("MISSING LEFT PAREN.")
      RETURN
      !
   CALL OUTSTR(TOKEN)
   NLPAR = 1
   REPEAT <
      T = GETTOK(TOKEN, MAXTOK)
      IF (T==SEMICOL \ T==LBRACE \ T==RBRACE \ T==EOF) <
         CALL PBSTR(TOKEN)
         BREAK
         !
      IF (T == NEWLINE)      # DELETE NEWLINES
         TOKEN(1) = EOS
      ELSE IF (T == LPAREN)
         NLPAR = NLPAR + 1
      ELSE IF (T == RPAREN)
         NLPAR = NLPAR - 1
      # ELSE NOTHING SPECIAL
      CALL OUTSTR(TOKEN)
      ! UNTIL (NLPAR <= 0)
   IF (NLPAR ^= 0)
      CALL SYNERR("MISSING PARENTHESIS IN CONDITION.")
   RETURN
   END
# BRKNXT - GENERATE CODE FOR BREAK N AND NEXT N; N = 1 IS DEFAULT
   SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN)
   INTEGER LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN
   INTEGER I, N, ALLDIG, CTOI
   CHARACTER T, PTOKEN(MAXTOK), GNBTOK
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
 
   N = 0
   T = GNBTOK(PTOKEN, MAXTOK)
   IF (ALLDIG(PTOKEN) == YES) <     # HAVE BREAK N OR NEXT N
      I = 1
      N = CTOI(PTOKEN, I) - 1
      !
   ELSE IF (T ^= SEMICOL)      # DEFAULT CASE
      CALL PBSTR(PTOKEN)
   FOR (I = SP; I > 0; I = I - 1)
      IF (LEXTYP(I) == LEXWHILE \ LEXTYP(I) == LEXDO
        \ LEXTYP(I) == LEXFOR \ LEXTYP(I) == LEXREPEAT) <
         IF (N > 0) <
            N = N - 1
            NEXT             # SEEK PROPER LEVEL
            !
         ELSE IF (TOKEN == LEXBREAK)
            CALL OUTGO(LABVAL(I)+1)
         ELSE
            CALL OUTGO(LABVAL(I))
         XFER = YES
         RETURN
         !
   IF (TOKEN == LEXBREAK)
      CALL SYNERR("ILLEGAL BREAK.")
   ELSE
      CALL SYNERR("ILLEGAL NEXT.")
   RETURN
   END
# CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I
   INTEGER FUNCTION CTOI(IN, I)
   CHARACTER IN(ARB)
   INTEGER I
 
   WHILE (IN(I) == BLANK \ IN(I) == TAB)
      I = I + 1
   FOR (CTOI = 0; IN(I) ^= EOS; I = I + 1) <
      IF (IN(I) < DIG0 \ IN(I) > DIG9)
         BREAK
      CTOI = 10 * CTOI + IN(I) - DIG0
      !
   RETURN
   END
# DEFTOK - GET TOKEN; PROCESS MACRO CALLS AND INVOCATIONS
   CHARACTER FUNCTION DEFTOK(TOKEN, TOKSIZ, FD)
   CHARACTER GTOK
   INTEGER FD, TOKSIZ
   CHARACTER DEFN(MAXDEF), T, TOKEN(MAXTOK)
   INTEGER LOOKUP
 
   FOR (T=GTOK(TOKEN, TOKSIZ, FD); T^=EOF; T=GTOK(TOKEN, TOKSIZ, FD)) <
      IF (T ^= ALPHA)   # NON-ALPHA
         BREAK
      IF (LOOKUP(TOKEN, DEFN) == NO)   # UNDEFINED
         BREAK
      IF (DEFN(1) == DEFTYPE) <   # GET DEFINITION
         CALL GETDEF(TOKEN, TOKSIZ, DEFN, MAXDEF, FD)
         CALL INSTAL(TOKEN, DEFN)
         !
      ELSE
         CALL PBSTR(DEFN)   # PUSH REPLACEMENT ONTO INPUT
      !
   DEFTOK = T
   IF (DEFTOK == ALPHA)   # CONVERT TO SINGLE CASE
      CALL FOLD(TOKEN)
   RETURN
   END
# FOLD - CONVERT ALPHABETIC TOKEN TO SINGLE CASE
   SUBROUTINE FOLD(TOKEN)
   CHARACTER TOKEN(ARB)
   INTEGER I
 
   FOR (I = 1; TOKEN(I) ^= EOS; I = I + 1)
      IF (TOKEN(I) >= BIGA & TOKEN(I) <= BIGZ)
         TOKEN(I) = TOKEN(I) - BIGA + LETA
   RETURN
   END
# DOCODE - GENERATE CODE FOR BEGINNING OF DO
   SUBROUTINE DOCODE(LAB)
   INTEGER LABGEN
   INTEGER LAB
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
   STRING SDO "DO"
 
   XFER = NO
   CALL OUTTAB
   CALL OUTSTR(SDO)
   LAB = LABGEN(2)
   CALL OUTNUM(LAB)
   CALL EATUP
   CALL OUTDON
   RETURN
   END
# DOSTAT - GENERATE CODE FOR END OF DO STATEMENT
   SUBROUTINE DOSTAT(LAB)
   INTEGER LAB
 
   CALL OUTCON(LAB)
   CALL OUTCON(LAB+1)
   RETURN
   END
# EATUP - PROCESS REST OF STATEMENT; INTERPRET CONTINUATIONS
   SUBROUTINE EATUP
   CHARACTER GETTOK
   CHARACTER PTOKEN(MAXTOK), T, TOKEN(MAXTOK)
   INTEGER NLPAR
 
   NLPAR = 0
   REPEAT <
      T = GETTOK(TOKEN, MAXTOK)
      IF (T == SEMICOL \ T == NEWLINE)
         BREAK
      IF (T == RBRACE \ T == LBRACE) <
         CALL PBSTR(TOKEN)
         BREAK
         !
      IF (T == EOF) <
         CALL SYNERR("UNEXPECTED EOF.")
         CALL PBSTR(TOKEN)
         BREAK
         !
      IF (T == COMMA \ T == PLUS \ T == MINUS \ T == STAR \ T == LPAREN \
        T == AND \ T == BAR \ T == BANG \ T == EQUALS \ T == UNDERLINE ) <
         WHILE (GETTOK(PTOKEN, MAXTOK) == NEWLINE)
            ;
         CALL PBSTR(PTOKEN)
         IF (T == UNDERLINE)
            TOKEN(1) = EOS
         !
      IF (T == LPAREN)
         NLPAR = NLPAR + 1
      ELSE IF (T == RPAREN)
         NLPAR = NLPAR - 1
      CALL OUTSTR(TOKEN)
      ! UNTIL (NLPAR < 0)
   IF (NLPAR ^= 0)
      CALL SYNERR("UNBALANCED PARENTHESES.")
   RETURN
   END
# ELSEIF - GENERATE CODE FOR END OF IF BEFORE ELSE
   SUBROUTINE ELSEIF(LAB)
   INTEGER LAB
 
   CALL OUTGO(LAB+1)
   CALL OUTCON(LAB)
   RETURN
   END
# 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) <
         EQUAL = YES
         RETURN
         !
   EQUAL = NO
   RETURN
   END
# FORCOD - BEGINNING OF FOR STATEMENT
   SUBROUTINE FORCOD(LAB)
   CHARACTER GETTOK, GNBTOK
   CHARACTER T, TOKEN(MAXTOK)
   INTEGER LENGTH, LABGEN
   INTEGER I, J, LAB, NLPAR
   # INCLUDE COMMONBLOCKS
   INCLUDE CFOR
   STRING IFNOT "IF(.NOT."
 
   LAB = LABGEN(3)
   CALL OUTCON(0)
   IF (GNBTOK(TOKEN, MAXTOK) ^= LPAREN) <
      CALL SYNERR("MISSING LEFT PAREN.")
      RETURN
      !
   IF (GNBTOK(TOKEN, MAXTOK) ^= SEMICOL) <   # REAL INIT CLAUSE
      CALL PBSTR(TOKEN)
      CALL OUTTAB
      CALL EATUP
      CALL OUTDON
      !
   IF (GNBTOK(TOKEN, MAXTOK) == SEMICOL)   # EMPTY CONDITION
      CALL OUTCON(LAB)
   ELSE <   # NON-EMPTY CONDITION
      CALL PBSTR(TOKEN)
      CALL OUTNUM(LAB)
      CALL OUTTAB
      CALL OUTSTR(IFNOT)
      CALL OUTCH(LPAREN)
      NLPAR = 0
      WHILE (NLPAR >= 0) <
         T = GETTOK(TOKEN, MAXTOK)
         IF (T == SEMICOL)
            BREAK
         IF (T == LPAREN)
            NLPAR = NLPAR + 1
         ELSE IF (T == RPAREN)
            NLPAR = NLPAR - 1
         IF (T == EOF) <
            CALL PBSTR(TOKEN)
            RETURN
            !
         IF (T ^= NEWLINE & T ^= UNDERLINE)
            CALL OUTSTR(TOKEN)
         !
      CALL OUTCH(RPAREN)
      CALL OUTCH(RPAREN)
      CALL OUTGO(LAB+2)
      IF (NLPAR < 0)
         CALL SYNERR("INVALID FOR CLAUSE.")
      !
   FORDEP = FORDEP + 1   # STACK REINIT CLAUSE
   J = 1
   FOR (I = 1; I < FORDEP; I = I + 1)   # FIND END
      J = J + LENGTH(FORSTK(J)) + 1
   FORSTK(J) = EOS   # NULL, IN CASE NO REINIT
   NLPAR = 0
   T = GNBTOK(TOKEN, MAXTOK)
   CALL PBSTR(TOKEN)
   WHILE (NLPAR >= 0) <
      T = GETTOK(TOKEN, MAXTOK)
      IF (T == LPAREN)
         NLPAR = NLPAR + 1
      ELSE IF (T == RPAREN)
         NLPAR = NLPAR - 1
      IF (T == EOF) <
         CALL PBSTR(TOKEN)
         BREAK
         !
      IF (NLPAR >= 0 & T ^= NEWLINE & T ^= UNDERLINE) <
         IF (J + LENGTH(TOKEN) >= MAXFORSTK)
            CALL BADERR("FOR CLAUSE TOO LONG.")
         CALL SCOPY(TOKEN, 1, FORSTK, J)
         J = J + LENGTH(TOKEN)
         !
      !
   LAB = LAB + 1   # LABEL FOR NEXT'S
   RETURN
   END
# FORS - PROCESS END OF FOR STATEMENT
   SUBROUTINE FORS(LAB)
   INTEGER LENGTH
   INTEGER I, J, LAB
   # INCLUDE COMMONBLOCKS
   INCLUDE CFOR
   INCLUDE CGOTO
 
   XFER = NO
   CALL OUTNUM(LAB)
   J = 1
   FOR (I = 1; I < FORDEP; I = I + 1)
      J = J + LENGTH(FORSTK(J)) + 1
   IF (LENGTH(FORSTK(J)) > 0) <
      CALL OUTTAB
      CALL OUTSTR(FORSTK(J))
      CALL OUTDON
      !
   CALL OUTGO(LAB-1)
   CALL OUTCON(LAB+1)
   FORDEP = FORDEP - 1
   RETURN
   END
# GETDEF (FOR NO ARGUMENTS) - GET NAME AND DEFINITION
   SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD)
   CHARACTER GTOK, NGETCH
   INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ
   CHARACTER C, DEFN(MAXDEF), TOKEN(MAXTOK), T, PTOKEN(MAXTOK)
 
   CALL SKPBLK(FD)
   C = GTOK(PTOKEN, MAXTOK, FD)
   IF (C == LPAREN)
      T = LPAREN             # DEFINE (NAME, DEFN)
   ELSE <
      T = BLANK              # DEFINE NAME DEFN
      CALL PBSTR(PTOKEN)
      !
   CALL SKPBLK(FD)
   IF (GTOK(TOKEN, TOKSIZ, FD) ^= ALPHA)
      CALL BADERR("NON-ALPHANUMERIC NAME.")
   CALL SKPBLK(FD)
   C = GTOK(PTOKEN, MAXTOK, FD)
   IF (T == BLANK) <         # DEFINE NAME DEFN
      CALL PBSTR(PTOKEN)
      I = 1
      REPEAT <
         C = NGETCH(C, FD)
         IF (I > DEFSIZ)
            CALL BADERR("DEFINITION TOO LONG.")
         DEFN(I) = C
         I = I + 1
         ! UNTIL (C == SHARP \ C == NEWLINE \ C == EOF)
      IF (C == SHARP)
         CALL PUTBAK(C)
      !
   ELSE IF (T == LPAREN) <   # DEFINE (NAME, DEFN)
      IF (C ^= COMMA)
         CALL BADERR("MISSING COMMA IN DEFINE.")
      # ELSE GOT (NAME,
      NLPAR = 0
      FOR (I = 1; NLPAR >= 0; I = I + 1)
         IF (I > DEFSIZ)
            CALL BADERR("DEFINITION TOO LONG.")
         ELSE IF (NGETCH(DEFN(I), FD) == EOF)
            CALL BADERR("MISSING RIGHT PAREN.")
         ELSE IF (DEFN(I) == LPAREN)
            NLPAR = NLPAR + 1
         ELSE IF (DEFN(I) == RPAREN)
            NLPAR = NLPAR - 1
         # ELSE NORMAL CHARACTER IN DEFN(I)
      !
   ELSE
      CALL BADERR("GETDEF IS CONFUSED.")
   DEFN(I-1) = EOS
   RETURN
   END
# GETTOK - GET TOKEN. HANDLES FILE INCLUSION AND LINE NUMBERS
   CHARACTER FUNCTION GETTOK(TOKEN, TOKSIZ)
   INTEGER EQUAL, OPEN, LENGTH
   INTEGER T, I, TOKSIZ, F
   CHARACTER DEFTOK
   CHARACTER NAME(MAXNAME), TOKEN(MAXTOK)
   # INCLUDE COMMONBLOCKS
   INCLUDE CLINE
   INCLUDE CFNAME
   STRING FNCN "FUNCTION"
   STRING INCL "INCLUDE"
 
   FOR ( ; LEVEL > 0; LEVEL = LEVEL - 1) <
      F = INFILE(LEVEL)
      FOR (GETTOK = DEFTOK(TOKEN, TOKSIZ, F); GETTOK ^= EOF;
         GETTOK = DEFTOK(TOKEN, TOKSIZ, F)) <
         IF (EQUAL(TOKEN, FNCN) == YES) <
            CALL SKPBLK(INFILE(LEVEL))
            T = DEFTOK(FCNAME, MAXNAME, F)
            CALL PBSTR(FCNAME)
            IF (T ^= ALPHA)
               CALL SYNERR("MISSING FUNCTION NAME.")
            CALL PUTBAK(BLANK)
            RETURN
            !
         ELSE IF (EQUAL(TOKEN, INCL) == NO)
            RETURN
         CALL SKPBLK(INFILE(LEVEL))
         FOR (I = 1;; I = LENGTH(NAME) + 1) <
            T = DEFTOK(NAME(I), MAXNAME, F)
            IF (T == NEWLINE \ T == SEMICOL) <
               CALL PBSTR(NAME(I))
               BREAK
               !
            !
         NAME(I) = EOS
         IF (LEVEL >= NFILES)
            CALL SYNERR("INCLUDES NESTED TOO DEEPLY.")
         ELSE <
            INFILE(LEVEL+1) = OPEN(NAME, READ)
            LINECT(LEVEL+1) = 1
            IF (INFILE(LEVEL+1) == ERR)
               CALL SYNERR("CAN'T OPEN INCLUDE.")
            ELSE <
               LEVEL = LEVEL + 1
               IF (FNAMP + I <= MAXFNAMES) <
                  CALL SCOPY(NAME, 1, FNAMES, FNAMP)
                  FNAMP = FNAMP + I    # PUSH FILE NAME STACK
                  !
               F = INFILE(LEVEL)
               !
            !
         !
      IF (LEVEL > 1) <      # CLOSE INCLUDE AND POP FILE NAME STACK
         CALL CLOSE(INFILE(LEVEL))
         FOR (FNAMP = FNAMP - 1; FNAMP > 1; FNAMP = FNAMP - 1)
            IF (FNAMES(FNAMP-1) == EOS)
               BREAK
         !
      !
   TOKEN(1) = EOF   # IN CASE CALLED MORE THAN ONCE
   TOKEN(2) = EOS
   GETTOK = EOF
   RETURN
   END
# GNBTOK - GET NONBLANK TOKEN
   CHARACTER FUNCTION GNBTOK(TOKEN, TOKSIZ)
   INTEGER TOKSIZ
   CHARACTER TOKEN(MAXTOK), GETTOK
   # INCLUDE COMMONBLOCKS
   INCLUDE CLINE
 
   CALL SKPBLK(INFILE(LEVEL))
   GNBTOK = GETTOK(TOKEN, TOKSIZ)
   RETURN
   END
# GTOK - GET TOKEN FOR RATFOR
   CHARACTER FUNCTION GTOK(LEXSTR, TOKSIZ, FD)
   CHARACTER NGETCH, TYPE
   INTEGER FD, I, B, N, TOKSIZ, ITOC
   CHARACTER C, LEXSTR(MAXTOK)
   # INCLUDE COMMONBLOCKS
   INCLUDE CLINE
 
   C = NGETCH(LEXSTR(1), FD)
   IF (C == BLANK \ C == TAB) <
      LEXSTR(1) = BLANK
      WHILE (C == BLANK \ C == TAB)    # COMPRESS MANY BLANKS TO ONE
         C = NGETCH(C, FD)
      IF (C == SHARP)
         WHILE (NGETCH(C, FD) ^= NEWLINE)   # STRIP COMMENTS
            ;
      IF (C ^= NEWLINE)
         CALL PUTBAK(C)
      ELSE
         LEXSTR(1) = NEWLINE
      LEXSTR(2) = EOS
      GTOK = LEXSTR(1)
      RETURN
      !
   I = 1
   GTOK = TYPE(C)
   IF (GTOK == LETTER) <%# ALPHA
      FOR (I = 1; I < TOKSIZ - 2; I = I + 1) <
         GTOK = TYPE(NGETCH(LEXSTR(I+1), FD))
         IF (GTOK ^= LETTER & GTOK ^= DIGIT & GTOK ^= UNDERLINE
             & GTOK ^= PERIOD)
               BREAK
         !
      CALL PUTBAK(LEXSTR(I+1))
      GTOK = ALPHA
      !
   ELSE IF (GTOK == DIGIT) <%# DIGITS
      B = C - DIG0%# IN CASE ALTERNATE BASE NUMBER
      FOR (I = 1; I < TOKSIZ - 2; I = I + 1) <
         IF (TYPE(NGETCH(LEXSTR(I+1), FD)) ^= DIGIT)
            BREAK
         B = 10*B + LEXSTR(I+1) - DIG0
         !
      IF (LEXSTR(I+1) == RADIX & B >= 2 & B <= 36) <   #N%DDD...
         FOR (N = 0;; N = B*N + C - DIG0) <
            C = NGETCH(LEXSTR(1), FD)
            IF (C >= LETA & C <= LETZ)
               C = C - LETA + DIG9 + 1
            ELSE IF (C >= BIGA & C <= BIGZ)
               C = C - BIGA + DIG9 + 1
            IF (C < DIG0 \ C >= DIG0 + B)
               BREAK
            !
         CALL PUTBAK(LEXSTR(1))
         I = ITOC(N, LEXSTR, TOKSIZ)
         !
      ELSE
         CALL PUTBAK(LEXSTR(I+1))
      GTOK = DIGIT
      !
   ELSE IF (C == LBRACK) <   # ALLOW [ FOR <
      LEXSTR(1) = LBRACE
      GTOK = LBRACE
      !
   ELSE IF (C == RBRACK) <   # ALLOW ] FOR !
      LEXSTR(1) = RBRACE
      GTOK = RBRACE
      !
   ELSE IF (C == DOLLAR) <   # ALLOW $( AND $) FOR < AND !
      IF (NGETCH(LEXSTR(2), FD) == LPAREN) <
         LEXSTR(1) = LBRACE
         GTOK = LBRACE
         !
      ELSE IF (LEXSTR(2) == RPAREN) <
         LEXSTR(1) = RBRACE
         GTOK = RBRACE
         !
      ELSE
         CALL PUTBAK(LEXSTR(2))
      !
   ELSE IF (C == SQUOTE \ C == DQUOTE) <
      FOR (I = 2; NGETCH(LEXSTR(I), FD) ^= LEXSTR(1); I = I + 1) <
         IF (LEXSTR(I) == UNDERLINE)
            IF (NGETCH(C, FD) == NEWLINE) <
               WHILE (C == NEWLINE \ C == BLANK \ C == TAB)
                  C = NGETCH(C, FD)
               LEXSTR(I) = C
               !
            ELSE
               CALL PUTBAK(C)
         IF (LEXSTR(I) == NEWLINE \ I >= TOKSIZ-1) <
            CALL SYNERR("MISSING QUOTE.")
            LEXSTR(I) = LEXSTR(1)
            CALL PUTBAK(NEWLINE)
            BREAK
            !
         !
      !
   ELSE IF (C == SHARP) <   # STRIP COMMENTS
      WHILE (NGETCH(LEXSTR(1), FD) ^= NEWLINE)
         ;
      GTOK = NEWLINE
      !
   ELSE IF (C == GREATER \ C == LESS \ C == NOT \ C == BANG \ C == CARET
      \ C == EQUALS \ C == AND \ C == OR)
      CALL RELATE(LEXSTR, I, FD)
   IF (I >= TOKSIZ-1)
      CALL SYNERR("TOKEN TOO LONG.")
   LEXSTR(I+1) = EOS
   IF (LEXSTR(1) == NEWLINE)
      LINECT(LEVEL) = LINECT(LEVEL) + 1
   RETURN
   END
# IFCODE - GENERATE INITIAL CODE FOR IF
   SUBROUTINE IFCODE(LAB)
   INTEGER LABGEN
   INTEGER LAB
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
 
   XFER = NO
   LAB = LABGEN(2)
   CALL IFGO(LAB)
   RETURN
   END
# IFGO - GENERATE "IF(.NOT.(...))GOTO LAB"
   SUBROUTINE IFGO(LAB)
   INTEGER LAB
   STRING IFNOT "IF(.NOT."
 
   CALL OUTTAB         # GET TO COLUMN 7
   CALL OUTSTR(IFNOT)      # " IF(.NOT. "
   CALL BALPAR         # COLLECT AND OUTPUT CONDITION
   CALL OUTCH(RPAREN)      # " ) "
   CALL OUTGO(LAB)      # " GOTO LAB "
   RETURN
   END
# INIT - INITIALIZE
   SUBROUTINE INIT
   INTEGER I, DEFTYP(2)
   # INCLUDE COMMONBLOCKS
   INCLUDE COUTLN
   INCLUDE CLINE
   INCLUDE CDEFIO
   INCLUDE CFOR
   INCLUDE CLOOK
   INCLUDE CFNAME
   INCLUDE CLABEL
   INCLUDE CSBUF
   STRING DEF "DEFINE"
   STRING BDEF "DEFINE"
   DATA DEFTYP(1), DEFTYP(2) /DEFTYPE, EOS/
 
   OUTP = 0%%# OUTPUT CHARACTER POINTER
   LEVEL = 1%%# FILE CONTROL
   LINECT(1) = 1
   INFILE(1) = STDIN
   FNAMP = 2
   FNAMES(1) = EOS
   BP = 0%%# PUSHBACK BUFFER POINTER
   FORDEP = 0%%# FOR STACK
   AVAIL = 1%%# POINTERS FOR LOOKUP
   DO I = 1,127
      TABPTR(I) = 0
   CALL INSTAL(DEF, DEFTYP)%# DEFAULT DEFINITIONS
   CALL INSTAL(BDEF, DEFTYP)
   FCNAME(1) = EOS%# CURRENT FUNCTION NAME
   LABEL = 23000%# NEXT GENERATED LABEL
   SBP = 1%%# STRING STATEMENT BUFFER
   RETURN
   END
# INSTAL - ADD NAME AND DEFINITION TO TABLE
   SUBROUTINE INSTAL(NAME, DEFN)
   CHARACTER DEFN(MAXTOK), NAME(MAXDEF), C
   INTEGER LENGTH
   INTEGER DLEN, NLEN
   # INCLUDE COMMONBLOCKS
   INCLUDE CLOOK
 
   NLEN = LENGTH(NAME) + 1
   DLEN = LENGTH(DEFN) + 1
   IF (AVAIL + NLEN + DLEN > MAXTBL) <
      CALL PUTLIN(NAME, ERROUT)
      CALL REMARK(": TOO MANY DEFINITIONS.")
      RETURN
      !
   C = NAME(1)
   TABLE(AVAIL) = TABPTR(C)
   TABPTR(C) = AVAIL
   CALL SCOPY(NAME, 1, TABLE, AVAIL + 1)
   CALL SCOPY(DEFN, 1, TABLE, AVAIL + NLEN + 1)
   AVAIL = AVAIL + NLEN + DLEN + 1
   RETURN
   END
# ITOC - CONVERT INTEGER  INT  TO CHAR STRING IN  STR
   INTEGER FUNCTION ITOC(INT, STR, SIZE)
   INTEGER ABS, MOD
   INTEGER I, INT, INTVAL, J, K, SIZE
   CHARACTER STR(MAXCHARS)
 
   INTVAL = ABS(INT)
   STR(1) = EOS
   I = 1
   REPEAT <            # GENERATE DIGITS
      I = I + 1
      STR(I) = MOD(INTVAL, 10) + DIG0
      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
# LABELC - OUTPUT STATEMENT NUMBER
   SUBROUTINE LABELC(LEXSTR)
   CHARACTER LEXSTR(ARB)
   INTEGER LENGTH
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
 
   XFER = NO   # CAN'T SUPPRESS GOTO'S NOW
   IF (LENGTH(LEXSTR) == 5)   # WARN ABOUT 23XXX LABELS
      IF (LEXSTR(1) == DIG2 & LEXSTR(2) == DIG3)
         CALL SYNERR("WARNING: POSSIBLE LABEL CONFLICT.")
   CALL OUTSTR(LEXSTR)
   CALL OUTTAB
   RETURN
   END
# LABGEN - GENERATE  N  CONSECUTIVE LABELS, RETURN FIRST ONE
   INTEGER FUNCTION LABGEN(N)
   INTEGER N
   # INCLUDE COMMONBLOCKS
   INCLUDE CLABEL
 
   LABGEN = LABEL
   LABEL = LABEL + N
   RETURN
   END
# LENGTH - COMPUTE LENGTH OF STRING
   INTEGER FUNCTION LENGTH(STR)
   INTEGER STR(ARB)
 
   FOR (LENGTH = 0; STR(LENGTH+1) ^= EOS; LENGTH = LENGTH + 1)
      ;
   RETURN
   END
# LEX - RETURN LEXICAL TYPE OF TOKEN
   INTEGER FUNCTION LEX(LEXSTR)
   CHARACTER GNBTOK
   CHARACTER LEXSTR(MAXTOK)
   INTEGER EQUAL
   # INCLUDE COMMONBLOCKS
   STRING SIF "IF"
   STRING SELSE "ELSE"
   STRING SWHILE "WHILE"
   STRING SDO "DO"
   STRING SBREAK "BREAK"
   STRING SNEXT "NEXT"
   STRING SFOR "FOR"
   STRING SREPT "REPEAT"
   STRING SUNTIL "UNTIL"
   STRING SRET "RETURN"
   STRING SSTR "STRING"
 
   FOR (LEX = GNBTOK(LEXSTR, MAXTOK); LEX == NEWLINE;
      LEX = GNBTOK(LEXSTR, MAXTOK))
         ;
   IF (LEX == EOF \ LEX == SEMICOL \ LEX == LBRACE \ LEX == RBRACE)
      RETURN
   IF (LEX == DIGIT)
      LEX = LEXDIGITS
   ELSE IF (EQUAL(LEXSTR, SIF) == YES)
      LEX = LEXIF
   ELSE IF (EQUAL(LEXSTR, SELSE) == YES)
      LEX = LEXELSE
   ELSE IF (EQUAL(LEXSTR, SWHILE) == YES)
      LEX = LEXWHILE
   ELSE IF (EQUAL(LEXSTR, SDO) == YES)
      LEX = LEXDO
   ELSE IF (EQUAL(LEXSTR, SBREAK) == YES)
      LEX = LEXBREAK
   ELSE IF (EQUAL(LEXSTR, SNEXT) == YES)
      LEX = LEXNEXT
   ELSE IF (EQUAL(LEXSTR, SFOR) == YES)
      LEX = LEXFOR
   ELSE IF (EQUAL(LEXSTR, SREPT) == YES)
      LEX = LEXREPEAT
   ELSE IF (EQUAL(LEXSTR, SUNTIL) == YES)
      LEX = LEXUNTIL
   ELSE IF (EQUAL(LEXSTR, SRET) == YES)
      LEX = LEXRETURN
   ELSE IF (EQUAL(LEXSTR, SSTR) == YES)
      LEX = LEXSTRING
   ELSE
      LEX = LEXOTHER
   RETURN
   END
# LOOKUP - LOCATE NAME, EXTRACT DEFINITION FROM TABLE
   INTEGER FUNCTION LOOKUP(NAME, DEFN)
   CHARACTER DEFN(MAXDEF), NAME(MAXTOK), C
   INTEGER I, J, K
   # INCLUDE COMMONBLOCKS
   INCLUDE CLOOK
 
   C = NAME(1)
   FOR (I = TABPTR(C); I > 0; I = TABLE(I)) <
      J = I + 1
      FOR (K = 1; NAME(K) == TABLE(J) & NAME(K) ^= EOS; K = K + 1)
         J = J + 1
      IF (NAME(K) == TABLE(J)) <      # GOT ONE
         CALL SCOPY(TABLE, J+1, DEFN, 1)
         LOOKUP = YES
         RETURN
         !
      !
   LOOKUP = NO
   RETURN
   END
# NGETCH - GET A (POSSIBLY PUSHED BACK) CHARACTER
   CHARACTER FUNCTION NGETCH(C, FD)
   CHARACTER GETCH
   CHARACTER C
   INTEGER FD
   # INCLUDE COMMONBLOCKS
   INCLUDE CDEFIO
 
   IF (BP > 0) <
      C = BUF(BP)
      BP = BP - 1
      !
   ELSE
      C = GETCH(C, FD)
   NGETCH = C
   RETURN
   END
# OTHERC - OUTPUT ORDINARY FORTRAN STATEMENT
   SUBROUTINE OTHERC(LEXSTR)
   CHARACTER LEXSTR(ARB)
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
 
   XFER = NO
   CALL OUTTAB
   CALL OUTSTR(LEXSTR)
   CALL EATUP
   CALL OUTDON
   RETURN
   END
# OUTCH - PUT ONE CHARACTER INTO OUTPUT BUFFER
   SUBROUTINE OUTCH(C)
   CHARACTER C
   INTEGER I
   # INCLUDE COMMONBLOCKS
   INCLUDE COUTLN
 
   IF (OUTP >= 72) <   # CONTINUATION CARD
      CALL OUTDON
      FOR (I = 1; I < 6; I = I + 1)
         OUTBUF(I) = BLANK
      OUTBUF(6) = STAR
      OUTP = 6
      !
   OUTP = OUTP + 1
   OUTBUF(OUTP) = C
   RETURN
   END
# OUTCON - OUTPUT "N   CONTINUE"
   SUBROUTINE OUTCON(N)
   INTEGER N
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
   INCLUDE COUTLN
   STRING CONTIN "CONTINUE"
 
   XFER = NO
   IF (N <= 0 & OUTP == 0)
      RETURN            # DON'T NEED UNLABELED CONTINUES
   IF (N > 0)
      CALL OUTNUM(N)
   CALL OUTTAB
   CALL OUTSTR(CONTIN)
   CALL OUTDON
   RETURN
   END
# OUTDON - FINISH OFF AN OUTPUT LINE
   SUBROUTINE OUTDON
   # INCLUDE COMMONBLOCKS
   INCLUDE COUTLN
 
   OUTBUF(OUTP+1) = NEWLINE
   OUTBUF(OUTP+2) = EOS
   CALL PUTLIN(OUTBUF, STDOUT)
   OUTP = 0
   RETURN
   END
# OUTGO - OUTPUT "GOTO  N"
   SUBROUTINE OUTGO(N)
   INTEGER N
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
   STRING GOTO "GOTO "
 
   IF (XFER == YES)
      RETURN
   CALL OUTTAB
   CALL OUTSTR(GOTO)
   CALL OUTNUM(N)
   CALL OUTDON
   RETURN
   END
# OUTNUM - OUTPUT POSITIVE DECIMAL NUMBER
   SUBROUTINE OUTNUM(N)
   CHARACTER CHARS(MAXCHARS)
   INTEGER I, M
 
   M = N
   I = 0
   REPEAT <
      I = I + 1
      CHARS(I) = MOD(M, 10) + DIG0
      M = M / 10
      ! UNTIL (M == 0 \ I >= MAXCHARS)
   FOR ( ; I > 0; I = I - 1)
      CALL OUTCH(CHARS(I))
   RETURN
   END
# OUTSTR - OUTPUT STRING; HANDLES QUOTED LITERALS
   SUBROUTINE OUTSTR(STR)
   CHARACTER C, STR(ARB)
   INTEGER I, J
 
   FOR (I = 1; STR(I) ^= EOS; I = I + 1) <
      C = STR(I)
      IF (C ^= SQUOTE & C ^= DQUOTE) <
         IF (C >= LETA & C <= LETZ)%# REMOVE THIS IF YOU
            C = C - LETA + BIGA%%# DON'T NEED UPPER CASE FORTRAN
         CALL OUTCH(C)
         !
      ELSE <
         I = I + 1
         FOR (J = I; STR(J) ^= C; J = J + 1)   # FIND END
            ;
         CALL OUTNUM(J-I)
         CALL OUTCH(BIGH)
         FOR ( ; I < J; I = I + 1)
            CALL OUTCH(STR(I))
         !
      !
   RETURN
   END
# OUTTAB - GET PAST COLUMN 6
   SUBROUTINE OUTTAB
   # INCLUDE COMMONBLOCKS
   INCLUDE COUTLN
 
   WHILE (OUTP < 6)
      CALL OUTCH(BLANK)
   RETURN
   END
# PARSE - PARSE RATFOR SOURCE PROGRAM
   SUBROUTINE PARSE
   CHARACTER LEXSTR(MAXTOK)
   INTEGER LEX
   INTEGER LAB, LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN
   INCLUDE CGOTO
   INCLUDE CFOR
   INCLUDE CFNAME
   INCLUDE CLINE
   INCLUDE CSBUF
   INCLUDE CLABEL
   INCLUDE CLOOK
   INCLUDE CDEFIO
   INCLUDE COUTLN
 
   CALL INIT
   SP = 1
   LEXTYP(1) = EOF
   FOR (TOKEN = LEX(LEXSTR); TOKEN ^= EOF; TOKEN = LEX(LEXSTR)) <
      IF (TOKEN == LEXIF)
         CALL IFCODE(LAB)
      ELSE IF (TOKEN == LEXDO)
         CALL DOCODE(LAB)
      ELSE IF (TOKEN == LEXWHILE)
         CALL WHILEC(LAB)
      ELSE IF (TOKEN == LEXFOR)
         CALL FORCOD(LAB)
      ELSE IF (TOKEN == LEXREPEAT)
         CALL REPCOD(LAB)
      ELSE IF (TOKEN == LEXDIGITS)
         CALL LABELC(LEXSTR)
      ELSE IF (TOKEN == LEXELSE) <
         IF (LEXTYP(SP) == LEXIF)
            CALL ELSEIF(LABVAL(SP))
         ELSE
            CALL SYNERR("ILLEGAL ELSE.")
         !
      IF (TOKEN == LEXIF \ TOKEN == LEXELSE \ TOKEN == LEXWHILE
        \ TOKEN == LEXFOR \ TOKEN == LEXREPEAT
        \ TOKEN == LEXDO \ TOKEN == LEXDIGITS \ TOKEN == LBRACE) <
         SP = SP + 1         # BEGINNING OF STATEMENT
         IF (SP > MAXSTACK)
            CALL BADERR("STACK OVERFLOW IN PARSER.")
         LEXTYP(SP) = TOKEN      # STACK TYPE AND VALUE
         LABVAL(SP) = LAB
         !
      ELSE <      # END OF STATEMENT - PREPARE TO UNSTACK
         IF (TOKEN == RBRACE) <
            IF (LEXTYP(SP) == LBRACE)
               SP = SP - 1
            ELSE
               CALL SYNERR("ILLEGAL RIGHT BRACE.")
            !
         ELSE IF (TOKEN == LEXOTHER)
            CALL OTHERC(LEXSTR)
         ELSE IF (TOKEN == LEXBREAK \ TOKEN == LEXNEXT)
            CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN)
         ELSE IF (TOKEN == LEXRETURN)
            CALL RETCOD
         ELSE IF (TOKEN == LEXSTRING)
            CALL STRDCL
         TOKEN = LEX(LEXSTR)      # PEEK AT NEXT TOKEN
         CALL PBSTR(LEXSTR)
         CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN)
         !
      !
   IF (SP ^= 1)
      CALL SYNERR("UNEXPECTED EOF.")
   RETURN
   END
# PBSTR - PUSH STRING BACK ONTO INPUT
   SUBROUTINE PBSTR(IN)
   CHARACTER IN(ARB)
   INTEGER LENGTH
   INTEGER I
 
   FOR (I = LENGTH(IN); I > 0; I = I - 1)
      CALL PUTBAK(IN(I))
   RETURN
   END
# PUTBAK - PUSH CHARACTER BACK ONTO INPUT
   SUBROUTINE PUTBAK(C)
   CHARACTER C
   # INCLUDE COMMONBLOCKS
   INCLUDE CDEFIO
 
   BP = BP + 1
   IF (BP > BUFSIZE)
      CALL BADERR("TOO MANY CHARACTERS PUSHED BACK.")
   BUF(BP) = C
   RETURN
   END
# PUTLIN - PUT OUT LINE BY REPEATED CALLS TO PUTCH
   SUBROUTINE PUTLIN(B, F)
   CHARACTER B(ARB)
   INTEGER F, I
 
   FOR (I = 1; B(I) ^= EOS; I = I + 1)
      CALL PUTCH(B(I), F)
   RETURN
   END
# RELATE - CONVERT RELATIONAL SHORTHANDS INTO LONG FORM
   SUBROUTINE RELATE(TOKEN, LAST, FD)
   CHARACTER NGETCH
   CHARACTER TOKEN(ARB)
   INTEGER LENGTH
   INTEGER FD, LAST
 
   IF (NGETCH(TOKEN(2), FD) ^= EQUALS) <
      CALL PUTBAK(TOKEN(2))
      TOKEN(3) = LETT
      !
   ELSE
      TOKEN(3) = LETE
   TOKEN(4) = PERIOD
   TOKEN(5) = EOS
   TOKEN(6) = EOS%# FOR .NOT. AND .AND.
   IF (TOKEN(1) == GREATER)
      TOKEN(2) = LETG
   ELSE IF (TOKEN(1) == LESS)
      TOKEN(2) = LETL
   ELSE IF (TOKEN(1) == NOT \ TOKEN(1) == BANG \ TOKEN(1) == CARET) <
      IF (TOKEN(2) ^= EQUALS) <
         TOKEN(3) = LETO
         TOKEN(4) = LETT
         TOKEN(5) = PERIOD
         !
      TOKEN(2) = LETN
      !
   ELSE IF (TOKEN(1) == EQUALS) <
      IF (TOKEN(2) ^= EQUALS) <
         TOKEN(2) = EOS
         LAST = 1
         RETURN
         !
      TOKEN(2) = LETE
      TOKEN(3) = LETQ
      !
   ELSE IF (TOKEN(1) == AND) <
      TOKEN(2) = LETA
      TOKEN(3) = LETN
      TOKEN(4) = LETD
      TOKEN(5) = PERIOD
      !
   ELSE IF (TOKEN(1) == OR) <
      TOKEN(2) = LETO
      TOKEN(3) = LETR
      !
   ELSE   # CAN'T HAPPEN
      TOKEN(2) = EOS
   TOKEN(1) = PERIOD
   LAST = LENGTH(TOKEN)
   RETURN
   END
# REPCOD - GENERATE CODE FOR BEGINNING OF REPEAT
   SUBROUTINE REPCOD(LAB)
   INTEGER LABGEN
   INTEGER LAB
 
   CALL OUTCON(0)   # IN CASE THERE WAS A LABEL
   LAB = LABGEN(3)
   CALL OUTCON(LAB)
   LAB = LAB + 1   # LABEL TO GO ON NEXT'S
   RETURN
   END
# RETCOD - GENERATE CODE FOR RETURN
   SUBROUTINE RETCOD
   CHARACTER TOKEN(MAXTOK), GNBTOK, T
   # INCLUDE COMMONBLOCKS
   INCLUDE CFNAME
   INCLUDE CGOTO
   STRING SRET "RETURN"
 
   T = GNBTOK(TOKEN, MAXTOK)
   IF (T ^= NEWLINE & T ^= SEMICOL & T ^= RBRACE) <
      CALL PBSTR(TOKEN)
      CALL OUTTAB
      CALL OUTSTR(FCNAME)
      CALL OUTCH(EQUALS)
      CALL EATUP
      CALL OUTDON
      !
   ELSE IF (T == RBRACE)
      CALL PBSTR(TOKEN)
   CALL OUTTAB
   CALL OUTSTR(SRET)
   CALL OUTDON
   XFER = YES
   RETURN
   END
# SCOPY - COPY STRING AT FROM(I) TO TO(J)
   SUBROUTINE SCOPY(FROM, I, TO, J)
   CHARACTER FROM(ARB), TO(ARB)
   INTEGER I, J, K1, K2
 
   K2 = J
   FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) <
      TO(K2) = FROM(K1)
      K2 = K2 + 1
      !
   TO(K2) = EOS
   RETURN
   END
# SKPBLK - SKIP BLANKS AND TABS IN FILE  FD
   SUBROUTINE SKPBLK(FD)
   INTEGER FD
   CHARACTER C, NGETCH
 
   FOR (C = NGETCH(C, FD); C == BLANK \ C == TAB; C = NGETCH(C, FD))
      ;
   CALL PUTBAK(C)
   RETURN
   END
# STRDCL - GENERATE CODE FOR STRING DECLARATION
   SUBROUTINE STRDCL
   CHARACTER T, TOKEN(MAXTOK), GNBTOK
   INTEGER I, J, K, LEN, LENGTH, CTOI, LEX
   INCLUDE CSBUF
   STRING INT "INTEGER "
   STRING DAT "DATA "
   STRING EOSS "EOS/"
 
   T = GNBTOK(TOKEN, MAXTOK)
   IF (T ^= ALPHA)
      CALL SYNERR("MISSING STRING TOKEN.")
   CALL OUTTAB
   CALL OUTSTR(INT)
   CALL OUTSTR(TOKEN)
   CALL ADDSTR(TOKEN, SBUF, SBP, SBUFSIZE)  # SAVE FOR LATER
   CALL ADDCHR(EOS, SBUF, SBP, SBUFSIZE)
   IF (GNBTOK(TOKEN, MAXTOK) ^= LPAREN) <  # MAKE SIZE SAME AS INITIAL VALUE
      LEN = LENGTH(TOKEN) + 1
      IF (TOKEN(1) == SQUOTE \ TOKEN(1) == DQUOTE)
         LEN = LEN - 2
      !
   ELSE <%# FORM IS STRING NAME(SIZE) INIT
      T = GNBTOK(TOKEN, MAXTOK)
      I = 1
      LEN = CTOI(TOKEN, I)
      IF (TOKEN(I) ^= EOS)
         CALL SYNERR("INVALID STRING SIZE.")
      IF (GNBTOK(TOKEN, MAXTOK) ^= RPAREN)
         CALL SYNERR("MISSING RIGHT PAREN.")
      ELSE
         T = GNBTOK(TOKEN, MAXTOK)
      !
   CALL OUTCH(LPAREN)
   CALL OUTNUM(LEN)
   CALL OUTCH(RPAREN)
   CALL OUTDON
   IF (TOKEN(1) == SQUOTE \ TOKEN(1) == DQUOTE) <
      LEN = LENGTH(TOKEN)
      TOKEN(LEN) = EOS
      CALL ADDSTR(TOKEN(2), SBUF, SBP, SBUFSIZE)
      !
   ELSE
      CALL ADDSTR(TOKEN, SBUF, SBP, SBUFSIZE)
   CALL ADDCHR(EOS, SBUF, SBP, SBUFSIZE)
   T = LEX(TOKEN)   # PEEK AT NEXT TOKEN
   CALL PBSTR(TOKEN)
   IF (T ^= LEXSTRING) <   # DUMP ACCUMULATED DATA STATEMENTS
      FOR (I = 1; I < SBP; I = J + 1) <
         CALL OUTTAB
         CALL OUTSTR(DAT)
         K = 1
         FOR (J = I + LENGTH(SBUF(I)) + 1; ; J = J + 1) <
            IF (K > 1)
               CALL OUTCH(COMMA)
            CALL OUTSTR(SBUF(I))
            CALL OUTCH(LPAREN)
            CALL OUTNUM(K)
            CALL OUTCH(RPAREN)
            CALL OUTCH(SLASH)
            IF (SBUF(J) == EOS)
               BREAK
            CALL OUTNUM(SBUF(J))
            CALL OUTCH(SLASH)
            K = K + 1
            !
         CALL PBSTR(EOSS)%# USE DEFINED MEANING OF EOS
         REPEAT <
            T = GNBTOK(TOKEN, MAXTOK)
            CALL OUTSTR(TOKEN)
         ! UNTIL (T == SLASH)
         CALL OUTDON
         !
      SBP = 1
      !
   RETURN
   END
# SYNERR - REPORT RATFOR SYNTAX ERROR
   SUBROUTINE SYNERR(MSG)
   CHARACTER LC(MAXCHARS), MSG(ARB)
   INTEGER ITOC
   INTEGER I, JUNK
   # INCLUDE COMMONBLOCKS
   INCLUDE CLINE
   STRING ERRMSG "ERROR AT LINE "
   STRING IN " IN "
 
   CALL PUTLIN(ERRMSG, ERROUT)
   IF (LEVEL >= 1)
      I = LEVEL
   ELSE
      I = 1   # FOR EOF ERRORS
   JUNK = ITOC(LINECT(I), LC, MAXCHARS)
   CALL PUTLIN(LC, ERROUT)
   FOR (I = FNAMP - 1; I > 1; I = I - 1)
      IF (FNAMES(I-1) == EOS) <   # PRINT FILE NAME
         CALL PUTLIN(IN, ERROUT)
         CALL PUTLIN(FNAMES(I), ERROUT)
         BREAK
         !
   CALL PUTCH(COLON, ERROUT)
   CALL PUTCH(BLANK, ERROUT)
   CALL REMARK(MSG)
   RETURN
   END
# TYPE - RETURN LETTER, DIGIT OR CHARACTER; WORKS WITH ASCII ALPHABET
   INTEGER FUNCTION TYPE(C)
   INTEGER C
 
   IF (C >= DIG0 & C <= DIG9)
      TYPE = DIGIT
   ELSE IF (C >= LETA & C <= LETZ)
      TYPE = LETTER
   ELSE IF (C >= BIGA & C <= BIGZ)
      TYPE = LETTER
   ELSE
      TYPE = C
   RETURN
   END
# UNSTAK - UNSTACK AT END OF STATEMENT
   SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN)
   INTEGER LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN
 
   FOR ( ; SP > 1; SP = SP - 1) <
      IF (LEXTYP(SP) == LBRACE)
         BREAK
      IF (LEXTYP(SP) == LEXIF & TOKEN == LEXELSE)
         BREAK
      IF (LEXTYP(SP) == LEXIF)
         CALL OUTCON(LABVAL(SP))
      ELSE IF (LEXTYP(SP) == LEXELSE) <
         IF (SP > 2)
            SP = SP - 1
         CALL OUTCON(LABVAL(SP)+1)
         !
      ELSE IF (LEXTYP(SP) == LEXDO)
         CALL DOSTAT(LABVAL(SP))
      ELSE IF (LEXTYP(SP) == LEXWHILE)
         CALL WHILES(LABVAL(SP))
      ELSE IF (LEXTYP(SP) == LEXFOR)
         CALL FORS(LABVAL(SP))
      ELSE IF (LEXTYP(SP) == LEXREPEAT)
         CALL UNTILS(LABVAL(SP), TOKEN)
      !
   RETURN
   END
# UNTILS - GENERATE CODE FOR UNTIL OR END OF REPEAT
   SUBROUTINE UNTILS(LAB, TOKEN)
   CHARACTER PTOKEN(MAXTOK)
   INTEGER LEX
   INTEGER JUNK, LAB, TOKEN
   # INCLUDE COMMONBLOCKS
   INCLUDE CGOTO
 
   XFER = NO
   CALL OUTNUM(LAB)
   IF (TOKEN == LEXUNTIL) <
      JUNK = LEX(PTOKEN)
      CALL IFGO(LAB-1)
      !
   ELSE
      CALL OUTGO(LAB-1)
   CALL OUTCON(LAB+1)
   RETURN
   END
# WHILEC - GENERATE CODE FOR BEGINNING OF WHILE
   SUBROUTINE WHILEC(LAB)
   INTEGER LABGEN
   INTEGER LAB
 
   CALL OUTCON(0)    # UNLABELED CONTINUE, IN CASE THERE WAS A LABEL
   LAB = LABGEN(2)
   CALL OUTNUM(LAB)
   CALL IFGO(LAB+1)
   RETURN
   END
# WHILES - GENERATE CODE FOR END OF WHILE
   SUBROUTINE WHILES(LAB)
   INTEGER LAB
 
   CALL OUTGO(LAB)
   CALL OUTCON(LAB+1)
   RETURN
   END
#-H- EBCDIC.RAT 17293 1980 103 2141
# EBCDIC - SUGGESTED TRANSLATION TABLES FOR EBCDIC <-> ASCII
   BLOCK DATA EBCDIC
   INTEGER ETOI(256), ITOE(256)
   # ETOI AND ITOE SHOULD BE IN SOME COMMON
 
   # EBCDIC TO INTERNAL ASCII; TABLE IS INDEXED BY C+1
   DATA ETOI(001) /000/  # (00)
   DATA ETOI(002) /001/  # (01)
   DATA ETOI(003) /002/  # (02)
   DATA ETOI(004) /003/  # (03)
   DATA ETOI(005) /019/  # (04)
   DATA ETOI(006) /009/  # (05)
   DATA ETOI(007) /010/  # (06)
   DATA ETOI(008) /127/  # (07)
   DATA ETOI(009) /128/  # (08)
   DATA ETOI(010) /129/  # (09)
   DATA ETOI(011) /130/  # (0A)
   DATA ETOI(012) /011/  # (0B)
   DATA ETOI(013) /012/  # (0C)
   DATA ETOI(014) /013/  # (0D)
   DATA ETOI(015) /014/  # (0E)
   DATA ETOI(016) /015/  # (0F)
   DATA ETOI(017) /016/  # (10)
   DATA ETOI(018) /017/  # (11)
   DATA ETOI(019) /018/  # (12)
   DATA ETOI(020) /131/  # (13)
   DATA ETOI(021) /132/  # (14)
   DATA ETOI(022) /133/  # (15)
   DATA ETOI(023) /008/  # (16)
   DATA ETOI(024) /022/  # (17)
   DATA ETOI(025) /024/  # (18)
   DATA ETOI(026) /025/  # (19)
   DATA ETOI(027) /134/  # (1A)
   DATA ETOI(028) /135/  # (1B)
   DATA ETOI(029) /136/  # (1C)
   DATA ETOI(030) /029/  # (1D)
   DATA ETOI(031) /137/  # (1E)
   DATA ETOI(032) /031/  # (1F)
   DATA ETOI(033) /138/  # (20)
   DATA ETOI(034) /139/  # (21)
   DATA ETOI(035) /028/  # (22)
   DATA ETOI(036) /140/  # (23)
   DATA ETOI(037) /141/  # (24)
   DATA ETOI(038) /142/  # (25)
   DATA ETOI(039) /023/  # (26)
   DATA ETOI(040) /027/  # (27)
   DATA ETOI(041) /143/  # (28)
   DATA ETOI(042) /144/  # (29)
   DATA ETOI(043) /145/  # (2A)
   DATA ETOI(044) /146/  # (2B)
   DATA ETOI(045) /147/  # (2C)
   DATA ETOI(046) /005/  # (2D)
   DATA ETOI(047) /006/  # (2E)
   DATA ETOI(048) /007/  # (2F)
   DATA ETOI(049) /148/  # (30)
   DATA ETOI(050) /149/  # (31)
   DATA ETOI(051) /150/  # (32)
   DATA ETOI(052) /151/  # (33)
   DATA ETOI(053) /152/  # (34)
   DATA ETOI(054) /030/  # (35)
   DATA ETOI(055) /153/  # (36)
   DATA ETOI(056) /004/  # (37)
   DATA ETOI(057) /154/  # (38)
   DATA ETOI(058) /155/  # (39)
   DATA ETOI(059) /156/  # (3A)
   DATA ETOI(060) /157/  # (3B)
   DATA ETOI(061) /020/  # (3C)
   DATA ETOI(062) /021/  # (3D)
   DATA ETOI(063) /158/  # (3E)
   DATA ETOI(064) /026/  # (3F)
   DATA ETOI(065) /032/  # (40)
   DATA ETOI(066) /159/  # (41)
   DATA ETOI(067) /160/  # (42)
   DATA ETOI(068) /161/  # (43)
   DATA ETOI(069) /162/  # (44)
   DATA ETOI(070) /163/  # (45)
   DATA ETOI(071) /164/  # (46)
   DATA ETOI(072) /165/  # (47)
   DATA ETOI(073) /166/  # (48)
   DATA ETOI(074) /167/  # (49)
   DATA ETOI(075) /168/  # (4A)
   DATA ETOI(076) /046/  # (4B)%.
   DATA ETOI(077) /060/  # (4C)%<
   DATA ETOI(078) /040/  # (4D)%(
   DATA ETOI(079) /043/  # (4E)%+
   DATA ETOI(080) /124/  # (4F)%\
   DATA ETOI(081) /038/  # (50)%&
   DATA ETOI(082) /169/  # (51)
   DATA ETOI(083) /170/  # (52)
   DATA ETOI(084) /171/  # (53)
   DATA ETOI(085) /172/  # (54)
   DATA ETOI(086) /173/  # (55)
   DATA ETOI(087) /174/  # (56)
   DATA ETOI(088) /175/  # (57)
   DATA ETOI(089) /176/  # (58)
   DATA ETOI(090) /177/  # (59)
   DATA ETOI(091) /033/  # (5A)%!
   DATA ETOI(092) /036/  # (5B)%$
   DATA ETOI(093) /042/  # (5C)%*
   DATA ETOI(094) /041/  # (5D)%)
   DATA ETOI(095) /059/  # (5E)%;
   DATA ETOI(096) /094/  # (5F)%^
   DATA ETOI(097) /045/  # (60)%-
   DATA ETOI(098) /047/  # (61)%/
   DATA ETOI(099) /178/  # (62)
   DATA ETOI(100) /179/  # (63)
   DATA ETOI(101) /180/  # (64)
   DATA ETOI(102) /181/  # (65)
   DATA ETOI(103) /182/  # (66)
   DATA ETOI(104) /183/  # (67)
   DATA ETOI(105) /184/  # (68)
   DATA ETOI(106) /185/  # (69)
   DATA ETOI(107) /186/  # (6A)
   DATA ETOI(108) /044/  # (6B)%,
   DATA ETOI(109) /037/  # (6C)%%
   DATA ETOI(110) /095/  # (6D)%_
   DATA ETOI(111) /062/  # (6E)%>
   DATA ETOI(112) /063/  # (6F)%?
   DATA ETOI(113) /187/  # (70)
   DATA ETOI(114) /188/  # (71)
   DATA ETOI(115) /189/  # (72)
   DATA ETOI(116) /190/  # (73)
   DATA ETOI(117) /191/  # (74)
   DATA ETOI(118) /192/  # (75)
   DATA ETOI(119) /193/  # (76)
   DATA ETOI(120) /194/  # (77)
   DATA ETOI(121) /195/  # (78)
   DATA ETOI(122) /096/  # (79)%@
   DATA ETOI(123) /058/  # (7A)%:
   DATA ETOI(124) /035/  # (7B)%#
   DATA ETOI(125) /064/  # (7C)%@
   DATA ETOI(126) /039/  # (7D)%'
   DATA ETOI(127) /061/  # (7E)%=
   DATA ETOI(128) /034/  # (7F)%"
   DATA ETOI(129) /196/  # (80)
   DATA ETOI(130) /097/  # (81)%A
   DATA ETOI(131) /098/  # (82)%B
   DATA ETOI(132) /099/  # (83)%C
   DATA ETOI(133) /100/  # (84)%D
   DATA ETOI(134) /101/  # (85)%E
   DATA ETOI(135) /102/  # (86)%F
   DATA ETOI(136) /103/  # (87)%G
   DATA ETOI(137) /104/  # (88)%H
   DATA ETOI(138) /105/  # (89)%I
   DATA ETOI(139) /197/  # (8A)
   DATA ETOI(140) /123/  # (8B)%<
   DATA ETOI(141) /198/  # (8C)
   DATA ETOI(142) /199/  # (8D)
   DATA ETOI(143) /200/  # (8E)
   DATA ETOI(144) /201/  # (8F)
   DATA ETOI(145) /202/  # (90)
   DATA ETOI(146) /106/  # (91)%J
   DATA ETOI(147) /107/  # (92)%K
   DATA ETOI(148) /108/  # (93)%L
   DATA ETOI(149) /109/  # (94)%M
   DATA ETOI(150) /110/  # (95)%N
   DATA ETOI(151) /111/  # (96)%O
   DATA ETOI(152) /112/  # (97)%P
   DATA ETOI(153) /113/  # (98)%Q
   DATA ETOI(154) /114/  # (99)%R
   DATA ETOI(155) /203/  # (9A)
   DATA ETOI(156) /125/  # (9B)%!
   DATA ETOI(157) /092/  # (9C)%\
   DATA ETOI(158) /204/  # (9D)
   DATA ETOI(159) /205/  # (9E)
   DATA ETOI(160) /206/  # (9F)
   DATA ETOI(161) /207/  # (A0)
   DATA ETOI(162) /126/  # (A1)%^
   DATA ETOI(163) /115/  # (A2)%S
   DATA ETOI(164) /116/  # (A3)%T
   DATA ETOI(165) /117/  # (A4)%U
   DATA ETOI(166) /118/  # (A5)%V
   DATA ETOI(167) /119/  # (A6)%W
   DATA ETOI(168) /120/  # (A7)%X
   DATA ETOI(169) /121/  # (A8)%Y
   DATA ETOI(170) /122/  # (A9)%Z
   DATA ETOI(171) /208/  # (AA)
   DATA ETOI(172) /209/  # (AB)
   DATA ETOI(173) /210/  # (AC)
   DATA ETOI(174) /091/  # (AD)%[
   DATA ETOI(175) /211/  # (AE)
   DATA ETOI(176) /212/  # (AF)
   DATA ETOI(177) /213/  # (B0)
   DATA ETOI(178) /214/  # (B1)
   DATA ETOI(179) /215/  # (B2)
   DATA ETOI(180) /216/  # (B3)
   DATA ETOI(181) /217/  # (B4)
   DATA ETOI(182) /218/  # (B5)
   DATA ETOI(183) /219/  # (B6)
   DATA ETOI(184) /220/  # (B7)
   DATA ETOI(185) /221/  # (B8)
   DATA ETOI(186) /222/  # (B9)
   DATA ETOI(187) /223/  # (BA)
   DATA ETOI(188) /224/  # (BB)
   DATA ETOI(189) /225/  # (BC)
   DATA ETOI(190) /093/  # (BD)%]
   DATA ETOI(191) /226/  # (BE)
   DATA ETOI(192) /227/  # (BF)
   DATA ETOI(193) /228/  # (C0)
   DATA ETOI(194) /065/  # (C1)%A
   DATA ETOI(195) /066/  # (C2)%B
   DATA ETOI(196) /067/  # (C3)%C
   DATA ETOI(197) /068/  # (C4)%D
   DATA ETOI(198) /069/  # (C5)%E
   DATA ETOI(199) /070/  # (C6)%F
   DATA ETOI(200) /071/  # (C7)%G
   DATA ETOI(201) /072/  # (C8)%H
   DATA ETOI(202) /073/  # (C9)%I
   DATA ETOI(203) /229/  # (CA)
   DATA ETOI(204) /230/  # (CB)
   DATA ETOI(205) /231/  # (CC)
   DATA ETOI(206) /232/  # (CD)
   DATA ETOI(207) /233/  # (CE)
   DATA ETOI(208) /234/  # (CF)
   DATA ETOI(209) /235/  # (D0)
   DATA ETOI(210) /074/  # (D1)%J
   DATA ETOI(211) /075/  # (D2)%K
   DATA ETOI(212) /076/  # (D3)%L
   DATA ETOI(213) /077/  # (D4)%M
   DATA ETOI(214) /078/  # (D5)%N
   DATA ETOI(215) /079/  # (D6)%O
   DATA ETOI(216) /080/  # (D7)%P
   DATA ETOI(217) /081/  # (D8)%Q
   DATA ETOI(218) /082/  # (D9)%R
   DATA ETOI(219) /236/  # (DA)
   DATA ETOI(220) /237/  # (DB)
   DATA ETOI(221) /238/  # (DC)
   DATA ETOI(222) /239/  # (DD)
   DATA ETOI(223) /240/  # (DE)
   DATA ETOI(224) /241/  # (DF)
   DATA ETOI(225) /242/  # (E0)
   DATA ETOI(226) /243/  # (E1)
   DATA ETOI(227) /083/  # (E2)%S
   DATA ETOI(228) /084/  # (E3)%T
   DATA ETOI(229) /085/  # (E4)%U
   DATA ETOI(230) /086/  # (E5)%V
   DATA ETOI(231) /087/  # (E6)%W
   DATA ETOI(232) /088/  # (E7)%X
   DATA ETOI(233) /089/  # (E8)%Y
   DATA ETOI(234) /090/  # (E9)%Z
   DATA ETOI(235) /244/  # (EA)
   DATA ETOI(236) /245/  # (EB)
   DATA ETOI(237) /246/  # (EC)
   DATA ETOI(238) /247/  # (ED)
   DATA ETOI(239) /248/  # (EE)
   DATA ETOI(240) /249/  # (EF)
   DATA ETOI(241) /048/  # (F0)%0
   DATA ETOI(242) /049/  # (F1)%1
   DATA ETOI(243) /050/  # (F2)%2
   DATA ETOI(244) /051/  # (F3)%3
   DATA ETOI(245) /052/  # (F4)%4
   DATA ETOI(246) /053/  # (F5)%5
   DATA ETOI(247) /054/  # (F6)%6
   DATA ETOI(248) /055/  # (F7)%7
   DATA ETOI(249) /056/  # (F8)%8
   DATA ETOI(250) /057/  # (F9)%9
   DATA ETOI(251) /250/  # (FA)
   DATA ETOI(252) /251/  # (FB)
   DATA ETOI(253) /252/  # (FC)
   DATA ETOI(254) /253/  # (FD)
   DATA ETOI(255) /254/  # (FE)
   DATA ETOI(256) /255/  # (FF)
 
   # INTERNAL ASCII TO EBCDIC; TABLE IS INDEXED BY C+1
   DATA ITOE(001) /000/  # (000)
   DATA ITOE(002) /001/  # (001)
   DATA ITOE(003) /002/  # (002)
   DATA ITOE(004) /003/  # (003)
   DATA ITOE(005) /055/  # (004)
   DATA ITOE(006) /045/  # (005)
   DATA ITOE(007) /046/  # (006)
   DATA ITOE(008) /047/  # (007)
   DATA ITOE(009) /022/  # (010)
   DATA ITOE(010) /005/  # (011)
   DATA ITOE(011) /006/  # (012)
   DATA ITOE(012) /011/  # (013)
   DATA ITOE(013) /012/  # (014)
   DATA ITOE(014) /013/  # (015)
   DATA ITOE(015) /014/  # (016)
   DATA ITOE(016) /015/  # (017)
   DATA ITOE(017) /016/  # (020)
   DATA ITOE(018) /017/  # (021)
   DATA ITOE(019) /018/  # (022)
   DATA ITOE(020) /004/  # (023)
   DATA ITOE(021) /060/  # (024)
   DATA ITOE(022) /061/  # (025)
   DATA ITOE(023) /023/  # (026)
   DATA ITOE(024) /038/  # (027)
   DATA ITOE(025) /024/  # (030)
   DATA ITOE(026) /025/  # (031)
   DATA ITOE(027) /063/  # (032)
   DATA ITOE(028) /039/  # (033)
   DATA ITOE(029) /034/  # (034)
   DATA ITOE(030) /029/  # (035)
   DATA ITOE(031) /053/  # (036)
   DATA ITOE(032) /031/  # (037)
   DATA ITOE(033) /064/  # (040)
   DATA ITOE(034) /090/  # (041)%!
   DATA ITOE(035) /127/  # (042)%"
   DATA ITOE(036) /123/  # (043)%#
   DATA ITOE(037) /091/  # (044)%$
   DATA ITOE(038) /108/  # (045)%%
   DATA ITOE(039) /080/  # (046)%&
   DATA ITOE(040) /125/  # (047)%'
   DATA ITOE(041) /077/  # (050)%(
   DATA ITOE(042) /093/  # (051)%)
   DATA ITOE(043) /092/  # (052)%*
   DATA ITOE(044) /078/  # (053)%+
   DATA ITOE(045) /107/  # (054)%,
   DATA ITOE(046) /096/  # (055)%-
   DATA ITOE(047) /075/  # (056)%.
   DATA ITOE(048) /097/  # (057)%/
   DATA ITOE(049) /240/  # (060)%0
   DATA ITOE(050) /241/  # (061)%1
   DATA ITOE(051) /242/  # (062)%2
   DATA ITOE(052) /243/  # (063)%3
   DATA ITOE(053) /244/  # (064)%4
   DATA ITOE(054) /245/  # (065)%5
   DATA ITOE(055) /246/  # (066)%6
   DATA ITOE(056) /247/  # (067)%7
   DATA ITOE(057) /248/  # (070)%8
   DATA ITOE(058) /249/  # (071)%9
   DATA ITOE(059) /122/  # (072)%:
   DATA ITOE(060) /094/  # (073)%;
   DATA ITOE(061) /076/  # (074)%<
   DATA ITOE(062) /126/  # (075)%=
   DATA ITOE(063) /110/  # (076)%>
   DATA ITOE(064) /111/  # (077)%?
   DATA ITOE(065) /124/  # (100)%@
   DATA ITOE(066) /193/  # (101)%A
   DATA ITOE(067) /194/  # (102)%B
   DATA ITOE(068) /195/  # (103)%C
   DATA ITOE(069) /196/  # (104)%D
   DATA ITOE(070) /197/  # (105)%E
   DATA ITOE(071) /198/  # (106)%F
   DATA ITOE(072) /199/  # (107)%G
   DATA ITOE(073) /200/  # (110)%H
   DATA ITOE(074) /201/  # (111)%I
   DATA ITOE(075) /209/  # (112)%J
   DATA ITOE(076) /210/  # (113)%K
   DATA ITOE(077) /211/  # (114)%L
   DATA ITOE(078) /212/  # (115)%M
   DATA ITOE(079) /213/  # (116)%N
   DATA ITOE(080) /214/  # (117)%O
   DATA ITOE(081) /215/  # (120)%P
   DATA ITOE(082) /216/  # (121)%Q
   DATA ITOE(083) /217/  # (122)%R
   DATA ITOE(084) /226/  # (123)%S
   DATA ITOE(085) /227/  # (124)%T
   DATA ITOE(086) /228/  # (125)%U
   DATA ITOE(087) /229/  # (126)%V
   DATA ITOE(088) /230/  # (127)%W
   DATA ITOE(089) /231/  # (130)%X
   DATA ITOE(090) /232/  # (131)%Y
   DATA ITOE(091) /233/  # (132)%Z
   DATA ITOE(092) /173/  # (133)%[
   DATA ITOE(093) /156/  # (134)%\
   DATA ITOE(094) /189/  # (135)%]
   DATA ITOE(095) /095/  # (136)%^
   DATA ITOE(096) /109/  # (137)%_
   DATA ITOE(097) /121/  # (140)%@
   DATA ITOE(098) /129/  # (141)%A
   DATA ITOE(099) /130/  # (142)%B
   DATA ITOE(100) /131/  # (143)%C
   DATA ITOE(101) /132/  # (144)%D
   DATA ITOE(102) /133/  # (145)%E
   DATA ITOE(103) /134/  # (146)%F
   DATA ITOE(104) /135/  # (147)%G
   DATA ITOE(105) /136/  # (150)%H
   DATA ITOE(106) /137/  # (151)%I
   DATA ITOE(107) /145/  # (152)%J
   DATA ITOE(108) /146/  # (153)%K
   DATA ITOE(109) /147/  # (154)%L
   DATA ITOE(110) /148/  # (155)%M
   DATA ITOE(111) /149/  # (156)%N
   DATA ITOE(112) /150/  # (157)%O
   DATA ITOE(113) /151/  # (160)%P
   DATA ITOE(114) /152/  # (161)%Q
   DATA ITOE(115) /153/  # (162)%R
   DATA ITOE(116) /162/  # (163)%S
   DATA ITOE(117) /163/  # (164)%T
   DATA ITOE(118) /164/  # (165)%U
   DATA ITOE(119) /165/  # (166)%V
   DATA ITOE(120) /166/  # (167)%W
   DATA ITOE(121) /167/  # (170)%X
   DATA ITOE(122) /168/  # (171)%Y
   DATA ITOE(123) /169/  # (172)%Z
   DATA ITOE(124) /139/  # (173)%<
   DATA ITOE(125) /079/  # (174)%\
   DATA ITOE(126) /155/  # (175)%!
   DATA ITOE(127) /161/  # (176)%^
   DATA ITOE(128) /007/  # (177)
   DATA ITOE(129) /008/  # (200)
   DATA ITOE(130) /009/  # (201)
   DATA ITOE(131) /010/  # (202)
   DATA ITOE(132) /019/  # (203)
   DATA ITOE(133) /020/  # (204)
   DATA ITOE(134) /021/  # (205)
   DATA ITOE(135) /026/  # (206)
   DATA ITOE(136) /027/  # (207)
   DATA ITOE(137) /028/  # (210)
   DATA ITOE(138) /030/  # (211)
   DATA ITOE(139) /032/  # (212)
   DATA ITOE(140) /033/  # (213)
   DATA ITOE(141) /035/  # (214)
   DATA ITOE(142) /036/  # (215)
   DATA ITOE(143) /037/  # (216)
   DATA ITOE(144) /040/  # (217)
   DATA ITOE(145) /041/  # (220)
   DATA ITOE(146) /042/  # (221)
   DATA ITOE(147) /043/  # (222)
   DATA ITOE(148) /044/  # (223)
   DATA ITOE(149) /048/  # (224)
   DATA ITOE(150) /049/  # (225)
   DATA ITOE(151) /050/  # (226)
   DATA ITOE(152) /051/  # (227)
   DATA ITOE(153) /052/  # (230)
   DATA ITOE(154) /054/  # (231)
   DATA ITOE(155) /056/  # (232)
   DATA ITOE(156) /057/  # (233)
   DATA ITOE(157) /058/  # (234)
   DATA ITOE(158) /059/  # (235)
   DATA ITOE(159) /062/  # (236)
   DATA ITOE(160) /065/  # (237)
   DATA ITOE(161) /066/  # (240)
   DATA ITOE(162) /067/  # (241)
   DATA ITOE(163) /068/  # (242)
   DATA ITOE(164) /069/  # (243)
   DATA ITOE(165) /070/  # (244)
   DATA ITOE(166) /071/  # (245)
   DATA ITOE(167) /072/  # (246)
   DATA ITOE(168) /073/  # (247)
   DATA ITOE(169) /074/  # (250)
   DATA ITOE(170) /081/  # (251)
   DATA ITOE(171) /082/  # (252)
   DATA ITOE(172) /083/  # (253)
   DATA ITOE(173) /084/  # (254)
   DATA ITOE(174) /085/  # (255)
   DATA ITOE(175) /086/  # (256)
   DATA ITOE(176) /087/  # (257)
   DATA ITOE(177) /088/  # (260)
   DATA ITOE(178) /089/  # (261)
   DATA ITOE(179) /098/  # (262)
   DATA ITOE(180) /099/  # (263)
   DATA ITOE(181) /100/  # (264)
   DATA ITOE(182) /101/  # (265)
   DATA ITOE(183) /102/  # (266)
   DATA ITOE(184) /103/  # (267)
   DATA ITOE(185) /104/  # (270)
   DATA ITOE(186) /105/  # (271)
   DATA ITOE(187) /106/  # (272)
   DATA ITOE(188) /112/  # (273)
   DATA ITOE(189) /113/  # (274)
   DATA ITOE(190) /114/  # (275)
   DATA ITOE(191) /115/  # (276)
   DATA ITOE(192) /116/  # (277)
   DATA ITOE(193) /117/  # (300)
   DATA ITOE(194) /118/  # (301)
   DATA ITOE(195) /119/  # (302)
   DATA ITOE(196) /120/  # (303)
   DATA ITOE(197) /128/  # (304)
   DATA ITOE(198) /138/  # (305)
   DATA ITOE(199) /140/  # (306)
   DATA ITOE(200) /141/  # (307)
   DATA ITOE(201) /142/  # (310)
   DATA ITOE(202) /143/  # (311)
   DATA ITOE(203) /144/  # (312)
   DATA ITOE(204) /154/  # (313)
   DATA ITOE(205) /157/  # (314)
   DATA ITOE(206) /158/  # (315)
   DATA ITOE(207) /159/  # (316)
   DATA ITOE(208) /160/  # (317)
   DATA ITOE(209) /170/  # (320)
   DATA ITOE(210) /171/  # (321)
   DATA ITOE(211) /172/  # (322)
   DATA ITOE(212) /174/  # (323)
   DATA ITOE(213) /175/  # (324)
   DATA ITOE(214) /176/  # (325)
   DATA ITOE(215) /177/  # (326)
   DATA ITOE(216) /178/  # (327)
   DATA ITOE(217) /179/  # (330)
   DATA ITOE(218) /180/  # (331)
   DATA ITOE(219) /181/  # (332)
   DATA ITOE(220) /182/  # (333)
   DATA ITOE(221) /183/  # (334)
   DATA ITOE(222) /184/  # (335)
   DATA ITOE(223) /185/  # (336)
   DATA ITOE(224) /186/  # (337)
   DATA ITOE(225) /187/  # (340)
   DATA ITOE(226) /188/  # (341)
   DATA ITOE(227) /190/  # (342)
   DATA ITOE(228) /191/  # (343)
   DATA ITOE(229) /192/  # (344)
   DATA ITOE(230) /202/  # (345)
   DATA ITOE(231) /203/  # (346)
   DATA ITOE(232) /204/  # (347)
   DATA ITOE(233) /205/  # (350)
   DATA ITOE(234) /206/  # (351)
   DATA ITOE(235) /207/  # (352)
   DATA ITOE(236) /208/  # (353)
   DATA ITOE(237) /218/  # (354)
   DATA ITOE(238) /219/  # (355)
   DATA ITOE(239) /220/  # (356)
   DATA ITOE(240) /221/  # (357)
   DATA ITOE(241) /222/  # (360)
   DATA ITOE(242) /223/  # (361)
   DATA ITOE(243) /224/  # (362)
   DATA ITOE(244) /225/  # (363)
   DATA ITOE(245) /234/  # (364)
   DATA ITOE(246) /235/  # (365)
   DATA ITOE(247) /236/  # (366)
   DATA ITOE(248) /237/  # (367)
   DATA ITOE(249) /238/  # (370)
   DATA ITOE(250) /239/  # (371)
   DATA ITOE(251) /250/  # (372)
   DATA ITOE(252) /251/  # (373)
   DATA ITOE(253) /252/  # (374)
   DATA ITOE(254) /253/  # (375)
   DATA ITOE(255) /254/  # (376)
   DATA ITOE(256) /255/  # (377)
   END
#-H- MBOOT 56521 1980 103 2146
      CALL PARSE
      CALL EXIT
      STOP
      END
      BLOCK DATA
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      DATA FDTAB(1) /1/
      DATA FILTAB(1), FILTAB(2), FILTAB(3), FILTAB(4), FILTAB(5)/ 1, 0,
     *0, 5, 0/
      DATA FDTAB(2) /141/
      DATA FILTAB(141), FILTAB(142), FILTAB(143), FILTAB(144), FILTAB(14
     *5)/ 1, 1, 0, 6, 146/
      DATA FDTAB(3) /281/
      DATA FILTAB(281), FILTAB(282), FILTAB(283), FILTAB(284), FILTAB(28
     *5)/ 1, 1, 0, 6, 286/
      DATA FDTAB(4) /0/
      DATA FILTAB(421) /0/
      DATA FDTAB(5) /0/
      DATA FILTAB(561) /0/
      DATA FDTAB(6) /0/
      DATA FILTAB(701) /0/
      DATA FDTAB(7) /0/
      DATA FILTAB(841) /0/
      DATA FDTAB(8) /0/
      DATA FILTAB(981) /0/
      DATA EXTCHR( 1) /1H /, INTCHR( 1) /32/
      DATA EXTCHR( 2) /1H0/, INTCHR( 2) /48/
      DATA EXTCHR( 3) /1H1/, INTCHR( 3) /49/
      DATA EXTCHR( 4) /1H2/, INTCHR( 4) /50/
      DATA EXTCHR( 5) /1H3/, INTCHR( 5) /51/
      DATA EXTCHR( 6) /1H4/, INTCHR( 6) /52/
      DATA EXTCHR( 7) /1H5/, INTCHR( 7) /53/
      DATA EXTCHR( 8) /1H6/, INTCHR( 8) /54/
      DATA EXTCHR( 9) /1H7/, INTCHR( 9) /55/
      DATA EXTCHR(10) /1H8/, INTCHR(10) /56/
      DATA EXTCHR(11) /1H9/, INTCHR(11) /57/
      DATA EXTCHR(12) /1HA/, INTCHR(12) /97/
      DATA EXTCHR(13) /1HB/, INTCHR(13) /98/
      DATA EXTCHR(14) /1HC/, INTCHR(14) /99/
      DATA EXTCHR(15) /1HD/, INTCHR(15) /100/
      DATA EXTCHR(16) /1HE/, INTCHR(16) /101/
      DATA EXTCHR(17) /1HF/, INTCHR(17) /102/
      DATA EXTCHR(18) /1HG/, INTCHR(18) /103/
      DATA EXTCHR(19) /1HH/, INTCHR(19) /104/
      DATA EXTCHR(20) /1HI/, INTCHR(20) /105/
      DATA EXTCHR(21) /1HJ/, INTCHR(21) /106/
      DATA EXTCHR(22) /1HK/, INTCHR(22) /107/
      DATA EXTCHR(23) /1HL/, INTCHR(23) /108/
      DATA EXTCHR(24) /1HM/, INTCHR(24) /109/
      DATA EXTCHR(25) /1HN/, INTCHR(25) /110/
      DATA EXTCHR(26) /1HO/, INTCHR(26) /111/
      DATA EXTCHR(27) /1HP/, INTCHR(27) /112/
      DATA EXTCHR(28) /1HQ/, INTCHR(28) /113/
      DATA EXTCHR(29) /1HR/, INTCHR(29) /114/
      DATA EXTCHR(30) /1HS/, INTCHR(30) /115/
      DATA EXTCHR(31) /1HT/, INTCHR(31) /116/
      DATA EXTCHR(32) /1HU/, INTCHR(32) /117/
      DATA EXTCHR(33) /1HV/, INTCHR(33) /118/
      DATA EXTCHR(34) /1HW/, INTCHR(34) /119/
      DATA EXTCHR(35) /1HX/, INTCHR(35) /120/
      DATA EXTCHR(36) /1HY/, INTCHR(36) /121/
      DATA EXTCHR(37) /1HZ/, INTCHR(37) /122/
      DATA EXTCHR(38) /1HA/, INTCHR(38) /65/
      DATA EXTCHR(39) /1HB/, INTCHR(39) /66/
      DATA EXTCHR(40) /1HC/, INTCHR(40) /67/
      DATA EXTCHR(41) /1HD/, INTCHR(41) /68/
      DATA EXTCHR(42) /1HE/, INTCHR(42) /69/
      DATA EXTCHR(43) /1HF/, INTCHR(43) /70/
      DATA EXTCHR(44) /1HG/, INTCHR(44) /71/
      DATA EXTCHR(45) /1HH/, INTCHR(45) /72/
      DATA EXTCHR(46) /1HI/, INTCHR(46) /73/
      DATA EXTCHR(47) /1HJ/, INTCHR(47) /74/
      DATA EXTCHR(48) /1HK/, INTCHR(48) /75/
      DATA EXTCHR(49) /1HL/, INTCHR(49) /76/
      DATA EXTCHR(50) /1HM/, INTCHR(50) /77/
      DATA EXTCHR(51) /1HN/, INTCHR(51) /78/
      DATA EXTCHR(52) /1HO/, INTCHR(52) /79/
      DATA EXTCHR(53) /1HP/, INTCHR(53) /80/
      DATA EXTCHR(54) /1HQ/, INTCHR(54) /81/
      DATA EXTCHR(55) /1HR/, INTCHR(55) /82/
      DATA EXTCHR(56) /1HS/, INTCHR(56) /83/
      DATA EXTCHR(57) /1HT/, INTCHR(57) /84/
      DATA EXTCHR(58) /1HU/, INTCHR(58) /85/
      DATA EXTCHR(59) /1HV/, INTCHR(59) /86/
      DATA EXTCHR(60) /1HW/, INTCHR(60) /87/
      DATA EXTCHR(61) /1HX/, INTCHR(61) /88/
      DATA EXTCHR(62) /1HY/, INTCHR(62) /89/
      DATA EXTCHR(63) /1HZ/, INTCHR(63) /90/
      DATA EXTCHR(64) /1H!/, INTCHR(64) /33/
      DATA EXTCHR(65) /1H"/, INTCHR(65) /34/
      DATA EXTCHR(66) /1H#/, INTCHR(66) /35/
      DATA EXTCHR(67) /1H$/, INTCHR(67) /36/
      DATA EXTCHR(68) /1H%/, INTCHR(68) /37/
      DATA EXTCHR(69) /1H&/, INTCHR(69) /38/
      DATA EXTCHR(70) /1H'/, INTCHR(70) /39/
      DATA EXTCHR(71) /1H(/, INTCHR(71) /40/
      DATA EXTCHR(72) /1H)/, INTCHR(72) /41/
      DATA EXTCHR(73) /1H*/, INTCHR(73) /42/
      DATA EXTCHR(74) /1H+/, INTCHR(74) /43/
      DATA EXTCHR(75) /1H,/, INTCHR(75) /44/
      DATA EXTCHR(76) /1H-/, INTCHR(76) /45/
      DATA EXTCHR(77) /1H./, INTCHR(77) /46/
      DATA EXTCHR(78) /1H//, INTCHR(78) /47/
      DATA EXTCHR(79) /1H:/, INTCHR(79) /58/
      DATA EXTCHR(80) /1H;/, INTCHR(80) /59/
      DATA EXTCHR(81) /1H</, INTCHR(81) /60/
      DATA EXTCHR(82) /1H=/, INTCHR(82) /61/
      DATA EXTCHR(83) /1H>/, INTCHR(83) /62/
      DATA EXTCHR(84) /1H?/, INTCHR(84) /63/
      DATA EXTCHR(85) /1H@/, INTCHR(85) /64/
      DATA EXTCHR(86) /1H[/, INTCHR(86) /91/
      DATA EXTCHR(87) /1H\/, INTCHR(87) /92/
      DATA EXTCHR(88) /1H]/, INTCHR(88) /93/
      DATA EXTCHR(89) /1H_/, INTCHR(89) /95/
      DATA EXTCHR(90) /1H</, INTCHR(90) /123/
      DATA EXTCHR(91) /1H\/, INTCHR(91) /124/
      DATA EXTCHR(92) /1H!/, INTCHR(92) /125/
      DATA EXTCHR(93) /1H6/, INTCHR(93) /8/
      DATA EXTCHR(94) /1H%/, INTCHR(94) /9/
      DATA EXTCHR(95) /1H^/, INTCHR(95) /94/
      DATA EXTCHR(96) /1H^/, INTCHR(96) /126/
      END
      SUBROUTINE CLOSE(FD)
      INTEGER FD
      INTEGER I, K
      INTEGER WRLIN, OUTMAP
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      I = FDTAB(FD+1)
      IF(.NOT.(I .EQ. 0))GOTO 23000
      RETURN
23000 CONTINUE
      FILTAB(I+0) = FILTAB(I+0) - 1
      IF(.NOT.(FILTAB(I+0) .LE. 0))GOTO 23002
      IF(.NOT.(FILTAB(I+1) .EQ. 1 .AND. FILTAB(I+4) .GT. I + 5))GOTO 230
     *04
      K = FILTAB(I+4)
      J = I + 5
23006 IF(.NOT.(J .LT. K))GOTO 23008
      FILTAB(J) = OUTMAP(FILTAB(J))
23007 J = J + 1
      GOTO 23006
23008 CONTINUE
      K = WRLIN(FILTAB(I+5), K - (I + 5), FILTAB(I+3))
      FILTAB(I+4) = I + 5
23004 CONTINUE
      CALL CLSFIL(FILTAB(I+3), FILTAB(I+1))
23002 CONTINUE
      FDTAB(FD+1) = 0
      RETURN
      END
      SUBROUTINE CLSFIL(UNIT, MD)
      INTEGER UNIT, MD
      REWIND UNIT
      RETURN
      END
      INTEGER FUNCTION CREATE(NAME, MD)
      INTEGER NAME(30)
      INTEGER MD
      INTEGER OPEN
      CREATE = OPEN(NAME, MD)
      RETURN
      END
      INTEGER FUNCTION DUP(FD)
      INTEGER FD
      INTEGER I
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      DUP = 0
23009 IF(.NOT.(DUP .LT. 8))GOTO 23011
      IF(.NOT.(FDTAB(DUP+1) .EQ. 0))GOTO 23012
      GOTO 23011
23012 CONTINUE
23010 DUP = DUP + 1
      GOTO 23009
23011 CONTINUE
      IF(.NOT.(DUP .GE. 8))GOTO 23014
      DUP = 10001
      GOTO 23015
23014 CONTINUE
      FDTAB(DUP+1) = FDTAB(FD+1)
      I = FDTAB(DUP+1)
      FILTAB(I+0) = FILTAB(I+0) + 1
23015 CONTINUE
      RETURN
      END
      SUBROUTINE ERROR(MSG)
      INTEGER MSG(80)
      CALL REMARK(MSG)
      CALL EXIT
      RETURN
      END
      SUBROUTINE EXIT
      INTEGER FD
      FD = 0
23016 IF(.NOT.(FD .LT. 8))GOTO 23018
      CALL CLOSE(FD)
23017 FD = FD + 1
      GOTO 23016
23018 CONTINUE
      STOP
      RETURN
      END
      INTEGER FUNCTION GETCH(C, FD)
      INTEGER C
      INTEGER INMAP
      INTEGER FD, I, J, K, N
      INTEGER RDLIN
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      I = FDTAB(FD+1)
      IF(.NOT.(FILTAB(I+1) .NE. 0))GOTO 23019
      CALL ERROR(42H INPUT ERROR: FILE NOT OPENED FOR READING.)
23019 CONTINUE
      IF(.NOT.(FILTAB(I+2) .EQ. 1))GOTO 23021
      GO TO 10
23021 CONTINUE
      K = FILTAB(I+4)
      IF(.NOT.(K .EQ. 0))GOTO 23023
      N = FILTAB(I+3)
      K = RDLIN(FILTAB(I+5), N)
      IF(.NOT.(K .EQ. 10003))GOTO 23025
      GO TO 10
      GOTO 23026
23025 CONTINUE
      IF(.NOT.(K .EQ. 10001))GOTO 23027
      CALL ERROR(13H INPUT ERROR.)
23027 CONTINUE
23026 CONTINUE
      J = I + 5 + K
      FILTAB(J) = 10
      J = I + 5
23029 IF(.NOT.(K .GT. 0))GOTO 23031
      FILTAB(J) = INMAP(FILTAB(J))
      K = K - 1
23030 J = J + 1
      GOTO 23029
23031 CONTINUE
      K = I + 5
      FILTAB(I+4) = K
23023 CONTINUE
      C = FILTAB(K)
      GETCH = C
      IF(.NOT.(C .EQ. 10))GOTO 23032
      FILTAB(I+4) = 0
      GOTO 23033
23032 CONTINUE
      FILTAB(I+4) = K + 1
23033 CONTINUE
      RETURN
10    FILTAB(I+2) = 1
      C = 10003
      GETCH = 10003
      RETURN
      END
      INTEGER FUNCTION INMAP(C)
      INTEGER C
      INTEGER I
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      DO23034 I = 1, 96
      IF(.NOT.(C .EQ. EXTCHR(I)))GOTO 23036
      INMAP = INTCHR(I)
      RETURN
23036 CONTINUE
23034 CONTINUE
23035 CONTINUE
      INMAP = C
      RETURN
      END
      INTEGER FUNCTION OPEN(NAME, MD)
      INTEGER NAME(30)
      INTEGER MD
      INTEGER FD, I
      INTEGER OPNFIL
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      OPEN = 10001
      FD = 0
23038 IF(.NOT.(FD .LT. 8))GOTO 23040
      IF(.NOT.(FDTAB(FD+1) .EQ. 0))GOTO 23041
      GOTO 23040
23041 CONTINUE
23039 FD = FD + 1
      GOTO 23038
23040 CONTINUE
      IF(.NOT.(FD .GE. 8))GOTO 23043
      RETURN
23043 CONTINUE
      I = 1
23045 IF(.NOT.(I .LT. 140*8))GOTO 23047
      IF(.NOT.(FILTAB(I+0) .EQ. 0))GOTO 23048
      GOTO 23047
23048 CONTINUE
23046 I = I + 140
      GOTO 23045
23047 CONTINUE
      IF(.NOT.(I .GE. 140*8))GOTO 23050
      RETURN
23050 CONTINUE
      FILTAB(I+3) = OPNFIL(NAME, MD, FD)
      IF(.NOT.(FILTAB(I+3) .EQ. 10001))GOTO 23052
      RETURN
23052 CONTINUE
      FILTAB(I+0) = 1
      FILTAB(I+1) = MD
      FILTAB(I+2) = 0
      IF(.NOT.(MD .EQ. 0))GOTO 23054
      FILTAB(I+4) = 0
      GOTO 23055
23054 CONTINUE
      FILTAB(I+4) = I + 5
23055 CONTINUE
      FDTAB(FD+1) = I
      OPEN = FD
      RETURN
      END
      INTEGER FUNCTION OPNFIL(NAME, MODE, FD)
      INTEGER NAME(30)
      INTEGER MODE, FD
      INTEGER I
      INTEGER CTOI
      I = 1
      OPNFIL=(CTOI(NAME, I))
      RETURN
      END
      INTEGER FUNCTION OUTMAP(C)
      INTEGER C
      INTEGER I
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      DO23056 I = 1, 96
      IF(.NOT.(C .EQ. INTCHR(I)))GOTO 23058
      OUTMAP = EXTCHR(I)
      RETURN
23058 CONTINUE
23056 CONTINUE
23057 CONTINUE
      OUTMAP = C
      RETURN
      END
      SUBROUTINE PUTCH(C, FD)
      INTEGER C
      INTEGER FD
      INTEGER I, J, K
      INTEGER OUTMAP, WRLIN
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      I = FDTAB(FD+1)
      IF(.NOT.(FILTAB(I+1) .NE. 1))GOTO 23060
      CALL ERROR(43H OUTPUT ERROR: FILE NOT OPENED FOR WRITING.)
23060 CONTINUE
      K = FILTAB(I+4)
      IF(.NOT.(C .EQ. 10 .OR. K .GT. I + 5 + 132 - 1))GOTO 23062
      J = I + 5
23064 IF(.NOT.(J .LT. K))GOTO 23066
      FILTAB(J) = OUTMAP(FILTAB(J))
23065 J = J + 1
      GOTO 23064
23066 CONTINUE
      IF(.NOT.(WRLIN(FILTAB(I+5), K - (I + 5), FILTAB(I+3)) .EQ. 10001))
     *GOTO 23067
      CALL ERROR(14H OUTPUT ERROR.)
23067 CONTINUE
      FILTAB(I+4) = I + 5
      GOTO 23063
23062 CONTINUE
      FILTAB(K) = C
      FILTAB(I+4) = K + 1
23063 CONTINUE
      RETURN
      END
      INTEGER FUNCTION RDLIN(BUF, N)
      INTEGER BUF(80), N
      INTEGER EXTBLK
      INTEGER I
      DATA EXTBLK /1H /
      READ(N, 100, END=10) BUF
100   FORMAT(80 A1)
      RDLIN = 80
23069 IF(.NOT.(RDLIN .GT. 0))GOTO 23071
      IF(.NOT.(BUF(RDLIN) .NE. EXTBLK))GOTO 23072
      GOTO 23071
23072 CONTINUE
23070 RDLIN = RDLIN - 1
      GOTO 23069
23071 CONTINUE
      RETURN
10    RDLIN = 10003
      RETURN
      END
      SUBROUTINE REMARK(BUF)
      INTEGER BUF(132)
      INTEGER I, N
      COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96)
      INTEGER FDTAB
      INTEGER FILTAB
      INTEGER EXTCHR
      INTEGER INTCHR
      I = 2
      I = FDTAB(I+1)
      N = FILTAB(I+3)
      WRITE(N, 10) (BUF(I), I = 1, 10)
10    FORMAT(10A 5)
      RETURN
      END
      SUBROUTINE REMOVE(NAME)
      INTEGER NAME(30)
      RETURN
      END
      INTEGER FUNCTION WRLIN(BUF, K, N)
      INTEGER BUF(132), K, N
      INTEGER I
      IF(.NOT.(K .GT. 0))GOTO 23074
      WRITE(N, 100) (BUF(I), I = 1, K)
100   FORMAT(132 A1)
      GOTO 23075
23074 CONTINUE
      WRITE(N, 200)
200   FORMAT(/)
23075 CONTINUE
      WRLIN = 0
      RETURN
      END
      SUBROUTINE ADDCHR(C, BUF, BP, MAXSIZ)
      INTEGER BP, MAXSIZ
      INTEGER C, BUF(100)
      IF(.NOT.(BP .GT. MAXSIZ))GOTO 23000
      CALL BADERR(16HBUFFER OVERFLOW.)
23000 CONTINUE
      BUF(BP) = C
      BP = BP + 1
      RETURN
      END
      SUBROUTINE ADDSTR(S, BUF, BP, MAXSIZ)
      INTEGER S(100), BUF(100)
      INTEGER BP, MAXSIZ
      INTEGER I
      I = 1
23002 IF(.NOT.(S(I) .NE. 10002))GOTO 23004
      CALL ADDCHR(S(I), BUF, BP, MAXSIZ)
23003 I = I + 1
      GOTO 23002
23004 CONTINUE
      RETURN
      END
      INTEGER FUNCTION ALLDIG(STR)
      INTEGER TYPE
      INTEGER STR(100)
      INTEGER I
      ALLDIG = 0
      IF(.NOT.(STR(1) .EQ. 10002))GOTO 23005
      RETURN
23005 CONTINUE
      I = 1
23007 IF(.NOT.(STR(I) .NE. 10002))GOTO 23009
      IF(.NOT.(TYPE(STR(I)) .NE. 2))GOTO 23010
      RETURN
23010 CONTINUE
23008 I = I + 1
      GOTO 23007
23009 CONTINUE
      ALLDIG = 1
      RETURN
      END
      SUBROUTINE BADERR(MSG)
      INTEGER MSG(100)
      CALL SYNERR(MSG)
      CALL EXIT
      RETURN
      END
      SUBROUTINE BALPAR
      INTEGER GETTOK, GNBTOK
      INTEGER T, TOKEN(200)
      INTEGER NLPAR
      IF(.NOT.(GNBTOK(TOKEN, 200) .NE. 40))GOTO 23012
      CALL SYNERR(19HMISSING LEFT PAREN.)
      RETURN
23012 CONTINUE
      CALL OUTSTR(TOKEN)
      NLPAR = 1
23014 CONTINUE
      T = GETTOK(TOKEN, 200)
      IF(.NOT.(T.EQ.59 .OR. T.EQ.123 .OR. T.EQ.125 .OR. T.EQ.10003))GOTO
     * 23017
      CALL PBSTR(TOKEN)
      GOTO 23016
23017 CONTINUE
      IF(.NOT.(T .EQ. 10))GOTO 23019
      TOKEN(1) = 10002
      GOTO 23020
23019 CONTINUE
      IF(.NOT.(T .EQ. 40))GOTO 23021
      NLPAR = NLPAR + 1
      GOTO 23022
23021 CONTINUE
      IF(.NOT.(T .EQ. 41))GOTO 23023
      NLPAR = NLPAR - 1
23023 CONTINUE
23022 CONTINUE
23020 CONTINUE
      CALL OUTSTR(TOKEN)
23015 IF(.NOT.(NLPAR .LE. 0))GOTO 23014
23016 CONTINUE
      IF(.NOT.(NLPAR .NE. 0))GOTO 23025
      CALL SYNERR(33HMISSING PARENTHESIS IN CONDITION.)
23025 CONTINUE
      RETURN
      END
      SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN)
      INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN
      INTEGER I, N, ALLDIG, CTOI
      INTEGER T, PTOKEN(200), GNBTOK
      COMMON /CGOTO/ XFER
      INTEGER XFER
      N = 0
      T = GNBTOK(PTOKEN, 200)
      IF(.NOT.(ALLDIG(PTOKEN) .EQ. 1))GOTO 23027
      I = 1
      N = CTOI(PTOKEN, I) - 1
      GOTO 23028
23027 CONTINUE
      IF(.NOT.(T .NE. 59))GOTO 23029
      CALL PBSTR(PTOKEN)
23029 CONTINUE
23028 CONTINUE
      I = SP
23031 IF(.NOT.(I .GT. 0))GOTO 23033
      IF(.NOT.(LEXTYP(I) .EQ. 10263 .OR. LEXTYP(I) .EQ. 10266 .OR. LEXTY
     *P(I) .EQ. 10268 .OR. LEXTYP(I) .EQ. 10269))GOTO 23034
      IF(.NOT.(N .GT. 0))GOTO 23036
      N = N - 1
      GOTO 23032
23036 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10264))GOTO 23038
      CALL OUTGO(LABVAL(I)+1)
      GOTO 23039
23038 CONTINUE
      CALL OUTGO(LABVAL(I))
23039 CONTINUE
23037 CONTINUE
      XFER = 1
      RETURN
23034 CONTINUE
23032 I = I - 1
      GOTO 23031
23033 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10264))GOTO 23040
      CALL SYNERR(14HILLEGAL BREAK.)
      GOTO 23041
23040 CONTINUE
      CALL SYNERR(13HILLEGAL NEXT.)
23041 CONTINUE
      RETURN
      END
      INTEGER FUNCTION CTOI(IN, I)
      INTEGER IN(100)
      INTEGER I
23042 IF(.NOT.(IN(I) .EQ. 32 .OR. IN(I) .EQ. 9))GOTO 23043
      I = I + 1
      GOTO 23042
23043 CONTINUE
      CTOI = 0
23044 IF(.NOT.(IN(I) .NE. 10002))GOTO 23046
      IF(.NOT.(IN(I) .LT. 48 .OR. IN(I) .GT. 57))GOTO 23047
      GOTO 23046
23047 CONTINUE
      CTOI = 10 * CTOI + IN(I) - 48
23045 I = I + 1
      GOTO 23044
23046 CONTINUE
      RETURN
      END
      INTEGER FUNCTION DEFTOK(TOKEN, TOKSIZ, FD)
      INTEGER GTOK
      INTEGER FD, TOKSIZ
      INTEGER DEFN(200), T, TOKEN(200)
      INTEGER LOOKUP
      T=GTOK(TOKEN, TOKSIZ, FD)
23049 IF(.NOT.(T.NE.10003))GOTO 23051
      IF(.NOT.(T .NE. 10100))GOTO 23052
      GOTO 23051
23052 CONTINUE
      IF(.NOT.(LOOKUP(TOKEN, DEFN) .EQ. 0))GOTO 23054
      GOTO 23051
23054 CONTINUE
      IF(.NOT.(DEFN(1) .EQ. 10010))GOTO 23056
      CALL GETDEF(TOKEN, TOKSIZ, DEFN, 200, FD)
      CALL INSTAL(TOKEN, DEFN)
      GOTO 23057
23056 CONTINUE
      CALL PBSTR(DEFN)
23057 CONTINUE
23050 T=GTOK(TOKEN, TOKSIZ, FD)
      GOTO 23049
23051 CONTINUE
      DEFTOK = T
      IF(.NOT.(DEFTOK .EQ. 10100))GOTO 23058
      CALL FOLD(TOKEN)
23058 CONTINUE
      RETURN
      END
      SUBROUTINE FOLD(TOKEN)
      INTEGER TOKEN(100)
      INTEGER I
      I = 1
23060 IF(.NOT.(TOKEN(I) .NE. 10002))GOTO 23062
      IF(.NOT.(TOKEN(I) .GE. 65 .AND. TOKEN(I) .LE. 90))GOTO 23063
      TOKEN(I) = TOKEN(I) - 65 + 97
23063 CONTINUE
23061 I = I + 1
      GOTO 23060
23062 CONTINUE
      RETURN
      END
      SUBROUTINE DOCODE(LAB)
      INTEGER LABGEN
      INTEGER LAB
      COMMON /CGOTO/ XFER
      INTEGER XFER
      INTEGER SDO(3)
      DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/10002/
      XFER = 0
      CALL OUTTAB
      CALL OUTSTR(SDO)
      LAB = LABGEN(2)
      CALL OUTNUM(LAB)
      CALL EATUP
      CALL OUTDON
      RETURN
      END
      SUBROUTINE DOSTAT(LAB)
      INTEGER LAB
      CALL OUTCON(LAB)
      CALL OUTCON(LAB+1)
      RETURN
      END
      SUBROUTINE EATUP
      INTEGER GETTOK
      INTEGER PTOKEN(200), T, TOKEN(200)
      INTEGER NLPAR
      NLPAR = 0
23065 CONTINUE
      T = GETTOK(TOKEN, 200)
      IF(.NOT.(T .EQ. 59 .OR. T .EQ. 10))GOTO 23068
      GOTO 23067
23068 CONTINUE
      IF(.NOT.(T .EQ. 125 .OR. T .EQ. 123))GOTO 23070
      CALL PBSTR(TOKEN)
      GOTO 23067
23070 CONTINUE
      IF(.NOT.(T .EQ. 10003))GOTO 23072
      CALL SYNERR(15HUNEXPECTED EOF.)
      CALL PBSTR(TOKEN)
      GOTO 23067
23072 CONTINUE
      IF(.NOT.(T .EQ. 44 .OR. T .EQ. 43 .OR. T .EQ. 45 .OR. T .EQ. 42 .O
     *R. T .EQ. 40 .OR. T .EQ. 38 .OR. T .EQ. 124 .OR. T .EQ. 33 .OR. T
     *.EQ. 61 .OR. T .EQ. 95 ))GOTO 23074
23076 IF(.NOT.(GETTOK(PTOKEN, 200) .EQ. 10))GOTO 23077
      GOTO 23076
23077 CONTINUE
      CALL PBSTR(PTOKEN)
      IF(.NOT.(T .EQ. 95))GOTO 23078
      TOKEN(1) = 10002
23078 CONTINUE
23074 CONTINUE
      IF(.NOT.(T .EQ. 40))GOTO 23080
      NLPAR = NLPAR + 1
      GOTO 23081
23080 CONTINUE
      IF(.NOT.(T .EQ. 41))GOTO 23082
      NLPAR = NLPAR - 1
23082 CONTINUE
23081 CONTINUE
      CALL OUTSTR(TOKEN)
23066 IF(.NOT.(NLPAR .LT. 0))GOTO 23065
23067 CONTINUE
      IF(.NOT.(NLPAR .NE. 0))GOTO 23084
      CALL SYNERR(23HUNBALANCED PARENTHESES.)
23084 CONTINUE
      RETURN
      END
      SUBROUTINE ELSEIF(LAB)
      INTEGER LAB
      CALL OUTGO(LAB+1)
      CALL OUTCON(LAB)
      RETURN
      END
      INTEGER FUNCTION EQUAL(STR1, STR2)
      INTEGER STR1(100), STR2(100)
      INTEGER I
      I = 1
23086 IF(.NOT.(STR1(I) .EQ. STR2(I)))GOTO 23088
      IF(.NOT.(STR1(I) .EQ. 10002))GOTO 23089
      EQUAL = 1
      RETURN
23089 CONTINUE
23087 I = I + 1
      GOTO 23086
23088 CONTINUE
      EQUAL = 0
      RETURN
      END
      SUBROUTINE FORCOD(LAB)
      INTEGER GETTOK, GNBTOK
      INTEGER T, TOKEN(200)
      INTEGER LENGTH, LABGEN
      INTEGER I, J, LAB, NLPAR
      COMMON /CFOR/ FORDEP, FORSTK(200)
      INTEGER FORDEP
      INTEGER FORSTK
      INTEGER IFNOT(9)
      DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/40/,IFNOT(4)/46/,IFNOT(5
     *)/110/,IFNOT(6)/111/,IFNOT(7)/116/,IFNOT(8)/46/,IFNOT(9)/10002/
      LAB = LABGEN(3)
      CALL OUTCON(0)
      IF(.NOT.(GNBTOK(TOKEN, 200) .NE. 40))GOTO 23091
      CALL SYNERR(19HMISSING LEFT PAREN.)
      RETURN
23091 CONTINUE
      IF(.NOT.(GNBTOK(TOKEN, 200) .NE. 59))GOTO 23093
      CALL PBSTR(TOKEN)
      CALL OUTTAB
      CALL EATUP
      CALL OUTDON
23093 CONTINUE
      IF(.NOT.(GNBTOK(TOKEN, 200) .EQ. 59))GOTO 23095
      CALL OUTCON(LAB)
      GOTO 23096
23095 CONTINUE
      CALL PBSTR(TOKEN)
      CALL OUTNUM(LAB)
      CALL OUTTAB
      CALL OUTSTR(IFNOT)
      CALL OUTCH(40)
      NLPAR = 0
23097 IF(.NOT.(NLPAR .GE. 0))GOTO 23098
      T = GETTOK(TOKEN, 200)
      IF(.NOT.(T .EQ. 59))GOTO 23099
      GOTO 23098
23099 CONTINUE
      IF(.NOT.(T .EQ. 40))GOTO 23101
      NLPAR = NLPAR + 1
      GOTO 23102
23101 CONTINUE
      IF(.NOT.(T .EQ. 41))GOTO 23103
      NLPAR = NLPAR - 1
23103 CONTINUE
23102 CONTINUE
      IF(.NOT.(T .EQ. 10003))GOTO 23105
      CALL PBSTR(TOKEN)
      RETURN
23105 CONTINUE
      IF(.NOT.(T .NE. 10 .AND. T .NE. 95))GOTO 23107
      CALL OUTSTR(TOKEN)
23107 CONTINUE
      GOTO 23097
23098 CONTINUE
      CALL OUTCH(41)
      CALL OUTCH(41)
      CALL OUTGO(LAB+2)
      IF(.NOT.(NLPAR .LT. 0))GOTO 23109
      CALL SYNERR(19HINVALID FOR CLAUSE.)
23109 CONTINUE
23096 CONTINUE
      FORDEP = FORDEP + 1
      J = 1
      I = 1
23111 IF(.NOT.(I .LT. FORDEP))GOTO 23113
      J = J + LENGTH(FORSTK(J)) + 1
23112 I = I + 1
      GOTO 23111
23113 CONTINUE
      FORSTK(J) = 10002
      NLPAR = 0
      T = GNBTOK(TOKEN, 200)
      CALL PBSTR(TOKEN)
23114 IF(.NOT.(NLPAR .GE. 0))GOTO 23115
      T = GETTOK(TOKEN, 200)
      IF(.NOT.(T .EQ. 40))GOTO 23116
      NLPAR = NLPAR + 1
      GOTO 23117
23116 CONTINUE
      IF(.NOT.(T .EQ. 41))GOTO 23118
      NLPAR = NLPAR - 1
23118 CONTINUE
23117 CONTINUE
      IF(.NOT.(T .EQ. 10003))GOTO 23120
      CALL PBSTR(TOKEN)
      GOTO 23115
23120 CONTINUE
      IF(.NOT.(NLPAR .GE. 0 .AND. T .NE. 10 .AND. T .NE. 95))GOTO 23122
      IF(.NOT.(J + LENGTH(TOKEN) .GE. 200))GOTO 23124
      CALL BADERR(20HFOR CLAUSE TOO LONG.)
23124 CONTINUE
      CALL SCOPY(TOKEN, 1, FORSTK, J)
      J = J + LENGTH(TOKEN)
23122 CONTINUE
      GOTO 23114
23115 CONTINUE
      LAB = LAB + 1
      RETURN
      END
      SUBROUTINE FORS(LAB)
      INTEGER LENGTH
      INTEGER I, J, LAB
      COMMON /CFOR/ FORDEP, FORSTK(200)
      INTEGER FORDEP
      INTEGER FORSTK
      COMMON /CGOTO/ XFER
      INTEGER XFER
      XFER = 0
      CALL OUTNUM(LAB)
      J = 1
      I = 1
23126 IF(.NOT.(I .LT. FORDEP))GOTO 23128
      J = J + LENGTH(FORSTK(J)) + 1
23127 I = I + 1
      GOTO 23126
23128 CONTINUE
      IF(.NOT.(LENGTH(FORSTK(J)) .GT. 0))GOTO 23129
      CALL OUTTAB
      CALL OUTSTR(FORSTK(J))
      CALL OUTDON
23129 CONTINUE
      CALL OUTGO(LAB-1)
      CALL OUTCON(LAB+1)
      FORDEP = FORDEP - 1
      RETURN
      END
      SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD)
      INTEGER GTOK, NGETCH
      INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ
      INTEGER C, DEFN(200), TOKEN(200), T, PTOKEN(200)
      CALL SKPBLK(FD)
      C = GTOK(PTOKEN, 200, FD)
      IF(.NOT.(C .EQ. 40))GOTO 23131
      T = 40
      GOTO 23132
23131 CONTINUE
      T = 32
      CALL PBSTR(PTOKEN)
23132 CONTINUE
      CALL SKPBLK(FD)
      IF(.NOT.(GTOK(TOKEN, TOKSIZ, FD) .NE. 10100))GOTO 23133
      CALL BADERR(22HNON-ALPHANUMERIC NAME.)
23133 CONTINUE
      CALL SKPBLK(FD)
      C = GTOK(PTOKEN, 200, FD)
      IF(.NOT.(T .EQ. 32))GOTO 23135
      CALL PBSTR(PTOKEN)
      I = 1
23137 CONTINUE
      C = NGETCH(C, FD)
      IF(.NOT.(I .GT. DEFSIZ))GOTO 23140
      CALL BADERR(20HDEFINITION TOO LONG.)
23140 CONTINUE
      DEFN(I) = C
      I = I + 1
23138 IF(.NOT.(C .EQ. 35 .OR. C .EQ. 10 .OR. C .EQ. 10003))GOTO 23137
23139 CONTINUE
      IF(.NOT.(C .EQ. 35))GOTO 23142
      CALL PUTBAK(C)
23142 CONTINUE
      GOTO 23136
23135 CONTINUE
      IF(.NOT.(T .EQ. 40))GOTO 23144
      IF(.NOT.(C .NE. 44))GOTO 23146
      CALL BADERR(24HMISSING COMMA IN DEFINE.)
23146 CONTINUE
      NLPAR = 0
      I = 1
23148 IF(.NOT.(NLPAR .GE. 0))GOTO 23150
      IF(.NOT.(I .GT. DEFSIZ))GOTO 23151
      CALL BADERR(20HDEFINITION TOO LONG.)
      GOTO 23152
23151 CONTINUE
      IF(.NOT.(NGETCH(DEFN(I), FD) .EQ. 10003))GOTO 23153
      CALL BADERR(20HMISSING RIGHT PAREN.)
      GOTO 23154
23153 CONTINUE
      IF(.NOT.(DEFN(I) .EQ. 40))GOTO 23155
      NLPAR = NLPAR + 1
      GOTO 23156
23155 CONTINUE
      IF(.NOT.(DEFN(I) .EQ. 41))GOTO 23157
      NLPAR = NLPAR - 1
23157 CONTINUE
23156 CONTINUE
23154 CONTINUE
23152 CONTINUE
23149 I = I + 1
      GOTO 23148
23150 CONTINUE
      GOTO 23145
23144 CONTINUE
      CALL BADERR(19HGETDEF IS CONFUSED.)
23145 CONTINUE
23136 CONTINUE
      DEFN(I-1) = 10002
      RETURN
      END
      INTEGER FUNCTION GETTOK(TOKEN, TOKSIZ)
      INTEGER EQUAL, OPEN, LENGTH
      INTEGER T, I, TOKSIZ, F
      INTEGER DEFTOK
      INTEGER NAME(30), TOKEN(200)
      COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5), FNAMP, FNAMES(150)
      INTEGER LEVEL
      INTEGER LINECT
      INTEGER INFILE
      INTEGER FNAMP
      INTEGER FNAMES
      COMMON /CFNAME/ FCNAME(30)
      INTEGER FCNAME
      INTEGER FNCN(9)
      INTEGER INCL(8)
      DATA FNCN(1)/102/,FNCN(2)/117/,FNCN(3)/110/,FNCN(4)/99/,FNCN(5)/11
     *6/,FNCN(6)/105/,FNCN(7)/111/,FNCN(8)/110/,FNCN(9)/10002/
      DATA INCL(1)/105/,INCL(2)/110/,INCL(3)/99/,INCL(4)/108/,INCL(5)/11
     *7/,INCL(6)/100/,INCL(7)/101/,INCL(8)/10002/
23159 IF(.NOT.(LEVEL .GT. 0))GOTO 23161
      F = INFILE(LEVEL)
      GETTOK = DEFTOK(TOKEN, TOKSIZ, F)
23162 IF(.NOT.(GETTOK .NE. 10003))GOTO 23164
      IF(.NOT.(EQUAL(TOKEN, FNCN) .EQ. 1))GOTO 23165
      CALL SKPBLK(INFILE(LEVEL))
      T = DEFTOK(FCNAME, 30, F)
      CALL PBSTR(FCNAME)
      IF(.NOT.(T .NE. 10100))GOTO 23167
      CALL SYNERR(22HMISSING FUNCTION NAME.)
23167 CONTINUE
      CALL PUTBAK(32)
      RETURN
23165 CONTINUE
      IF(.NOT.(EQUAL(TOKEN, INCL) .EQ. 0))GOTO 23169
      RETURN
23169 CONTINUE
23166 CONTINUE
      CALL SKPBLK(INFILE(LEVEL))
      I = 1
23171 CONTINUE
      T = DEFTOK(NAME(I), 30, F)
      IF(.NOT.(T .EQ. 10 .OR. T .EQ. 59))GOTO 23174
      CALL PBSTR(NAME(I))
      GOTO 23173
23174 CONTINUE
23172 I = LENGTH(NAME) + 1
      GOTO 23171
23173 CONTINUE
      NAME(I) = 10002
      IF(.NOT.(LEVEL .GE. 5))GOTO 23176
      CALL SYNERR(27HINCLUDES NESTED TOO DEEPLY.)
      GOTO 23177
23176 CONTINUE
      INFILE(LEVEL+1) = OPEN(NAME, 0)
      LINECT(LEVEL+1) = 1
      IF(.NOT.(INFILE(LEVEL+1) .EQ. 10001))GOTO 23178
      CALL SYNERR(19HCAN'T OPEN INCLUDE.)
      GOTO 23179
23178 CONTINUE
      LEVEL = LEVEL + 1
      IF(.NOT.(FNAMP + I .LE. 150))GOTO 23180
      CALL SCOPY(NAME, 1, FNAMES, FNAMP)
      FNAMP = FNAMP + I
23180 CONTINUE
      F = INFILE(LEVEL)
23179 CONTINUE
23177 CONTINUE
23163  GETTOK = DEFTOK(TOKEN, TOKSIZ, F)
      GOTO 23162
23164 CONTINUE
      IF(.NOT.(LEVEL .GT. 1))GOTO 23182
      CALL CLOSE(INFILE(LEVEL))
      FNAMP = FNAMP - 1
23184 IF(.NOT.(FNAMP .GT. 1))GOTO 23186
      IF(.NOT.(FNAMES(FNAMP-1) .EQ. 10002))GOTO 23187
      GOTO 23186
23187 CONTINUE
23185 FNAMP = FNAMP - 1
      GOTO 23184
23186 CONTINUE
23182 CONTINUE
23160 LEVEL = LEVEL - 1
      GOTO 23159
23161 CONTINUE
      TOKEN(1) = 10003
      TOKEN(2) = 10002
      GETTOK = 10003
      RETURN
      END
      INTEGER FUNCTION GNBTOK(TOKEN, TOKSIZ)
      INTEGER TOKSIZ
      INTEGER TOKEN(200), GETTOK
      COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5), FNAMP, FNAMES(150)
      INTEGER LEVEL
      INTEGER LINECT
      INTEGER INFILE
      INTEGER FNAMP
      INTEGER FNAMES
      CALL SKPBLK(INFILE(LEVEL))
      GNBTOK = GETTOK(TOKEN, TOKSIZ)
      RETURN
      END
      INTEGER FUNCTION GTOK(LEXSTR, TOKSIZ, FD)
      INTEGER NGETCH, TYPE
      INTEGER FD, I, B, N, TOKSIZ, ITOC
      INTEGER C, LEXSTR(200)
      COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5), FNAMP, FNAMES(150)
      INTEGER LEVEL
      INTEGER LINECT
      INTEGER INFILE
      INTEGER FNAMP
      INTEGER FNAMES
      C = NGETCH(LEXSTR(1), FD)
      IF(.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23189
      LEXSTR(1) = 32
23191 IF(.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23192
      C = NGETCH(C, FD)
      GOTO 23191
23192 CONTINUE
      IF(.NOT.(C .EQ. 35))GOTO 23193
23195 IF(.NOT.(NGETCH(C, FD) .NE. 10))GOTO 23196
      GOTO 23195
23196 CONTINUE
23193 CONTINUE
      IF(.NOT.(C .NE. 10))GOTO 23197
      CALL PUTBAK(C)
      GOTO 23198
23197 CONTINUE
      LEXSTR(1) = 10
23198 CONTINUE
      LEXSTR(2) = 10002
      GTOK = LEXSTR(1)
      RETURN
23189 CONTINUE
      I = 1
      GTOK = TYPE(C)
      IF(.NOT.(GTOK .EQ. 1))GOTO 23199
      I = 1
23201 IF(.NOT.(I .LT. TOKSIZ - 2))GOTO 23203
      GTOK = TYPE(NGETCH(LEXSTR(I+1), FD))
      IF(.NOT.(GTOK .NE. 1 .AND. GTOK .NE. 2 .AND. GTOK .NE. 95 .AND. GT
     *OK .NE. 46))GOTO 23204
      GOTO 23203
23204 CONTINUE
23202 I = I + 1
      GOTO 23201
23203 CONTINUE
      CALL PUTBAK(LEXSTR(I+1))
      GTOK = 10100
      GOTO 23200
23199 CONTINUE
      IF(.NOT.(GTOK .EQ. 2))GOTO 23206
      B = C - 48
      I = 1
23208 IF(.NOT.(I .LT. TOKSIZ - 2))GOTO 23210
      IF(.NOT.(TYPE(NGETCH(LEXSTR(I+1), FD)) .NE. 2))GOTO 23211
      GOTO 23210
23211 CONTINUE
      B = 10*B + LEXSTR(I+1) - 48
23209 I = I + 1
      GOTO 23208
23210 CONTINUE
      IF(.NOT.(LEXSTR(I+1) .EQ. 37 .AND. B .GE. 2 .AND. B .LE. 36))GOTO
     *23213
      N = 0
23215 CONTINUE
      C = NGETCH(LEXSTR(1), FD)
      IF(.NOT.(C .GE. 97 .AND. C .LE. 122))GOTO 23218
      C = C - 97 + 57 + 1
      GOTO 23219
23218 CONTINUE
      IF(.NOT.(C .GE. 65 .AND. C .LE. 90))GOTO 23220
      C = C - 65 + 57 + 1
23220 CONTINUE
23219 CONTINUE
      IF(.NOT.(C .LT. 48 .OR. C .GE. 48 + B))GOTO 23222
      GOTO 23217
23222 CONTINUE
23216 N = B*N + C - 48
      GOTO 23215
23217 CONTINUE
      CALL PUTBAK(LEXSTR(1))
      I = ITOC(N, LEXSTR, TOKSIZ)
      GOTO 23214
23213 CONTINUE
      CALL PUTBAK(LEXSTR(I+1))
23214 CONTINUE
      GTOK = 2
      GOTO 23207
23206 CONTINUE
      IF(.NOT.(C .EQ. 91))GOTO 23224
      LEXSTR(1) = 123
      GTOK = 123
      GOTO 23225
23224 CONTINUE
      IF(.NOT.(C .EQ. 93))GOTO 23226
      LEXSTR(1) = 125
      GTOK = 125
      GOTO 23227
23226 CONTINUE
      IF(.NOT.(C .EQ. 36))GOTO 23228
      IF(.NOT.(NGETCH(LEXSTR(2), FD) .EQ. 40))GOTO 23230
      LEXSTR(1) = 123
      GTOK = 123
      GOTO 23231
23230 CONTINUE
      IF(.NOT.(LEXSTR(2) .EQ. 41))GOTO 23232
      LEXSTR(1) = 125
      GTOK = 125
      GOTO 23233
23232 CONTINUE
      CALL PUTBAK(LEXSTR(2))
23233 CONTINUE
23231 CONTINUE
      GOTO 23229
23228 CONTINUE
      IF(.NOT.(C .EQ. 39 .OR. C .EQ. 34))GOTO 23234
      I = 2
23236 IF(.NOT.(NGETCH(LEXSTR(I), FD) .NE. LEXSTR(1)))GOTO 23238
      IF(.NOT.(LEXSTR(I) .EQ. 95))GOTO 23239
      IF(.NOT.(NGETCH(C, FD) .EQ. 10))GOTO 23241
23243 IF(.NOT.(C .EQ. 10 .OR. C .EQ. 32 .OR. C .EQ. 9))GOTO 23244
      C = NGETCH(C, FD)
      GOTO 23243
23244 CONTINUE
      LEXSTR(I) = C
      GOTO 23242
23241 CONTINUE
      CALL PUTBAK(C)
23242 CONTINUE
23239 CONTINUE
      IF(.NOT.(LEXSTR(I) .EQ. 10 .OR. I .GE. TOKSIZ-1))GOTO 23245
      CALL SYNERR(14HMISSING QUOTE.)
      LEXSTR(I) = LEXSTR(1)
      CALL PUTBAK(10)
      GOTO 23238
23245 CONTINUE
23237 I = I + 1
      GOTO 23236
23238 CONTINUE
      GOTO 23235
23234 CONTINUE
      IF(.NOT.(C .EQ. 35))GOTO 23247
23249 IF(.NOT.(NGETCH(LEXSTR(1), FD) .NE. 10))GOTO 23250
      GOTO 23249
23250 CONTINUE
      GTOK = 10
      GOTO 23248
23247 CONTINUE
      IF(.NOT.(C .EQ. 62 .OR. C .EQ. 60 .OR. C .EQ. 126 .OR. C .EQ. 33 .
     *OR. C .EQ. 94 .OR. C .EQ. 61 .OR. C .EQ. 38 .OR. C .EQ. 124))GOTO
     *23251
      CALL RELATE(LEXSTR, I, FD)
23251 CONTINUE
23248 CONTINUE
23235 CONTINUE
23229 CONTINUE
23227 CONTINUE
23225 CONTINUE
23207 CONTINUE
23200 CONTINUE
      IF(.NOT.(I .GE. TOKSIZ-1))GOTO 23253
      CALL SYNERR(15HTOKEN TOO LONG.)
23253 CONTINUE
      LEXSTR(I+1) = 10002
      IF(.NOT.(LEXSTR(1) .EQ. 10))GOTO 23255
      LINECT(LEVEL) = LINECT(LEVEL) + 1
23255 CONTINUE
      RETURN
      END
      SUBROUTINE IFCODE(LAB)
      INTEGER LABGEN
      INTEGER LAB
      COMMON /CGOTO/ XFER
      INTEGER XFER
      XFER = 0
      LAB = LABGEN(2)
      CALL IFGO(LAB)
      RETURN
      END
      SUBROUTINE IFGO(LAB)
      INTEGER LAB
      INTEGER IFNOT(9)
      DATA IFNOT(1)/105/,IFNOT(2)/102/,IFNOT(3)/40/,IFNOT(4)/46/,IFNOT(5
     *)/110/,IFNOT(6)/111/,IFNOT(7)/116/,IFNOT(8)/46/,IFNOT(9)/10002/
      CALL OUTTAB
      CALL OUTSTR(IFNOT)
      CALL BALPAR
      CALL OUTCH(41)
      CALL OUTGO(LAB)
      RETURN
      END
      SUBROUTINE INIT
      INTEGER I, DEFTYP(2)
      COMMON /COUTLN/ OUTP, OUTBUF(74)
      INTEGER OUTP
      INTEGER OUTBUF
      COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5), FNAMP, FNAMES(150)
      INTEGER LEVEL
      INTEGER LINECT
      INTEGER INFILE
      INTEGER FNAMP
      INTEGER FNAMES
      COMMON /CDEFIO/ BP, BUF(300)
      INTEGER BP
      INTEGER BUF
      COMMON /CFOR/ FORDEP, FORSTK(200)
      INTEGER FORDEP
      INTEGER FORSTK
      COMMON /CLOOK/ AVAIL, TABPTR(127), TABLE(7000)
      INTEGER AVAIL
      INTEGER TABPTR
      INTEGER TABLE
      COMMON /CFNAME/ FCNAME(30)
      INTEGER FCNAME
      COMMON /CLABEL/ LABEL
      INTEGER LABEL
      COMMON /CSBUF/ SBP, SBUF(500)
      INTEGER SBP
      INTEGER SBUF
      INTEGER DEF(7)
      INTEGER BDEF(7)
      DATA DEF(1)/100/,DEF(2)/101/,DEF(3)/102/,DEF(4)/105/,DEF(5)/110/,D
     *EF(6)/101/,DEF(7)/10002/
      DATA BDEF(1)/68/,BDEF(2)/69/,BDEF(3)/70/,BDEF(4)/73/,BDEF(5)/78/,B
     *DEF(6)/69/,BDEF(7)/10002/
      DATA DEFTYP(1), DEFTYP(2) /10010, 10002/
      OUTP = 0
      LEVEL = 1
      LINECT(1) = 1
      INFILE(1) = 0
      FNAMP = 2
      FNAMES(1) = 10002
      BP = 0
      FORDEP = 0
      AVAIL = 1
      DO23257 I = 1,127
      TABPTR(I) = 0
23257 CONTINUE
23258 CONTINUE
      CALL INSTAL(DEF, DEFTYP)
      CALL INSTAL(BDEF, DEFTYP)
      FCNAME(1) = 10002
      LABEL = 23000
      SBP = 1
      RETURN
      END
      SUBROUTINE INSTAL(NAME, DEFN)
      INTEGER DEFN(200), NAME(200), C
      INTEGER LENGTH
      INTEGER DLEN, NLEN
      COMMON /CLOOK/ AVAIL, TABPTR(127), TABLE(7000)
      INTEGER AVAIL
      INTEGER TABPTR
      INTEGER TABLE
      NLEN = LENGTH(NAME) + 1
      DLEN = LENGTH(DEFN) + 1
      IF(.NOT.(AVAIL + NLEN + DLEN .GT. 7000))GOTO 23259
      CALL PUTLIN(NAME, 2)
      CALL REMARK(23H: TOO MANY DEFINITIONS.)
      RETURN
23259 CONTINUE
      C = NAME(1)
      TABLE(AVAIL) = TABPTR(C)
      TABPTR(C) = AVAIL
      CALL SCOPY(NAME, 1, TABLE, AVAIL + 1)
      CALL SCOPY(DEFN, 1, TABLE, AVAIL + NLEN + 1)
      AVAIL = AVAIL + NLEN + DLEN + 1
      RETURN
      END
      INTEGER FUNCTION ITOC(INT, STR, SIZE)
      INTEGER IABS, MOD
      INTEGER I, INT, INTVAL, J, K, SIZE
      INTEGER STR(10)
      INTVAL = IABS(INT)
      STR(1) = 10002
      I = 1
23261 CONTINUE
      I = I + 1
      STR(I) = MOD(INTVAL, 10) + 48
      INTVAL = INTVAL / 10
23262 IF(.NOT.(INTVAL .EQ. 0 .OR. I .GE. SIZE))GOTO 23261
23263 CONTINUE
      IF(.NOT.(INT .LT. 0 .AND. I .LT. SIZE))GOTO 23264
      I = I + 1
      STR(I) = 45
23264 CONTINUE
      ITOC = I - 1
      J = 1
23266 IF(.NOT.(J .LT. I))GOTO 23268
      K = STR(I)
      STR(I) = STR(J)
      STR(J) = K
      I = I - 1
23267 J = J + 1
      GOTO 23266
23268 CONTINUE
      RETURN
      END
      SUBROUTINE LABELC(LEXSTR)
      INTEGER LEXSTR(100)
      INTEGER LENGTH
      COMMON /CGOTO/ XFER
      INTEGER XFER
      XFER = 0
      IF(.NOT.(LENGTH(LEXSTR) .EQ. 5))GOTO 23269
      IF(.NOT.(LEXSTR(1) .EQ. 50 .AND. LEXSTR(2) .EQ. 51))GOTO 23271
      CALL SYNERR(33HWARNING: POSSIBLE LABEL CONFLICT.)
23271 CONTINUE
23269 CONTINUE
      CALL OUTSTR(LEXSTR)
      CALL OUTTAB
      RETURN
      END
      INTEGER FUNCTION LABGEN(N)
      INTEGER N
      COMMON /CLABEL/ LABEL
      INTEGER LABEL
      LABGEN = LABEL
      LABEL = LABEL + N
      RETURN
      END
      INTEGER FUNCTION LENGTH(STR)
      INTEGER STR(100)
      LENGTH = 0
23273 IF(.NOT.(STR(LENGTH+1) .NE. 10002))GOTO 23275
23274 LENGTH = LENGTH + 1
      GOTO 23273
23275 CONTINUE
      RETURN
      END
      INTEGER FUNCTION LEX(LEXSTR)
      INTEGER GNBTOK
      INTEGER LEXSTR(200)
      INTEGER EQUAL
      INTEGER SIF(3)
      INTEGER SELSE(5)
      INTEGER SWHILE(6)
      INTEGER SDO(3)
      INTEGER SBREAK(6)
      INTEGER SNEXT(5)
      INTEGER SFOR(4)
      INTEGER SREPT(7)
      INTEGER SUNTIL(6)
      INTEGER SRET(7)
      INTEGER SSTR(7)
      DATA SIF(1)/105/,SIF(2)/102/,SIF(3)/10002/
      DATA SELSE(1)/101/,SELSE(2)/108/,SELSE(3)/115/,SELSE(4)/101/,SELSE
     *(5)/10002/
      DATA SWHILE(1)/119/,SWHILE(2)/104/,SWHILE(3)/105/,SWHILE(4)/108/,S
     *WHILE(5)/101/,SWHILE(6)/10002/
      DATA SDO(1)/100/,SDO(2)/111/,SDO(3)/10002/
      DATA SBREAK(1)/98/,SBREAK(2)/114/,SBREAK(3)/101/,SBREAK(4)/97/,SBR
     *EAK(5)/107/,SBREAK(6)/10002/
      DATA SNEXT(1)/110/,SNEXT(2)/101/,SNEXT(3)/120/,SNEXT(4)/116/,SNEXT
     *(5)/10002/
      DATA SFOR(1)/102/,SFOR(2)/111/,SFOR(3)/114/,SFOR(4)/10002/
      DATA SREPT(1)/114/,SREPT(2)/101/,SREPT(3)/112/,SREPT(4)/101/,SREPT
     *(5)/97/,SREPT(6)/116/,SREPT(7)/10002/
      DATA SUNTIL(1)/117/,SUNTIL(2)/110/,SUNTIL(3)/116/,SUNTIL(4)/105/,S
     *UNTIL(5)/108/,SUNTIL(6)/10002/
      DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1
     *14/,SRET(6)/110/,SRET(7)/10002/
      DATA SSTR(1)/115/,SSTR(2)/116/,SSTR(3)/114/,SSTR(4)/105/,SSTR(5)/1
     *10/,SSTR(6)/103/,SSTR(7)/10002/
      LEX = GNBTOK(LEXSTR, 200)
23276 IF(.NOT.(LEX .EQ. 10))GOTO 23278
23277  LEX = GNBTOK(LEXSTR, 200)
      GOTO 23276
23278 CONTINUE
      IF(.NOT.(LEX .EQ. 10003 .OR. LEX .EQ. 59 .OR. LEX .EQ. 123 .OR. LE
     *X .EQ. 125))GOTO 23279
      RETURN
23279 CONTINUE
      IF(.NOT.(LEX .EQ. 2))GOTO 23281
      LEX = 10260
      GOTO 23282
23281 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SIF) .EQ. 1))GOTO 23283
      LEX = 10261
      GOTO 23284
23283 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SELSE) .EQ. 1))GOTO 23285
      LEX = 10262
      GOTO 23286
23285 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SWHILE) .EQ. 1))GOTO 23287
      LEX = 10263
      GOTO 23288
23287 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SDO) .EQ. 1))GOTO 23289
      LEX = 10266
      GOTO 23290
23289 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SBREAK) .EQ. 1))GOTO 23291
      LEX = 10264
      GOTO 23292
23291 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SNEXT) .EQ. 1))GOTO 23293
      LEX = 10265
      GOTO 23294
23293 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SFOR) .EQ. 1))GOTO 23295
      LEX = 10268
      GOTO 23296
23295 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SREPT) .EQ. 1))GOTO 23297
      LEX = 10269
      GOTO 23298
23297 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SUNTIL) .EQ. 1))GOTO 23299
      LEX = 10270
      GOTO 23300
23299 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SRET) .EQ. 1))GOTO 23301
      LEX = 10271
      GOTO 23302
23301 CONTINUE
      IF(.NOT.(EQUAL(LEXSTR, SSTR) .EQ. 1))GOTO 23303
      LEX = 10274
      GOTO 23304
23303 CONTINUE
      LEX = 10267
23304 CONTINUE
23302 CONTINUE
23300 CONTINUE
23298 CONTINUE
23296 CONTINUE
23294 CONTINUE
23292 CONTINUE
23290 CONTINUE
23288 CONTINUE
23286 CONTINUE
23284 CONTINUE
23282 CONTINUE
      RETURN
      END
      INTEGER FUNCTION LOOKUP(NAME, DEFN)
      INTEGER DEFN(200), NAME(200), C
      INTEGER I, J, K
      COMMON /CLOOK/ AVAIL, TABPTR(127), TABLE(7000)
      INTEGER AVAIL
      INTEGER TABPTR
      INTEGER TABLE
      C = NAME(1)
      I = TABPTR(C)
23305 IF(.NOT.(I .GT. 0))GOTO 23307
      J = I + 1
      K = 1
23308 IF(.NOT.(NAME(K) .EQ. TABLE(J) .AND. NAME(K) .NE. 10002))GOTO 2331
     *0
      J = J + 1
23309 K = K + 1
      GOTO 23308
23310 CONTINUE
      IF(.NOT.(NAME(K) .EQ. TABLE(J)))GOTO 23311
      CALL SCOPY(TABLE, J+1, DEFN, 1)
      LOOKUP = 1
      RETURN
23311 CONTINUE
23306 I = TABLE(I)
      GOTO 23305
23307 CONTINUE
      LOOKUP = 0
      RETURN
      END
      INTEGER FUNCTION NGETCH(C, FD)
      INTEGER GETCH
      INTEGER C
      INTEGER FD
      COMMON /CDEFIO/ BP, BUF(300)
      INTEGER BP
      INTEGER BUF
      IF(.NOT.(BP .GT. 0))GOTO 23313
      C = BUF(BP)
      BP = BP - 1
      GOTO 23314
23313 CONTINUE
      C = GETCH(C, FD)
23314 CONTINUE
      NGETCH = C
      RETURN
      END
      SUBROUTINE OTHERC(LEXSTR)
      INTEGER LEXSTR(100)
      COMMON /CGOTO/ XFER
      INTEGER XFER
      XFER = 0
      CALL OUTTAB
      CALL OUTSTR(LEXSTR)
      CALL EATUP
      CALL OUTDON
      RETURN
      END
      SUBROUTINE OUTCH(C)
      INTEGER C
      INTEGER I
      COMMON /COUTLN/ OUTP, OUTBUF(74)
      INTEGER OUTP
      INTEGER OUTBUF
      IF(.NOT.(OUTP .GE. 72))GOTO 23315
      CALL OUTDON
      I = 1
23317 IF(.NOT.(I .LT. 6))GOTO 23319
      OUTBUF(I) = 32
23318 I = I + 1
      GOTO 23317
23319 CONTINUE
      OUTBUF(6) = 42
      OUTP = 6
23315 CONTINUE
      OUTP = OUTP + 1
      OUTBUF(OUTP) = C
      RETURN
      END
      SUBROUTINE OUTCON(N)
      INTEGER N
      COMMON /CGOTO/ XFER
      INTEGER XFER
      COMMON /COUTLN/ OUTP, OUTBUF(74)
      INTEGER OUTP
      INTEGER OUTBUF
      INTEGER CONTIN(9)
      DATA CONTIN(1)/99/,CONTIN(2)/111/,CONTIN(3)/110/,CONTIN(4)/116/,CO
     *NTIN(5)/105/,CONTIN(6)/110/,CONTIN(7)/117/,CONTIN(8)/101/,CONTIN(9
     *)/10002/
      XFER = 0
      IF(.NOT.(N .LE. 0 .AND. OUTP .EQ. 0))GOTO 23320
      RETURN
23320 CONTINUE
      IF(.NOT.(N .GT. 0))GOTO 23322
      CALL OUTNUM(N)
23322 CONTINUE
      CALL OUTTAB
      CALL OUTSTR(CONTIN)
      CALL OUTDON
      RETURN
      END
      SUBROUTINE OUTDON
      COMMON /COUTLN/ OUTP, OUTBUF(74)
      INTEGER OUTP
      INTEGER OUTBUF
      OUTBUF(OUTP+1) = 10
      OUTBUF(OUTP+2) = 10002
      CALL PUTLIN(OUTBUF, 1)
      OUTP = 0
      RETURN
      END
      SUBROUTINE OUTGO(N)
      INTEGER N
      COMMON /CGOTO/ XFER
      INTEGER XFER
      INTEGER GOTO(6)
      DATA GOTO(1)/103/,GOTO(2)/111/,GOTO(3)/116/,GOTO(4)/111/,GOTO(5)/3
     *2/,GOTO(6)/10002/
      IF(.NOT.(XFER .EQ. 1))GOTO 23324
      RETURN
23324 CONTINUE
      CALL OUTTAB
      CALL OUTSTR(GOTO)
      CALL OUTNUM(N)
      CALL OUTDON
      RETURN
      END
      SUBROUTINE OUTNUM(N)
      INTEGER CHARS(10)
      INTEGER I, M
      M = N
      I = 0
23326 CONTINUE
      I = I + 1
      CHARS(I) = MOD(M, 10) + 48
      M = M / 10
23327 IF(.NOT.(M .EQ. 0 .OR. I .GE. 10))GOTO 23326
23328 CONTINUE
23329 IF(.NOT.(I .GT. 0))GOTO 23331
      CALL OUTCH(CHARS(I))
23330 I = I - 1
      GOTO 23329
23331 CONTINUE
      RETURN
      END
      SUBROUTINE OUTSTR(STR)
      INTEGER C, STR(100)
      INTEGER I, J
      I = 1
23332 IF(.NOT.(STR(I) .NE. 10002))GOTO 23334
      C = STR(I)
      IF(.NOT.(C .NE. 39 .AND. C .NE. 34))GOTO 23335
      IF(.NOT.(C .GE. 97 .AND. C .LE. 122))GOTO 23337
      C = C - 97 + 65
23337 CONTINUE
      CALL OUTCH(C)
      GOTO 23336
23335 CONTINUE
      I = I + 1
      J = I
23339 IF(.NOT.(STR(J) .NE. C))GOTO 23341
23340 J = J + 1
      GOTO 23339
23341 CONTINUE
      CALL OUTNUM(J-I)
      CALL OUTCH(72)
23342 IF(.NOT.(I .LT. J))GOTO 23344
      CALL OUTCH(STR(I))
23343 I = I + 1
      GOTO 23342
23344 CONTINUE
23336 CONTINUE
23333 I = I + 1
      GOTO 23332
23334 CONTINUE
      RETURN
      END
      SUBROUTINE OUTTAB
      COMMON /COUTLN/ OUTP, OUTBUF(74)
      INTEGER OUTP
      INTEGER OUTBUF
23345 IF(.NOT.(OUTP .LT. 6))GOTO 23346
      CALL OUTCH(32)
      GOTO 23345
23346 CONTINUE
      RETURN
      END
      SUBROUTINE PARSE
      INTEGER LEXSTR(200)
      INTEGER LEX
      INTEGER LAB, LABVAL(100), LEXTYP(100), SP, TOKEN
      COMMON /CGOTO/ XFER
      INTEGER XFER
      COMMON /CFOR/ FORDEP, FORSTK(200)
      INTEGER FORDEP
      INTEGER FORSTK
      COMMON /CFNAME/ FCNAME(30)
      INTEGER FCNAME
      COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5), FNAMP, FNAMES(150)
      INTEGER LEVEL
      INTEGER LINECT
      INTEGER INFILE
      INTEGER FNAMP
      INTEGER FNAMES
      COMMON /CSBUF/ SBP, SBUF(500)
      INTEGER SBP
      INTEGER SBUF
      COMMON /CLABEL/ LABEL
      INTEGER LABEL
      COMMON /CLOOK/ AVAIL, TABPTR(127), TABLE(7000)
      INTEGER AVAIL
      INTEGER TABPTR
      INTEGER TABLE
      COMMON /CDEFIO/ BP, BUF(300)
      INTEGER BP
      INTEGER BUF
      COMMON /COUTLN/ OUTP, OUTBUF(74)
      INTEGER OUTP
      INTEGER OUTBUF
      CALL INIT
      SP = 1
      LEXTYP(1) = 10003
      TOKEN = LEX(LEXSTR)
23347 IF(.NOT.(TOKEN .NE. 10003))GOTO 23349
      IF(.NOT.(TOKEN .EQ. 10261))GOTO 23350
      CALL IFCODE(LAB)
      GOTO 23351
23350 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10266))GOTO 23352
      CALL DOCODE(LAB)
      GOTO 23353
23352 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10263))GOTO 23354
      CALL WHILEC(LAB)
      GOTO 23355
23354 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10268))GOTO 23356
      CALL FORCOD(LAB)
      GOTO 23357
23356 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10269))GOTO 23358
      CALL REPCOD(LAB)
      GOTO 23359
23358 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10260))GOTO 23360
      CALL LABELC(LEXSTR)
      GOTO 23361
23360 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10262))GOTO 23362
      IF(.NOT.(LEXTYP(SP) .EQ. 10261))GOTO 23364
      CALL ELSEIF(LABVAL(SP))
      GOTO 23365
23364 CONTINUE
      CALL SYNERR(13HILLEGAL ELSE.)
23365 CONTINUE
23362 CONTINUE
23361 CONTINUE
23359 CONTINUE
23357 CONTINUE
23355 CONTINUE
23353 CONTINUE
23351 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10261 .OR. TOKEN .EQ. 10262 .OR. TOKEN .EQ. 10
     *263 .OR. TOKEN .EQ. 10268 .OR. TOKEN .EQ. 10269 .OR. TOKEN .EQ. 10
     *266 .OR. TOKEN .EQ. 10260 .OR. TOKEN .EQ. 123))GOTO 23366
      SP = SP + 1
      IF(.NOT.(SP .GT. 100))GOTO 23368
      CALL BADERR(25HSTACK OVERFLOW IN PARSER.)
23368 CONTINUE
      LEXTYP(SP) = TOKEN
      LABVAL(SP) = LAB
      GOTO 23367
23366 CONTINUE
      IF(.NOT.(TOKEN .EQ. 125))GOTO 23370
      IF(.NOT.(LEXTYP(SP) .EQ. 123))GOTO 23372
      SP = SP - 1
      GOTO 23373
23372 CONTINUE
      CALL SYNERR(20HILLEGAL RIGHT BRACE.)
23373 CONTINUE
      GOTO 23371
23370 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10267))GOTO 23374
      CALL OTHERC(LEXSTR)
      GOTO 23375
23374 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10264 .OR. TOKEN .EQ. 10265))GOTO 23376
      CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN)
      GOTO 23377
23376 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10271))GOTO 23378
      CALL RETCOD
      GOTO 23379
23378 CONTINUE
      IF(.NOT.(TOKEN .EQ. 10274))GOTO 23380
      CALL STRDCL
23380 CONTINUE
23379 CONTINUE
23377 CONTINUE
23375 CONTINUE
23371 CONTINUE
      TOKEN = LEX(LEXSTR)
      CALL PBSTR(LEXSTR)
      CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN)
23367 CONTINUE
23348 TOKEN = LEX(LEXSTR)
      GOTO 23347
23349 CONTINUE
      IF(.NOT.(SP .NE. 1))GOTO 23382
      CALL SYNERR(15HUNEXPECTED EOF.)
23382 CONTINUE
      RETURN
      END
      SUBROUTINE PBSTR(IN)
      INTEGER IN(100)
      INTEGER LENGTH
      INTEGER I
      I = LENGTH(IN)
23384 IF(.NOT.(I .GT. 0))GOTO 23386
      CALL PUTBAK(IN(I))
23385 I = I - 1
      GOTO 23384
23386 CONTINUE
      RETURN
      END
      SUBROUTINE PUTBAK(C)
      INTEGER C
      COMMON /CDEFIO/ BP, BUF(300)
      INTEGER BP
      INTEGER BUF
      BP = BP + 1
      IF(.NOT.(BP .GT. 300))GOTO 23387
      CALL BADERR(32HTOO MANY CHARACTERS PUSHED BACK.)
23387 CONTINUE
      BUF(BP) = C
      RETURN
      END
      SUBROUTINE PUTLIN(B, F)
      INTEGER B(100)
      INTEGER F, I
      I = 1
23389 IF(.NOT.(B(I) .NE. 10002))GOTO 23391
      CALL PUTCH(B(I), F)
23390 I = I + 1
      GOTO 23389
23391 CONTINUE
      RETURN
      END
      SUBROUTINE RELATE(TOKEN, LAST, FD)
      INTEGER NGETCH
      INTEGER TOKEN(100)
      INTEGER LENGTH
      INTEGER FD, LAST
      IF(.NOT.(NGETCH(TOKEN(2), FD) .NE. 61))GOTO 23392
      CALL PUTBAK(TOKEN(2))
      TOKEN(3) = 116
      GOTO 23393
23392 CONTINUE
      TOKEN(3) = 101
23393 CONTINUE
      TOKEN(4) = 46
      TOKEN(5) = 10002
      TOKEN(6) = 10002
      IF(.NOT.(TOKEN(1) .EQ. 62))GOTO 23394
      TOKEN(2) = 103
      GOTO 23395
23394 CONTINUE
      IF(.NOT.(TOKEN(1) .EQ. 60))GOTO 23396
      TOKEN(2) = 108
      GOTO 23397
23396 CONTINUE
      IF(.NOT.(TOKEN(1) .EQ. 126 .OR. TOKEN(1) .EQ. 33 .OR. TOKEN(1) .EQ
     *. 94))GOTO 23398
      IF(.NOT.(TOKEN(2) .NE. 61))GOTO 23400
      TOKEN(3) = 111
      TOKEN(4) = 116
      TOKEN(5) = 46
23400 CONTINUE
      TOKEN(2) = 110
      GOTO 23399
23398 CONTINUE
      IF(.NOT.(TOKEN(1) .EQ. 61))GOTO 23402
      IF(.NOT.(TOKEN(2) .NE. 61))GOTO 23404
      TOKEN(2) = 10002
      LAST = 1
      RETURN
23404 CONTINUE
      TOKEN(2) = 101
      TOKEN(3) = 113
      GOTO 23403
23402 CONTINUE
      IF(.NOT.(TOKEN(1) .EQ. 38))GOTO 23406
      TOKEN(2) = 97
      TOKEN(3) = 110
      TOKEN(4) = 100
      TOKEN(5) = 46
      GOTO 23407
23406 CONTINUE
      IF(.NOT.(TOKEN(1) .EQ. 124))GOTO 23408
      TOKEN(2) = 111
      TOKEN(3) = 114
      GOTO 23409
23408 CONTINUE
      TOKEN(2) = 10002
23409 CONTINUE
23407 CONTINUE
23403 CONTINUE
23399 CONTINUE
23397 CONTINUE
23395 CONTINUE
      TOKEN(1) = 46
      LAST = LENGTH(TOKEN)
      RETURN
      END
      SUBROUTINE REPCOD(LAB)
      INTEGER LABGEN
      INTEGER LAB
      CALL OUTCON(0)
      LAB = LABGEN(3)
      CALL OUTCON(LAB)
      LAB = LAB + 1
      RETURN
      END
      SUBROUTINE RETCOD
      INTEGER TOKEN(200), GNBTOK, T
      COMMON /CFNAME/ FCNAME(30)
      INTEGER FCNAME
      COMMON /CGOTO/ XFER
      INTEGER XFER
      INTEGER SRET(7)
      DATA SRET(1)/114/,SRET(2)/101/,SRET(3)/116/,SRET(4)/117/,SRET(5)/1
     *14/,SRET(6)/110/,SRET(7)/10002/
      T = GNBTOK(TOKEN, 200)
      IF(.NOT.(T .NE. 10 .AND. T .NE. 59 .AND. T .NE. 125))GOTO 23410
      CALL PBSTR(TOKEN)
      CALL OUTTAB
      CALL OUTSTR(FCNAME)
      CALL OUTCH(61)
      CALL EATUP
      CALL OUTDON
      GOTO 23411
23410 CONTINUE
      IF(.NOT.(T .EQ. 125))GOTO 23412
      CALL PBSTR(TOKEN)
23412 CONTINUE
23411 CONTINUE
      CALL OUTTAB
      CALL OUTSTR(SRET)
      CALL OUTDON
      XFER = 1
      RETURN
      END
      SUBROUTINE SCOPY(FROM, I, TO, J)
      INTEGER FROM(100), TO(100)
      INTEGER I, J, K1, K2
      K2 = J
      K1 = I
23414 IF(.NOT.(FROM(K1) .NE. 10002))GOTO 23416
      TO(K2) = FROM(K1)
      K2 = K2 + 1
23415 K1 = K1 + 1
      GOTO 23414
23416 CONTINUE
      TO(K2) = 10002
      RETURN
      END
      SUBROUTINE SKPBLK(FD)
      INTEGER FD
      INTEGER C, NGETCH
      C = NGETCH(C, FD)
23417 IF(.NOT.(C .EQ. 32 .OR. C .EQ. 9))GOTO 23419
23418 C = NGETCH(C, FD)
      GOTO 23417
23419 CONTINUE
      CALL PUTBAK(C)
      RETURN
      END
      SUBROUTINE STRDCL
      INTEGER T, TOKEN(200), GNBTOK
      INTEGER I, J, K, LEN, LENGTH, CTOI, LEX
      COMMON /CSBUF/ SBP, SBUF(500)
      INTEGER SBP
      INTEGER SBUF
      INTEGER INT(9)
      INTEGER DAT(6)
      INTEGER EOSS(5)
      DATA INT(1)/105/,INT(2)/110/,INT(3)/116/,INT(4)/101/,INT(5)/103/,I
     *NT(6)/101/,INT(7)/114/,INT(8)/32/,INT(9)/10002/
      DATA DAT(1)/100/,DAT(2)/97/,DAT(3)/116/,DAT(4)/97/,DAT(5)/32/,DAT(
     *6)/10002/
      DATA EOSS(1)/69/,EOSS(2)/79/,EOSS(3)/83/,EOSS(4)/47/,EOSS(5)/10002
     */
      T = GNBTOK(TOKEN, 200)
      IF(.NOT.(T .NE. 10100))GOTO 23420
      CALL SYNERR(21HMISSING STRING TOKEN.)
23420 CONTINUE
      CALL OUTTAB
      CALL OUTSTR(INT)
      CALL OUTSTR(TOKEN)
      CALL ADDSTR(TOKEN, SBUF, SBP, 500)
      CALL ADDCHR(10002, SBUF, SBP, 500)
      IF(.NOT.(GNBTOK(TOKEN, 200) .NE. 40))GOTO 23422
      LEN = LENGTH(TOKEN) + 1
      IF(.NOT.(TOKEN(1) .EQ. 39 .OR. TOKEN(1) .EQ. 34))GOTO 23424
      LEN = LEN - 2
23424 CONTINUE
      GOTO 23423
23422 CONTINUE
      T = GNBTOK(TOKEN, 200)
      I = 1
      LEN = CTOI(TOKEN, I)
      IF(.NOT.(TOKEN(I) .NE. 10002))GOTO 23426
      CALL SYNERR(20HINVALID STRING SIZE.)
23426 CONTINUE
      IF(.NOT.(GNBTOK(TOKEN, 200) .NE. 41))GOTO 23428
      CALL SYNERR(20HMISSING RIGHT PAREN.)
      GOTO 23429
23428 CONTINUE
      T = GNBTOK(TOKEN, 200)
23429 CONTINUE
23423 CONTINUE
      CALL OUTCH(40)
      CALL OUTNUM(LEN)
      CALL OUTCH(41)
      CALL OUTDON
      IF(.NOT.(TOKEN(1) .EQ. 39 .OR. TOKEN(1) .EQ. 34))GOTO 23430
      LEN = LENGTH(TOKEN)
      TOKEN(LEN) = 10002
      CALL ADDSTR(TOKEN(2), SBUF, SBP, 500)
      GOTO 23431
23430 CONTINUE
      CALL ADDSTR(TOKEN, SBUF, SBP, 500)
23431 CONTINUE
      CALL ADDCHR(10002, SBUF, SBP, 500)
      T = LEX(TOKEN)
      CALL PBSTR(TOKEN)
      IF(.NOT.(T .NE. 10274))GOTO 23432
      I = 1
23434 IF(.NOT.(I .LT. SBP))GOTO 23436
      CALL OUTTAB
      CALL OUTSTR(DAT)
      K = 1
      J = I + LENGTH(SBUF(I)) + 1
23437 CONTINUE
      IF(.NOT.(K .GT. 1))GOTO 23440
      CALL OUTCH(44)
23440 CONTINUE
      CALL OUTSTR(SBUF(I))
      CALL OUTCH(40)
      CALL OUTNUM(K)
      CALL OUTCH(41)
      CALL OUTCH(47)
      IF(.NOT.(SBUF(J) .EQ. 10002))GOTO 23442
      GOTO 23439
23442 CONTINUE
      CALL OUTNUM(SBUF(J))
      CALL OUTCH(47)
      K = K + 1
23438 J = J + 1
      GOTO 23437
23439 CONTINUE
      CALL PBSTR(EOSS)
23444 CONTINUE
      T = GNBTOK(TOKEN, 200)
      CALL OUTSTR(TOKEN)
23445 IF(.NOT.(T .EQ. 47))GOTO 23444
23446 CONTINUE
      CALL OUTDON
23435 I = J + 1
      GOTO 23434
23436 CONTINUE
      SBP = 1
23432 CONTINUE
      RETURN
      END
      SUBROUTINE SYNERR(MSG)
      INTEGER LC(10), MSG(100)
      INTEGER ITOC
      INTEGER I, JUNK
      COMMON /CLINE/ LEVEL, LINECT(5), INFILE(5), FNAMP, FNAMES(150)
      INTEGER LEVEL
      INTEGER LINECT
      INTEGER INFILE
      INTEGER FNAMP
      INTEGER FNAMES
      INTEGER ERRMSG(15)
      INTEGER IN(5)
      DATA ERRMSG(1)/101/,ERRMSG(2)/114/,ERRMSG(3)/114/,ERRMSG(4)/111/,E
     *RRMSG(5)/114/,ERRMSG(6)/32/,ERRMSG(7)/97/,ERRMSG(8)/116/,ERRMSG(9)
     */32/,ERRMSG(10)/108/,ERRMSG(11)/105/,ERRMSG(12)/110/,ERRMSG(13)/10
     *1/,ERRMSG(14)/32/,ERRMSG(15)/10002/
      DATA IN(1)/32/,IN(2)/105/,IN(3)/110/,IN(4)/32/,IN(5)/10002/
      CALL PUTLIN(ERRMSG, 2)
      IF(.NOT.(LEVEL .GE. 1))GOTO 23447
      I = LEVEL
      GOTO 23448
23447 CONTINUE
      I = 1
23448 CONTINUE
      JUNK = ITOC(LINECT(I), LC, 10)
      CALL PUTLIN(LC, 2)
      I = FNAMP - 1
23449 IF(.NOT.(I .GT. 1))GOTO 23451
      IF(.NOT.(FNAMES(I-1) .EQ. 10002))GOTO 23452
      CALL PUTLIN(IN, 2)
      CALL PUTLIN(FNAMES(I), 2)
      GOTO 23451
23452 CONTINUE
23450 I = I - 1
      GOTO 23449
23451 CONTINUE
      CALL PUTCH(58, 2)
      CALL PUTCH(32, 2)
      CALL REMARK(MSG)
      RETURN
      END
      INTEGER FUNCTION TYPE(C)
      INTEGER C
      IF(.NOT.(C .GE. 48 .AND. C .LE. 57))GOTO 23454
      TYPE = 2
      GOTO 23455
23454 CONTINUE
      IF(.NOT.(C .GE. 97 .AND. C .LE. 122))GOTO 23456
      TYPE = 1
      GOTO 23457
23456 CONTINUE
      IF(.NOT.(C .GE. 65 .AND. C .LE. 90))GOTO 23458
      TYPE = 1
      GOTO 23459
23458 CONTINUE
      TYPE = C
23459 CONTINUE
23457 CONTINUE
23455 CONTINUE
      RETURN
      END
      SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN)
      INTEGER LABVAL(100), LEXTYP(100), SP, TOKEN
23460 IF(.NOT.(SP .GT. 1))GOTO 23462
      IF(.NOT.(LEXTYP(SP) .EQ. 123))GOTO 23463
      GOTO 23462
23463 CONTINUE
      IF(.NOT.(LEXTYP(SP) .EQ. 10261 .AND. TOKEN .EQ. 10262))GOTO 23465
      GOTO 23462
23465 CONTINUE
      IF(.NOT.(LEXTYP(SP) .EQ. 10261))GOTO 23467
      CALL OUTCON(LABVAL(SP))
      GOTO 23468
23467 CONTINUE
      IF(.NOT.(LEXTYP(SP) .EQ. 10262))GOTO 23469
      IF(.NOT.(SP .GT. 2))GOTO 23471
      SP = SP - 1
23471 CONTINUE
      CALL OUTCON(LABVAL(SP)+1)
      GOTO 23470
23469 CONTINUE
      IF(.NOT.(LEXTYP(SP) .EQ. 10266))GOTO 23473
      CALL DOSTAT(LABVAL(SP))
      GOTO 23474
23473 CONTINUE
      IF(.NOT.(LEXTYP(SP) .EQ. 10263))GOTO 23475
      CALL WHILES(LABVAL(SP))
      GOTO 23476
23475 CONTINUE
      IF(.NOT.(LEXTYP(SP) .EQ. 10268))GOTO 23477
      CALL FORS(LABVAL(SP))
      GOTO 23478
23477 CONTINUE
      IF(.NOT.(LEXTYP(SP) .EQ. 10269))GOTO 23479
      CALL UNTILS(LABVAL(SP), TOKEN)
23479 CONTINUE
23478 CONTINUE
23476 CONTINUE
23474 CONTINUE
23470 CONTINUE
23468 CONTINUE
23461 SP = SP - 1
      GOTO 23460
23462 CONTINUE
      RETURN
      END
      SUBROUTINE UNTILS(LAB, TOKEN)
      INTEGER PTOKEN(200)
      INTEGER LEX
      INTEGER JUNK, LAB, TOKEN
      COMMON /CGOTO/ XFER
      INTEGER XFER
      XFER = 0
      CALL OUTNUM(LAB)
      IF(.NOT.(TOKEN .EQ. 10270))GOTO 23481
      JUNK = LEX(PTOKEN)
      CALL IFGO(LAB-1)
      GOTO 23482
23481 CONTINUE
      CALL OUTGO(LAB-1)
23482 CONTINUE
      CALL OUTCON(LAB+1)
      RETURN
      END
      SUBROUTINE WHILEC(LAB)
      INTEGER LABGEN
      INTEGER LAB
      CALL OUTCON(0)
      LAB = LABGEN(2)
      CALL OUTNUM(LAB)
      CALL IFGO(LAB+1)
      RETURN
      END
      SUBROUTINE WHILES(LAB)
      INTEGER LAB
      CALL OUTGO(LAB)
      CALL OUTCON(LAB+1)
      RETURN
      END
#========== DEC-10 I/O SYSTEM ==========
#-H- ALCBK.MAC 711 1980 103 2148
SEARCH%IOPARM
TITLE.%ALCBK$
; ALCBK$ - I/O SYSTEM INTERFACE TO ALLOC TO ALLOCATE CORE.  CALL IS
;%MOVE%Z,NUMBER OF WORDS
;%PUSHJ%P,ALCBK$
;% COULD NOT ALLOCATE
;%R & C POINT TO FIRST WORD OF BLOCK
;
ALCBK$::PUSH%P,A%%; SAVE THE ARGUMENT POINTER
%MOVEM%Z,NWORDS%; SET UP FOR CALL
%MOVEI%A,[EXP <-1,,0>,NWORDS]+1
%PUSHJ%P,QQALLC##%; ALLOCATE THE BLOCK
%POP%P,A%%; RESTORE A
%CAMN%R,[-1]%%; ERROR?
% POPJ%P,%%; COULD NOT ALLOCATE
%AOS%(P)%%; GIVE SKIP RETURN
%HRL%C,R%%; SAVE RESULT
%CLEARM%@R%%; CLEAR BUFFER AREA
%HRL%R,R
%ADDI%R,1
%HLR%C,R
%ADD%C,NWORDS%; POINT TO END
%BLT%R,-1(C)%%; ZAP
%HLRZS%C%%; RESET RESULT
%MOVE%R,C%%; RETURN RESULT IN R TOO
%POPJ%P,%%; RETURN, MAY SKIP
RELOC
NWORDS:%BLOCK%1
RELOC
END
#-H- ALLOC.RAT 149 1980 103 2148
# ALLOC(N) - ALLOCATE N WORDS, RETURN ADDRESS OF FIRST WORD
   INTEGER FUNCTION ALLOC(N)
   INTEGER N
   INTEGER QQALLC
 
   RETURN(QQALLC(N))
   END
#-H- AMOVE.MAC 1054 1980 103 2148
SEARCH%IOPARM
TITLE.%AMOVE
; AMOVE(NAME1:STRING,NAME2:STRING) -- DELETE NAME2 AND RENAME NAME1
; TO NAME2.
;
AMOVE::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%PUSH%P,A%%; SAVE ARGUMENT LIST POINTER
%ADDI%A,1%%; POINT TO NAME2
%PUSHJ%P,REMOVE##%; DELETE NAME2
%MOVE%A,0(P)%%; RESTORE ARGUMENT LIST
%MOVEI%T1,@0(A)%; POINT TO NAME1
%MOVEM%T1,NAMPTR
%MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1
%PUSHJ%P,QQPARS##%; PARSE THE FILE SPEC
%POP%P,A%%; RESTORE A
%CAMN%R,[ERR]%%; DIE ON ERROR
% POPJ%P,
%CLEARM%OPNBK$%%; CLEAR OTHER WORDS IN OPNBK$
%CLEARM%OPNBK$+2
%OPEN.%0,OPNBK$
% JRST%$99%%; CAN'T OPEN
%LOOKUP%0,UUOBK$##
% JRST%$99%%; CAN'T FIND
%PUSH%P,A%%; SAVE A AGAIN
%MOVEI%T1,@1(A)%; POINT TO NAME2
%MOVEM%T1,NAMPTR
%MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1
%PUSHJ%P,QQPARS%; PARSE IT
%POP%P,A%%; RESTORE A
%CAMN%R,[ERR]%%; DIE ON ERROR
% JRST%$99
%RENAME%0,UUOBK$
% SKIPA%%%; OOPS
%TDZA%R,R%%; INDICATE SUCCESS
$99:%MOVE%R,[ERR]%%; INDICATE ERROR
%RELEAS%0,0%%; RELEASE CHANNEL
%POPJ%P,%%; RETURN
RELOC
NAMPTR:%BLOCK%1
RELOC
END
#-H- ARG.MAC 94 1980 103 2148
SEARCH%IOPARM
TITLE.%ARG
; ARG(I:INT):ADDR -- RETURN ADDRESS OF ARGUMENT I
;
ARG==QQARG##
END
#-H- CALLOC 176 1980 103 2148
COMMON /CALLOC/ LOWPAG, MEMOFF, MEM(1)
   INTEGER LOWPAG%# LOWEST PAGE ALLOCATED SO FAR
   INTEGER MEMOFF%# OFFSET FOR INDICES INTO MEM
   INTEGER MEM%%# USED TO ACCESS MEMORY
#-H- CARGS 666 1980 103 2148
COMMON /CARGS/ TTYFLG, RUNPTR, INPTR, OUTPTR, ERRPTR, NARGS, ARGPTR,
   MEMOFF, MEM(1), PEEK, NMETA
   INTEGER TTYFLG%# NO IF NO COMMAND LINE WAS TYPED
   INTEGER RUNPTR%# POINTER TO NAME OF NEXT PROGRAM OR 0
   INTEGER INPTR%# POINTER TO STANDARD INPUT NAME OR 0
   INTEGER OUTPTR%# POINTER TO STANDARD OUTPUT NAME OR 0
   INTEGER ERRPTR%# POINTER TO STANDARD ERROR NAME OR 0
   INTEGER NARGS%# NUMBER OF ARGUMENTS
   INTEGER ARGPTR%# POINTER TO THE LIST OF ARGUMENTS
   INTEGER MEMOFF%# OFFSET FOR ADDRESSING MEMORY
   INTEGER MEM%%# USE TO ADDRESS MEMORY
   CHARACTER PEEK%# LOOKAHEAD CHARACTER FOR ATOK
   INTEGER NMETA%# COUNT OF META CHARACTERS IN AN ARGUMENT
#-H- CIOSYS 346 1980 103 2148
COMMON /CIOSYS/ FDTAB(MAXFILES), FBKTAB(FBLEN, MAXFILES), OPNBLK(23)
   INTEGER FDTAB%# POINTERS TO FILE BLOCKS
   INTEGER FBKTAB%# FILE BLOCKS
   INTEGER OPNBLK%# FOR UUOS
   INTEGER UUOBLK(20)%# FOR LOOKUP AND ENTER UUOS
   INTEGER FILTAB(1)%# FOR SINGLE-DIMENSION ACCESS TO FBKTAB
   EQUIVALENCE (FBKTAB(1), FILTAB(1)), (OPNBLK(4), UUOBLK(1))
#-H- CLOSE.RAT 591 1980 103 2148
INCLUDE RATDEF
INCLUDE IODEFS
 
# CLOSE - CLOSE FILE FD
SUBROUTINE CLOSE(FD)
   INTEGER FD
   INTEGER I, JUNK
   INTEGER QQCLS
   INCLUDE CIOSYS
 
   I = FDTAB(FD+1)
   FDTAB(FD+1) = 0  # MARK DESCRIPTOR FREE
   IF (I == 0)%# PERMIT CLOSE ON UNOPENED FILES
      RETURN
   FILTAB(I+USECNT) = FILTAB(I+USECNT) - 1  # DECREMENT USE COUNT
   IF (FILTAB(I+USECNT) == 0) < # CLOSE FILE IF NECESSARY
      JUNK = QQCLS(FILTAB(I+MAJOR), FILTAB(I+MINOR), FILTAB(I+USECNT))
      FILTAB(I+MAJOR) = 0   # CLEAR RELEVANT FIELDS
      FILTAB(I+MINOR) = 0
      FILTAB(I+CHANNEL) = 0
      !
   RETURN
END
#-H- CNTRL.MAC 373 1980 103 2148
SEARCH%IOPARM
TITLE.%CNTRL
; CNTRL(FD,FCT,VALUE) - PERFORM CONTROL FUNCTION ON FD.
;
CNTRL::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVE%F,@0(A)%%; POINT TO FILE BLOCK
%MOVE%F,FDTAB$##(F)
%MOVEI%F,FLTAB$##-1(F)
%MOVE%T1,@1(A)%; GET FUNCTION CODE
%MOVE%T2,@2(A)%; GET VALUE
%MOVE%C,MAJOR(F)%; GET MAJOR DEVICE NUMBER
%JRST%@CNSW$##(C)%; SWITCH TO PROPER CONTROL ROUTINE
END
#-H- COMMAN.RAT 2088 1980 103 2148
INCLUDE RATDEF
DEFINE(MAXARG,60)
 
# COMMAN - READ DEC10 COMMAND STRING FROM FILE FD
   INTEGER FUNCTION COMMAN(FD, NIARGS, NOARGS)
   INTEGER FD, NIARGS, NOARGS
   INTEGER I, NLPAR, P
   INTEGER LOC, ALLOC, LENGTH, GETCH
   CHARACTER C, ARG(MAXARG)
   INCLUDE CARGS
 
   MEMOFF = 1 - LOC(MEM(1))%# GET ADDRESSING OFFSET
   NARGS = 0
   NOARGS = -1
   ARG(1) = DQUOTE
   P = ARGPTR
   MEM(P+MEMOFF) = 0%# BREAK LINK TO PREVIOUS ARGUMENTS
   REPEAT <
      NLPAR = 0
      FOR (I = 1; GETCH(C, FD) ^= EOF; I = I + 1) < # GET AN ARGUMENT
         IF (C == NEWLINE & I > 1)
            IF (ARG(I-1) == MINUS) <%# CONTINUATION
               I = I - 2
               NEXT
               !
         IF (I >= MAXARG) <
            CALL REMARK("ARGUMENT TOO LONG.")
            RETURN(ERR)
            !
         ARG(I) = C
         IF (C == LPAREN \ C == LBRACK)
            NLPAR = NLPAR + 1
         ELSE IF (C == RPAREN \ C == RBRACK) <
            NLPAR = NLPAR - 1
            IF (NLPAR < 0) <
               CALL REMARK("MISSING LEFT PAREN OR BRACKET.")
               RETURN(ERR)
               !
            !
         IF (C == NEWLINE \ C == EQUALS \ (C == COMMA & NLPAR == 0))
            BREAK
         !
      IF (NLPAR ^= 0) <
         CALL REMARK("MISSING RIGHT PAREN OR BRACKET.")
         RETURN(ERR)
         !
      IF (I == 1 & (C == EOF \ C == NEWLINE))
         BREAK
      ARG(I) = DQUOTE
      ARG(I+1) = EOS
      I = ALLOC(LENGTH(ARG) + 3)
      IF (I == -1) <
         CALL REMARK("TOO MANY ARGUMENTS.")
         RETURN(ERR)
         !
      CALL SCOPY(ARG, 1, MEM, I + MEMOFF + 2)
      NARGS = NARGS + 1
      IF (C == EQUALS)
         IF (NOARGS == -1)
            NOARGS = NARGS
         ELSE <
            CALL REMARK("MULTIPLE OUTPUT SPECIFICATIONS NOT ALLOWED.")
            RETURN(ERR)
            !
      MEM(P+MEMOFF) = I
      MEM(I+MEMOFF) = 0
      MEM(I+MEMOFF+1) = DQUOTE
      P = I
      ! UNTIL (C == NEWLINE \ C == EOF)
   IF (NOARGS == -1) <
      NOARGS = 0
      NIARGS = NARGS
      !
   ELSE
      NIARGS = NARGS - NOARGS
   RETURN(NARGS)
   END
#-H- CON.MAC 244 1980 103 2148
SEARCH%IOPARM
TITLE.%CON
; CON(A:ADDR):INTEGER -- RETURN CONTENTS OF CELL AT ADDRESS A.
;
CON::   MOVE    1,@0(16)        ; POINT AT DESIRED CELL
        MOVE    R,0(1)          ; FETCH DESIRED CELL
        POPJ    P,              ; RETURN
END
#-H- CREATE.RAT 255 1980 103 2148
INCLUDE RATDEF
INCLUDE IODEFS
 
# CREATE - CREATE FILE NAME AND OPEN ACCORDING TO MODE
INTEGER FUNCTION CREATE(NAME, MODE)
   CHARACTER NAME(ARB)
   INTEGER MODE
   INTEGER QQOPEN, FD
   EXTERNAL QQCRT
 
   FD = QQOPEN(QQCRT, NAME, MODE)
   RETURN (FD)
END
#-H- CTOSIX.RAT 457 1980 103 2148
INCLUDE RATDEF
 
# CTOSIX - RETURN SIXBIT PACKED REPRESENTATION OF NAME
INTEGER FUNCTION CTOSIX(NAME)
   CHARACTER NAME(ARB)
   INTEGER SHIFT
 
   CTOSIX = 0
   FOR(I = 1; I <= 6 & NAME(I) ^= EOS; I = I + 1)
      IF (NAME(I) >= LETA & NAME(I) <= LETZ)
         CTOSIX = SHIFT(CTOSIX, 6) + NAME(I) - LETA + BIGA - BLANK
      ELSE
         CTOSIX = SHIFT(CTOSIX, 6) + NAME(I) - BLANK
   FOR (; I <= 6; I = I + 1)
      CTOSIX = SHIFT(CTOSIX, 6)
   RETURN
END
#-H- DATE4.RAT 452 1980 103 2148
INCLUDE RATDEF
 
# DATE4 - RETURN DATE, YEAR, TIME, & SECS IN D, Y, T, & S (DEC-10 VERSION)
   SUBROUTINE DATE4(D, Y, T, S)
   INTEGER D, Y, T, S
   INTEGER GETTAB
 
   D = 100*GETTAB(9, 47) + GETTAB(9, 48)   # RETURN DATE AS MMDD INTEGER
   Y = GETTAB(9, 46)     # RETURN YEAR AS INTEGER (E.G. 1978)
   T = 100*GETTAB(9, 49) + GETTAB(9, 50)   # RETURN TIME AS HHMM INTEGER
   S = GETTAB(9, 51)     # RETURN SECONDS AS INTEGER (E.G. 56)
   RETURN
   END
#-H- DELARG.RAT 368 1980 103 2148
INCLUDE RATDEF
 
# DELARG - DELETE ARGUMENT  N  FROM COMMAND STRING
   SUBROUTINE DELARG(N)
   INTEGER N, I, J
   INCLUDE CARGS
 
   IF (N > NARGS \ N <= 0)
      RETURN
   J = ARGPTR%# WALK DOWN LIST TO PROPER ARGUMENT
   FOR (I = 0; I < N; I = I + 1) <
      K = J
      J = MEM(J+MEMOFF)
      !
   MEM(K+MEMOFF) = MEM(J+MEMOFF)
   NARGS = NARGS - 1
   RETURN
   END
#-H- DEV.MAC 4483 1980 103 2148
TITLE%DEV - GENERAL DEVICE DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%DEVOP$, DEVCL$, DEVRD$, DEVWR$
 
RELOC%400000
PHASE%%; DEV BLOCK LAYOUT
DEVBUF:%BLOCK%1%%; # BUFFERS,,BUFFER ADDRESS
DEVBHD:%BLOCK%3%%; BUFFER HEADER
DEVBFR:%%%%; ACTUAL BUFFER IN SOME CASES
DEVLEN==.
DEPHASE
RELOC%400000
 
; DEVOP$ - OPEN A DEVICE; FOR OTHER THAN MAJOR DEVICE 0, EXPECTS
; SIZE,,BUFFER ADDRESS IN DEVPTR(F); DEVPTR(F) = 0 CAUSES DEFAULT
; BUFFER SPACE TO BE ALLOCATED.
;
DEVOP$:%SKIPN%MAJOR(F)%; MAJOR DEVICE 0?
% CLEARM%DEVPTR(F)%; YES, ALLOCATE BUFFERS
%SKIPE%DEVPTR(F)%; BUFFER ADDRESS SPECIFIED?
% JRST%$1%%; YES, USING THIS DRIVER INDIRECTLY
%MOVEI%T2,OPNBK$##%; POINT TO OPEN BLOCK
%DEVSIZ%T2,%%; GET BUFFER SIZE
% JRST%$99%%; FAILED
%JUMPLE%T2,$99%%; SO DO FUNNY DEVICES
%HLRZ%Z,T2%%; COMPUTE TOTAL SPACE REQUIRED
%IMULI%Z,(T2)
%ADDI%Z,DEVLEN%; ADD IN DEV BLOCK OVERHEAD
%PUSHJ%P,ALCBK$##%; GET THE CORE
% JRST%$99%%; LOSER
%MOVEI%Z,DEVBFR(C)%; POINT TO BUFFER
%MOVEM%Z,DEVBUF(C)%; STASH FOR LATER
%HLLM%T2,DEVBUF(C)%; SAVE NUMBER OF BUFFERS
%JRST%$2%%; MERGE BELOW
$1:%MOVEI%Z,DEVLEN%; ALLOCATE A DEV BLOCK
%PUSHJ%P,ALCBK$##
% JRST%$99%%; FAILED
%MOVE%Z,DEVPTR(F)%; GET BUFFER ADDRESS
%MOVEM%Z,DEVBUF(C)%; SAVE IT
%MOVEI%T2,OPNBK$##%; COMPUTE NUMBER OF BUFFERS REQUIRED
%DEVSIZ%T2,
% JRST%$98%%; FAILED OR NOT IMPLEMENTED
%JUMPLE%T2,$98%%; STRANGE DEVICE?
%HLRZ%Z,DEVBUF(C)%; GET SIZE OF BUFFER AREA
%IDIVI%Z,(T2)%%; COMPUTE NUMBER OF BUFFERS
%JUMPE%Z,$98%%; BUFFER AREA TOO SMALL
%HRLM%Z,DEVBUF(C)%; SAVE FOR INBUF/OUTBUF UUOS
$2:%PUSHJ%P,FDCHN$##%; FIND A CHANNEL
%JUMPE%Z,$98%%; NONE AVAILABLE
%MOVEM%Z,CHANNEL(F)%; STORE IN FILE BLOCK
%LDB%T2,[MODEPTR]%; GET THE MODE
%CAIE%T2,READ%%; READ?
% JRST%$3%%; NO
%MOVEI%Z,DEVBHD(C)%; POINT TO INPUT BUFFER HEADER
%MOVEM%Z,OPNBK$+2%; STASH IN OPEN BLOCK
%PUSHJ%P,XUUO$##%; DO THE OPEN
%OPEN.%0,OPNBK$
% JRST%$98%%; OPEN FAILED
%PUSHJ%P,XUUO$%%; DO A LOOKUP
%LOOKUP%0,UUOBK$##
% JRST%$97%%; LOOKUP FAILED
%PUSH%P,.JBFF##%; FAKE .JBFF FOR BUFFER FORMATTING
%HLRZ%T2,DEVBUF(C)%; GET NUMBER OF BUFFERS
%HRRZ%Z,DEVBUF(C)%; GET BUFFER ADDRESS
%MOVEM%Z,.JBFF
%PUSHJ%P,XUUO$%%; FORMAT THE BUFFERS
%INBUF%0,(T2)
%POP%P,.JBFF%%; PUT BACK FIRST FREE
%JRST%$5%%; MERGE BELOW FOR COMPLETION
$3:%CAIE%T2,WRITE%; OPEN FOR WRITING?
% JRST%$98%%; NO, BAD MODE
%MOVSI%Z,DEVBHD(C)%; POINT TO OUTPUT BUFFER HEADER
%MOVEM%Z,OPNBK$+2%; STASH IN OPEN BLOCK
%PUSHJ%P,XUUO$%%; DO THE OPEN
%OPEN.%0,OPNBK$
% JRST%$98%%; OPEN FAILED
%PUSHJ%P,XUUO$%%; DO AN ENTER
%ENTER%0,UUOBK$
% JRST%$97%%; ENTER FAILED
%PUSH%P,.JBFF##%; FAKE .JBFF FOR BUFFER FORMATTING
%HLRZ%T2,DEVBUF(C)%; GET NUMBER OF BUFFERS
%HRRZ%Z,DEVBUF(C)%; GET BUFFER ADDRESS
%MOVEM%Z,.JBFF
%PUSHJ%P,XUUO$%%; FORMAT THE BUFFERS
%OUTBUF%0,(T2)
%POP%P,.JBFF%%; PUT BACK FIRST FREE
%JRST%$5%%; MERGE BELOW FOR COMPLETION
$5:%LDB%Z,[SIZEPTR]%; GET BYTE SIZE
%DPB%Z,[POINT 6,DEVBHD+1(C),11]%; STASH IN BUFFER HEADER
%HRRM%C,DEVPTR(F)%; SAVE DEV BLOCK ADDRESS FOR READ/WRITE
%CLEAR%R,%%; RETURN SUCCESSFULLY
%POPJ%P,
$97:%PUSHJ%P,XUUO$%%; SOME ERROR, RELEASE THE CHANNEL
%RELEAS%0,0
$98:%PUSHJ%P,FREBK$##%; RELEASE CORE
$99:%MOVE%R,[ERR]%%; RETURN ERROR CODE
%POPJ%P,
 
; DEVCL$ - CLOSE A DEVICE; FREES UP A DEVICE BLOCK.
;
DEVCL$::PUSHJ%P,XUUO$%%; DO A CLOSE
%CLOSE%0,0
%PUSHJ%P,XUUO$%%; AND A RELEASE
%RELEAS%0,0
%HRRZ%C,DEVPTR(F)%; POINT TO DEVICE BLOCK
%PUSHJ%P,FREBK$##%; FREE BLOCK
%CLEAR%R,%%; INDICATE SUCCESS
%POPJ%P,%%; RETURN
 
; DEVRD$ - READ FROM A DEVICE; POINTER TO STRING IN T1, MAX COUNT IN T2.
;
DEVRD$::PUSH%P,T2%%; SAVE COUNT
%MOVE%C,DEVPTR(F)%; POINT TO DEVICE BLOCK
$8:%SOSGE%DEVBHD+2(C)%; DECREMENT AND TEST BYTE COUNT
% JRST $10%%; GET A NEW BUFFER
%ILDB%Z,DEVBHD+1(C)%; GET THE BYTE
%IDPB%Z,T1%%; STASH THE BYTE
%SOJG%T2,$8%%; LOOP BACK FOR MORE
$9:%POP%P,R%%; GET BACK ORIGINAL COUNT
%SUB%R,T2%%; COMPUTE NUMBER OF CHARACTERS READ
%POPJ%P,
$10:%PUSHJ%P,XUUO$%%; DO AN IN
%IN%0,0
% JRST%$8%%; OK, GO ON
%AOS%EOFFLAG(F)%; LIGHT EOF FLAG
%CAME%T2,(P)%%; DID WE GET SOMETHING?
% JRST%$9%%; YES, DON'T GIVE EOF YET
%POP%P,R%%; NO, TOSS ORIGINAL COUNT
%MOVE%R,[EOF]%%; GIVE A REAL EOF
%POPJ%P,%%; RETURN
 
; DEVWR$ - WRITE TO A DEVICE; POINTER TO STRING IN T1, COUNT IN T2.
;
DEVWR$::MOVE%C,DEVPTR(F)%; POINT TO DEVICE BLOCK
$12:%SOSG%DEVBHD+2(C)%; DECREMENT AND TEST BYTE COUNT
% JRST%$14%%; DUMP THE BUFFER
$13:%ILDB%Z,T1%%; GET A BYTE
%IDPB%Z,DEVBHD+1(C)%; DEPOSIT THE BYTE
%SOJG%T2,$12%%; CONTINUE UNTIL DONE
%POPJ%P,%%; RETURN
$14:%PUSHJ%P,XUUO$%%; DO THE OUTPUT
%OUTPUT%0,0
%JRST%$13%%; GO ON
 
END
#-H- DEVSW.MAC 1336 1980 103 2148
TITLE%DEVSW - I/O FUNCTION SWITCH
TWOSEG
RELOC%400000
SEARCH%IOPARM
 
DEFINE DEVSW(Y),<
ENTRY%Y
Y::
;  CREATE   OPEN   CLOSE    READ   WRITE   SEEK   CNTRL
X DEVOP$, DEVOP$, DEVCL$, DEVRD$, DEVWR$, NULDV$, NULDV$  ; 0 UNKNOWN DEVICE
X NULDV$, NULDV$, NULDV$, NULDV$, NULDV$, NULDV$, NULDV$  ; 1 NULL DEVICE
X MEMOP$, MEMOP$, MEMCL$, MEMRD$, MEMWR$, MEMSK$, NULDV$  ; 2 MEMORY
X DSKCR$, DSKOP$, DSKCL$, DSKRD$, DSKWR$, DSKSK$, NULDV$  ; 3 DISK
X MTAOP$, MTAOP$, DEVCL$, DEVRD$, DEVWR$, NULDV$, NULDV$  ; 4 MAGNETIC TAPE
X TTYOP$, TTYOP$, TTYCL$, TTYRD$, TTYWR$, NULDV$, TTYCN$  ; 5 TERMINAL
X LPTOP$, LPTOP$, DEVCL$, ERRDV$, DEVWR$, NULDV$, NULDV$  ; 6 LINE PRINTER
X PTYOP$, PTYOP$, PTYCL$, PTYRD$, PTYWR$, NULDV$, NULDV$  ; 7 PSEUDO TERMINAL
X TMPCR$, TMPOP$, TMPCL$, MEMRD$, MEMWR$, MEMSK$, NULDV$  ; 8 TEMP CORE
>
 
DEFINE X(A,B,C,D,E,F,G),<A##>
DEVSW(CRSW$)
 
DEFINE X(A,B,C,D,E,F,G),<B##>
DEVSW(OPSW$)
 
DEFINE X(A,B,C,D,E,F,G),<C##>
DEVSW(CLSW$)
 
DEFINE X(A,B,C,D,E,F,G),<D##>
DEVSW(RDSW$)
 
DEFINE X(A,B,C,D,E,F,G),<E##>
DEVSW(WRSW$)
 
DEFINE X(A,B,C,D,E,F,G),<F##>
DEVSW(SKSW$)
 
DEFINE X(A,B,C,D,E,F,G),<G##>
DEVSW(CNSW$)
PRGEND
TITLE
SEARCH%IOPARM
TWOSEG
RELOC%400000
ENTRY%NULDV$, ERRDV$
 
NULDV$::TDZA%R,R
ERRDV$::MOVE%R,[ERR]
%POPJ%P,
 
FDTAB$=:CIOSYS##
FLTAB$=:CIOSYS+MAXFILES
OPNBK$=:FLTAB$+<MAXFILES*FBLEN>
UUOBK$=:OPNBK$+3
 
END
#-H- DSK.MAC 8874 1980 103 2148
TITLE%DSK - DISK DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%DSKCR$, DSKOP$, DSKCL$, DSKRD$, DSKWR$, DSKSK$, DSKGC$
 
RELOC%400000
PHASE%%; DSK BLOCK LAYOUT
DSKSIZ:%BLOCK%1%%; LENGTH OF FILE IN BYTES
DSKCNT:%BLOCK%1%%; NUMBER OF BYTES REMAINING IN BUFFER
DSKREC:%BLOCK%1%%; RECORD # FOR CONTENTS OF CURRENT BUF.
DSKPOS:%BLOCK%1%%; CURRENT POSITION IN FILE
DSKMOD:%BLOCK%1%%; 1 IF CURRENT BUFFER HAS BEEN MODIFIED
DSKPTR::BLOCK%1%%; BYTE POINTER
DSKCSZ:%BLOCK%1%%; CLUSTER SIZE
DSKBSZ:%BLOCK%1%%; BUFFER SIZE IN WORDS
DSKBUF:%BLOCK%1%%; POINTER TO BUFFER
DSKLEN==.
DEPHASE
RELOC%0
IOCMD:%BLOCK%2%%; FOR I/O COMMAND
RELOC%400000
 
; DSKCR$ - CREATE AND OPEN A FILE
;
DSKCR$::MOVEI%Z,17%%; SET UP DUMP MODE
%MOVEM%Z,OPNBK$##
%OPEN.%0,OPNBK$%; OPEN FILE
% JRST%$99%%; FAILED
%HLLZS%Z,UUOBK$+3%; CLEAR ERROR IN UUOBK$
%ENTER%0,UUOBK$%; CREATE FILE
% JRST%[RELEAS 0,0%; FAILED
%         JRST $99]
%CLOSE%0,0%%; CLOSE & RELEASE FILE
        RELEAS%0,0
%HLLZS%UUOBK$+3%; CLEAR ERROR BITS
%CLEARM%UUOBK$+4%; CLEAR PRIV BITS
%MOVE%Z,UUOBK$+1%; GET PATH
%TLNE%Z,-1%%; PATH?
%CLEARM%Z,UUOBK$+1%; NO, USE DEFAULT
%%%%; FALL INTO OPEN CODE
 
; DSKOP$ - OPEN A DISK FILE; SETS UP DEVICE DEPENDENT DATA
;
DSKOP$::MOVEI%Z,DSKLEN%; ALLOCATE CORE FOR DISK BLOCK
%PUSHJ%P,ALCBK$##
% JRST%$99%%; NOT ENOUGH CORE
%MOVEM%C,DEVPTR(F)%; SET DEVICE POINTER IN FILE BLOCK
%PUSHJ%P,FDCHN$##%; FIND A FREE CHANNEL
%JUMPE%Z,$98%%; NONE AVIALABLE
%MOVEM%Z,CHANNEL(F)%; SAVE IN FILE BLOCK
%MOVEI%Z,17%%; SET UP DUMP MODE
%MOVEM%Z,OPNBK$##
%PUSHJ%P,XUUO$##%; OPEN THE DISK
%OPEN.%0,OPNBK$
% JRST%$98%%; FAILED
%PUSHJ%P,XUUO$%%; LOOKUP THE FILE
%LOOKUP%0,UUOBK$##
% JRST%$97%%; FAILED
%LDB%Z,[MODEPTR]%; GET OPEN MODE
%CAIN%Z,READ%%; READ ONLY ?
% JRST%$1%%; YES, DON'T ENTER
%PUSHJ%P,XUUO$%%; ENTER FILE (OPENS IN UPDATE MODE)
%ENTER%0,UUOBK$
% JRST%$97%%; FAILED
$1:%MOVE%Z,UUOBK$+5%; COMPUTE FILE SIZE
%IMUL%Z,BYTEPW(F)
%MOVEM%Z,DSKSIZ(C)
%CLEARM%DSKREC(C)%; INITIALIZE RECORD NUMBER
%CLEARM%DSKPOS(C)%; INITIALIZE POSITION
%CLEARM%DSKMOD(C)%; BUFFER NOT MODIFIED YET
%MOVE%Z,CHANNEL(F)%; FIND CLUSTER SIZE
%LSH%Z,-^D23
%MOVEM%Z,UUOBK$
%MOVE%Z,[6,,UUOBK$]%; GET DISK CHARACTERISTICS
%DSKCHR%Z,
% SKIPA%T1,[1_^D27]%; FAILED, USE DEFAULT
%MOVE%T1,UUOBK$+5%; CLUSTER SIZE HIDDEN IN HERE
%LSH%T1,-^D27
%MOVEM%T1,DSKCSZ(C)%; SAVE FOR LATER
%IMULI%T1,200%%; COMPUTE BUFFER SIZE
%MOVEM%T1,DSKBSZ(C)%; SAVE FOR LATER
%MOVE%Z,T1
%PUSHJ%P,ALCBK$%; ALLOCATE CORE FOR BUFFER
% JRST%$97%%; FAILED
%MOVE%C,DEVPTR(F)%; POINT TO DISK BLOCK AGAIN
%MOVEM%Z,DSKBUF(C)%; SAVE BUFFER POINTER
%MOVE%Z,BYTEPW(F)%; COMPUTE BYTES PER BUFFER
%IMUL%Z,DSKBSZ(C)
%MOVEM%Z,DSKCNT(C)%; INITIALIZE COUNT
%MOVE%Z,BYTEPTR(F)%; INITIALIZE BYTE POINTER
%HRR%Z,DSKBUF(C)
%MOVEM%Z,DSKPTR(C)
%PUSHJ%P,GETBUF%; READ FIRST BUFFER
%CLEAR%R,%%; NORMAL RETURN
%POPJ%P,
$97:%MOVE%C,DEVPTR(F)%; MAKE SURE WE POINT TO DISK BLOCK
%PUSHJ%P,XUUO$
%RELEAS%0,0%%; RELEASE FILE
$98:%PUSHJ%P,FREBK$##%; RELEASE CORE
%CLEARM%DEVPTR(F)%; CLEAR DEVICE POINTER
$99:%MOVE%R,[ERR]%%; ERROR RETURN
%POPJ%P,
 
; DSKCL$ - CLOSE A DISK FILE; FREE UP DEVICE BLOCK
;
DSKCL$::MOVE%C,DEVPTR(F)%; GET POINTER DISK BLOCK
%PUSHJ%P,PUTBUF%; WRITE CURRENT BUFFER IF NECESSARY
%PUSHJ%P,XUUO$%%; CLOSE DEVICE
%CLOSE%0,0
 %PUSHJ%P,XUUO$%%; RELEASE DEVICE CHANNEL
%RELEAS%0,0
%MOVE%C,DSKBUF(C)%; FREE BUFFER SPACE
%PUSHJ%P,FREBK$##
%MOVE%C,DEVPTR(F)%; POINT TO DISK BLOCK AGAIN
%CLEARM%DEVPTR(F)%; CLEAR DISK BLOCK POINTER
%JRST%FREBK$##%; FREE CORE BLOCK AND RETURN
 
; DSKRD$  - READ FROM DISK; POINTER TO STRING IN T1, MAX COUNT IN T2
;
DSKRD$::MOVE%C,DEVPTR(F)%; POINT TO DISK FILE BLOCK
%MOVE%Z,T2%%; INCREMENT AND CHECK POSITION
%ADDB%Z,DSKPOS(C)
%CAMLE%Z,DSKSIZ(C)
% JRST%$3%%; GONE PAST END
%HRL%C,T2%%; SAVE ORIGINAL COUNT
$2:%SOSGE%DSKCNT(C)%; MORE IN THIS BUFFER?
% JRST%[PUSHJ%P,REFRESH%; NO, GET NEXT BUFFER
%% JRST%$2]%%; AND CONTINUE
%ILDB%Z,DSKPTR(C)%; GET A BYTE
%IDPB%Z,T1%%; STASH IT
%SOJG%T2,$2%%; DECREMENT AND TEST COUNT
%HLRZ%R,C%%; RETURN COUNT
%POPJ%P,%%; RETURN
$3:%SUB%T2,DSKPOS(C)%; COMPUTE NUMBER OF BYTES LEFT
%ADD%T2,DSKSIZ(C)
%MOVE%Z,DSKSIZ(C)%; RESET POSITION
%MOVEM%Z,DSKPOS(C)
%HRL%C,T2%%; SAVE NEW COUNT
%JUMPG%T2,$2%%; READ UNLESS AT END
%AOS%EOFFLAG(F)%; LIGHT EOF FLAG
%MOVE%R,[EOF]%%; RETURN EOF INDICATOR
%POPJ%P,
 
; DSKWR$  - WRITE TO DISK; POINTER TO STRING IN T1, MAX COUNT IN T2
;
DSKWR$::MOVE%C,DEVPTR(F)%; POINT TO DISK FILE BLOCK
%MOVE%Z,T2%%; INCREMENT AND TEST POSITION
%ADDB%Z,DSKPOS(C)
%CAMLE%Z,DSKSIZ(C)%; PAST END?
% MOVEM%Z,DSKSIZ(C)%; YES, UPDATE SIZE
%SETOM%DSKMOD(C)%; NOTE BUFFER MODIFICATION
$4:%SOSGE%DSKCNT(C)%; ANY ROOM LEFT?
% JRST%[PUSHJ%P,REFRESH%; NO, DUMP CURRENT BUFFER
%% JRST%$4-1]%%; CONTINUE
%ILDB%Z,T1%%; GET A BYTE
%IDPB%Z,DSKPTR(C)%; STASH IN BUFFER
%SOJG%T2,$4%%; DECREMENT AND TEST COUNT
%MOVE%R,@1(A)%%; RELOAD COUNT
%POPJ%P,%%; RETURN
 
; DSKSK$ - SEEK, POSITION IN T1
;
DSKSK$::MOVE%C,DEVPTR(F)%;  GET POINTER TO DISK BLOCK
%SKIPGE%T1%%; -1 MEANS END OF FILE
% MOVE%T1,DSKSIZ(C)
%CAMLE%T1,DSKSIZ(C)%; WITHIN FILE?
% JRST%$6%%; NO
%MOVEM%T1,DSKPOS(C)%; RESET POSITION
%CLEARM%EOFFLAG(F)%; CLEAR EOF FLAG
%IDIV%T1,BYTEPW(F)%; T1=WORD IN FILE, T2=BYTE IN WORD
%MOVE%Z,BYTEPTR(F)%; REBUILD BYTE POINTER
%HRR%Z,DSKBUF(C)
%MOVEM%Z,DSKPTR(C)
%LDB%Z,[SIZEPTR]%; GET BYTE SIZE
%IMULI%Z,(T2)%%; COMPUTE POSITION IN WORD
%MOVNS%Z
%ADDI%Z,^D36
%DPB%Z,[POINT 6,DSKPTR(C),5]
%MOVNM%T2,DSKCNT(C)%; SAVE FOR COUNT COMPUTATION
%IDIV%T1,DSKBSZ(C)%; T1=RECORD NUMBER, T2=WORD IN BUFFER
%ADDM%T2,DSKPTR(C)%; COMPLETE BYTE POINTER
%MOVE%Z,DSKBSZ(C)%; COMPUTE NEW BYTE COUNT
%SUBI%Z,(T2)
%IMUL%Z,BYTEPW(F)
%ADDM%Z,DSKCNT(C)%; ADD TO -BYTE NUMBER IN COUNT FIELD
%CAMN%T1,DSKREC(C)%; NEED TO READ NEW RECORD?
% JRST%$5%%; NO
%PUSHJ%P,PUTBUF%; YES, WRITE THIS ONE IF NECCESSARY
%MOVEM%T1,DSKREC(C)%; SET NEW RECORD NUMBER
%PUSHJ%P,GETBUF%; READ IT
$5:%TDZA%R,R%%; INDICATE SUCCESS
$6:%MOVE%R,[ERR]%%; BAD POSITION
%POPJ%P,%%; RETURN
 
; DSKGC$ - SPECIAL INTERFACE FOR GETCH; IGNORES LINE NUMBERS
;
DSKGC$::MOVE%C,DEVPTR(F)%; POINT TO DISK FILE BLOCK
$7:%AOS%T1,DSKPOS(C)%; INCREMENT AND LOAD POSITION
%CAMLE%T1,DSKSIZ(C)
% JRST%$10%%; GONE PAST END
$8:%SOSGE%DSKCNT(C)%; MORE IN THIS BUFFER?
% JRST%[PUSHJ%P,REFRESH%; NO, GET NEXT BUFFER
%% JRST%$8]%%; AND CONTINUE
%ILDB%Z,DSKPTR(C)%; GET A CHARACTER
%SKIPE%T1,@DSKPTR(C)%; GET WORD FROM BUFFER
%TRNN%T1,1%%; SEQUENCE NUMBER?
% JRST%$9%%; NOPE
%AOS%DSKPTR(C)%; YES, BUMP POINTER
%MOVEI%T1,5%%; SKIP 5 CHARACTERS
%ADDM%T1,DSKPOS(C)
%MOVNI%T1,5%%; DECREMENT COUNT
%ADDB%T1,DSKCNT(C)
%JUMPG%T1,$7%%; TRY AGAIN UNLESS AT END OF BUFFER
%PUSHJ%P,REFRESH%; GET NEXT BUFFER
%IBP%DSKPTR(C)%; BUMP POINTER PAST THE TAB
%SOS%DSKCNT(C)%; AND ADJUST THE COUNT
%JRST%$7%%; TRY AGAIN
$9:%MOVE%T1,[X.SKP]%; GET SKIP BITS
%LSH%T1,@R%%; SHIFT TO SIGN BIT
%JUMPL%T1,$7%%; TRY AGAIN
%MOVEM%R,@0(A)%%; STORE CHARACTER
%POPJ%P,
$10:%MOVE%Z,DSKSIZ(C)%; RESET POSITION
%MOVEM%Z,DSKPOS(C)
%AOS%EOFFLAG(F)%; LIGHT EOF FLAG
%MOVE%R,[EOF]%%; RETURN EOF INDICATOR
%MOVEM%R,@0(A)%%; RESET FIRST ARGUMENT
%POPJ%P,
 
; REFRESH - DUMP CURRENT BUFFER AND READ NEXT RECORD.  CALL IS
;%PUSHJ%P,REFRESH
;
REFRESH:PUSHJ%P,PUTBUF%; WRITE CURRENT BUFFER IF NECESSARY
%AOS%DSKREC(C)%; ADVANCE TO NEXT RECORD
%MOVE%Z,BYTEPTR(F)%; REBUILD BYTE POINTER
%HRR%Z,DSKBUF(C)
%MOVEM%Z,DSKPTR(C)
%MOVE%Z,BYTEPW(F)%; RESET COUNT
%IMUL%Z,DSKBSZ(C)
%MOVEM%Z,DSKCNT(C)
%JRST%GETBUF%%; GET BUFFER AND RETURN
 
; GETBUF - GET BUFFER AT RECORD DSKREC
;
GETBUF:%MOVN%Z,DSKBSZ(C)%; BUILD I/O COMMAND
%HRLS%Z
%HRR%Z,DSKBUF(C)
%SUBI%Z,1
%MOVEM%Z,IOCMD
%CLEARM%IOCMD+1
%MOVE%Z,DSKREC(C)%; COMPUTE BLOCK NUMBER IN FILE
%IMUL%Z,DSKCSZ(C)
%ADDI%Z,1
%PUSHJ%P,XUUO$%%; POSITION FOR INPUT
%USETI%0,@Z
%PUSHJ%P,XUUO$%%; READ BUFFER
%INPUT%0,IOCMD
%POPJ%P,%%; RETURN
 
; PUTBUF - WRITE CURRENT BUFFER AT DSKREC IF NECESSARY
;
PUTBUF:%SKIPN%DSKMOD(C)%; MODIFIED?
% POPJ%P,%%; NO
%CLEARM%DSKMOD(C)%; YES, INDICATE CLEAN SLATE
%PUSH%P,T1%%; SAVE T1 AND T2
%PUSH%P,T2
%MOVE%Z,DSKSIZ(C)%; COMPUTE LAST RECORD NUMBER
%IDIV%Z,BYTEPW(F)%; Z=WORD IN FILE, T1=BYTE IN WORD
%MOVE%T2,T1%%; SAVE FOR LATER ADJUSTMENT
%IDIV%Z,DSKBSZ(C)%; Z=RECORD NUMBER, T1=WORD IN BUFFER
%CAME%Z,DSKREC(C)%; WRITING LAST RECORD?
% JRST%$11%%; NO
%SKIPN%T2%%; YES, NEED TO ADJUST FOR ODD SIZE?
% JRST%$12%%; NO
%LDB%Z,[SIZEPTR]%; GET BYTE SIZE
%IMUL%T2,Z%%; COMPUTE SHIFT AMOUNT
%MOVNS%T2
%SETO%Z,%%; GET A BUNCH OF 1'S
%LSH%Z,(T2)%%; SLIDE OVER A BIT
%MOVE%T2,DSKBUF(C)%; POINT TO LAST WORD
%ADD%T2,T1
%ANDCAM%Z,(T2)%%; CLEAR OUT TRAILING BITS IN LAST WORD
%AOJA%T1,$12%%; ADJUST COUNT AND MERGE BELOW
$11:%MOVE%T1,DSKBSZ(C)%; JUST USE BUFFER SIZE
$12:%MOVNS%T1%%; BUILD I/O COMMAND
%HRL%Z,T1
%HRR%Z,DSKBUF(C)
%SUBI%Z,1
%MOVEM%Z,IOCMD
%CLEARM%IOCMD+1
%MOVE%Z,DSKREC(C)%; COMPUTE BLOCK NUMBER IN FILE
%IMUL%Z,DSKCSZ(C)
%ADDI%Z,1
%PUSHJ%P,XUUO$%%; POSITION FOR OUTPUT
%USETO%0,@Z
%PUSHJ%P,XUUO$%%; WRITE THE BUFFER
%OUTPUT%0,IOCMD
%POP%P,T2%%; RESTORE T1 AND T2
%POP%P,T1
%POPJ%P,%%; RETURN
 
END
#-H- DUP.RAT 445 1980 103 2148
INCLUDE RATDEF
INCLUDE IODEFS
 
# DUP - DUPLICATE FILE DESCRIPTOR FD.
INTEGER FUNCTION DUP(FD)
   INTEGER FD
   INTEGER I, J
   INCLUDE CIOSYS
 
   FOR (I = 1; I <= MAXFILES; I = I + 1)  # FIND A FREE DESCRIPTOR
      IF (FDTAB(I) == 0)
         BREAK
   IF (I > MAXFILES)
      RETURN (ERR)
   FDTAB(I) = FDTAB(FD+1)%# POINT TO SAME FILE BLOCK
   J = FDTAB(I)
   FILTAB(J+USECNT) = FILTAB(J+USECNT) + 1%# BUMP REFERENCE COUNT
   RETURN (I-1)
END
#-H- ERROR.RAT 144 1980 103 2148
INCLUDE RATDEF
 
# ERROR - PRINT FATAL ERROR MESSAGE, THEN DIE
   SUBROUTINE ERROR(BUF)
   INTEGER BUF(ARB)
 
   CALL REMARK(BUF)
   STOP
   END
#-H- EXEC.RAT 133 1980 103 2148
INCLUDE RATDEF
 
# EXEC - EXECUTE PROGRAM NAME
   SUBROUTINE EXEC(NAME)
   CHARACTER NAME(ARB)
 
   CALL RUN(NAME, 1)
   RETURN
   END
#-H- EXECC.RAT 928 1980 103 2148
INCLUDE RATDEF
 
# EXECC - EXECUTE COMMAND CMD
   SUBROUTINE EXECC(CMD)
   CHARACTER CMD(ARB)
   CHARACTER NAME(MAXNAME), C
   CHARACTER GETCH
   INTEGER FDI, FDO, I
   INTEGER GETWRD, OPEN, CREATE
   INCLUDE CARGS
 
   FDI = OPEN("TMP:ARG", READ)
   IF (FDI == ERR)
      FDI = CREATE("TMP:ARG", READ)
   FDO = CREATE("TMP:ARG", WRITE)
   IF (FDI == ERR \ FDO == ERR)
      RETURN
   I = 1
   JUNK = GETWRD(CMD, I, NAME)%# GET THE COMMAND NAME
   CALL QQPUTS(FDO, NAME, 0)
   IF (INPTR ^= 0)
      CALL QQPUTS(FDO, " \0", MEM(INPTR+MEMOFF+2), 0)
   CALL QQPUTS(FDO, " \0", CMD(I), 0)
   IF (OUTPTR ^= 0)
      CALL QQPUTS(FDO, " \0", MEM(OUTPTR+MEMOFF+2), 0)
   IF (ERRPTR ^= 0)
      CALL QQPUTS(FDO, " \0", MEM(ERRPTR+MEMOFF+2), 0)
   IF (GETCH(C, FDI) ^= EOF) <
      CALL PUTCH(SEMICOL, FDO)
      CALL PUTCH(C, FDO)
      !
   CALL FCOPY(FDI, FDO)
   CALL CLOSE(FDI)
   CALL CLOSE(FDO)
   CALL RUN(NAME, 1)
   RETURN
   END
#-H- EXIT.MAC 97 1980 103 2148
SEARCH%IOPARM
TITLE.%EXIT
; EXIT -- EXIT TO THE MONITOR.  CLOSES ALL FILES.
;
EXIT==QQEXIT##
END
#-H- FCANON.RAT 1317 1980 103 2148
INCLUDE RATDEF
INCLUDE IODEFS
DEFINE(DSK, 8%0446353)
 
# FCANON - RETURN NAME1 IN NAME2 IN DEC-10 FILE SPEC FORM
   INTEGER FUNCTION FCANON(NAME1, NAME2)
   CHARACTER NAME1(ARB), NAME2(ARB)
   INTEGER QQPARS, SIXTOC, XTOC, SHIFT
   INTEGER I, J
   INCLUDE CIOSYS
 
   NAME2(1) = EOS
   IF (QQPARS(NAME1, OPNBLK, 9) == ERR)
      RETURN (ERR)
   I = 1
   IF (OPNBLK(2) ^= 0 & OPNBLK(2) ^= SHIFT(DSK, 18)) <%# DEVICE
      I = I + 1 + SIXTOC(OPNBLK(2), NAME2(I), MAXNAME)
      NAME2(I-1) = COLON
      !
   IF (OPNBLK(6) ^= 0)%%# NAME
      I = I + SIXTOC(OPNBLK(6), NAME2(I), MAXNAME)
   IF (OPNBLK(7) ^= 0) <%# EXTENSION
      NAME2(I) = PERIOD
      I = I + 1 + SIXTOC(OPNBLK(7), NAME2(I+1), MAXNAME)
      !
   IF (OPNBLK(5) ^= 0) <%# PPN
      NAME2(I) = LBRACK
      I = I + 2 + XTOC(SHIFT(OPNBLK(9+7), -18), NAME2(I+1), MAXNAME, 8)
      NAME2(I-1) = COMMA
      I = I + 1 + XTOC(OPNBLK(9+7) & 8%0777777, NAME2(I), MAXNAME, 8)
      FOR (J = 9+8; OPNBLK(J) ^= 0; J = J + 1) <
         NAME2(I-1) = COMMA
         I = I + 1 + SIXTOC(OPNBLK(J), NAME2(I), MAXNAME)
         !
      NAME2(I-1) = RBRACK
      !
   IF (OPNBLK(8) ^= 0) <%# PROTECTION
      NAME2(I) = LESS
      I = I + 2 + XTOC(SHIFT(OPNBLK(8), -27), NAME2(I+1), MAXNAME, 8)
      NAME2(I-1) = GREATER
      !
   NAME2(I) = EOS
   RETURN (I-1)
   END
#-H- FDCHN.MAC 378 1980 103 2148
SEARCH%IOPARM
TITLE.%FDCHN$
; FDCHN$ -- FIND A CHANNEL; RETURNS 0 IF NONE AVAILABLE.
FDCHN$::PUSH%P,T1%%; SAVE A REGISTER
%MOVEI%R,17%%; START FROM TOP AND GO DOWN
$1:%HRRZ%T1,R%%; COPY CHANNEL NUMBER
%DEVNAM%T1,%%; IS THIS CHANNEL IN USE?
% JRST%$2%%; NO
%SOJG%R,$1%%; TRY ANOTHER ONE BUT DON'T USE 0
$2:%LSH%R,^D23%%; SHIFT TO RIGHT PLACE
%POP%P,T1%%; RESTORE T1
%POPJ%P,
END
#-H- FREBK.MAC 311 1980 103 2148
SEARCH%IOPARM
TITLE.%FREBK$
; FREBK$ - I/O SYSTEM INTERFACE TO FREE TO FREE CORE.  CALL IS
;%MOVE%C,POINTER TO BLOCK
;%PUSHJ%P,FREBK$
;
FREBK$::PUSHJ%P,SAVR$##%; SAVE THE WORLD
%MOVEM%C,PTR%%; SET UP FOR CALL
%MOVEI%A,[EXP <-1,,0>,PTR]+1
%JRST%QQFREE##%%; FREE THE BLOCK AND RETURN
RELOC
PTR:%BLOCK%1
RELOC
END
#-H- FREE.RAT 107 1980 103 2148
# FREE - FREE CORE POINTED TO BY P.
   SUBROUTINE FREE(P)
   INTEGER P
 
   CALL QQFREE(P)
   RETURN
   END
#-H- FSIZEW.RAT 235 1980 103 2148
INCLUDE RATDEF
 
# FSIZEW - SIZE OF FILE IN WORDS
   INTEGER FUNCTION FSIZEW(NAME)
   CHARACTER NAME(ARB)
   INTEGER FSTAT, INFO(4)
 
   IF (FSTAT(NAME, INFO, 4) == ERR)
      FSIZEW = -1
   ELSE
      FSIZEW = INFO(4)
   RETURN
   END
#-H- FSTAT.RAT 1422 1980 103 2148
INCLUDE RATDEF
 
# FSTAT - RETURN INFORMATION ABOUT FILE NAME
# A(1) = CREATION DATE, A(2) = CREATION YEAR, A(3) = CREATION TIME,
# A(4) = WORDS WRITTEN, A(5) = PROTECTION, A(6) = ACCESS DATE,
# A(7) = ACCESS YEAR, A(8) = BLOCKS ALLOCATED, A(9) = STATUS BITS
   INTEGER FUNCTION FSTAT(NAME, A, N)
   CHARACTER NAME(ARB)
   INTEGER A(ARB), N
   INTEGER BUF(45), ARG(30), D, T
   INTEGER SHIFT, MOD, QQPARS, LKPUUO
   EQUIVALENCE (BUF(5), ARG(1))
 
   IF (QQPARS(NAME, BUF, 29) == ERR)
      RETURN(ERR)
   IF (LKPUUO(BUF) == ERR)%# GET RIB INFORMATION
      RETURN(ERR)
   IF (N >= 1) <%# A(1) = CREATION DATE
      D = SHIFT(SHIFT(ARG(3), -15) & 8%07, 12) + (ARG(4) & 8%07777)
      A(1) = 100*(MOD(D, 12*31)/31 + 1) + MOD(MOD(D, 12*31), 31) + 1
      !
   IF (N >= 2)%%# A(2) = CREATION YEAR
      A(2) = D/(12*31) + 1964
   IF (N >= 3) <%# A(3) = CREATION TIME
      T = SHIFT(ARG(4), -12) & 8%03777
      A(3) = 100*(T/60) + MOD(T, 60)
      !
   IF (N >= 4)%%# A(4) = WORDS WRITTEN
      A(4) = ARG(5)
   IF (N >= 5)%%# A(5) = PROTECTION
      A(5) = SHIFT(ARG(4), -27)
   IF (N >= 6) <%# A(6) = ACCESS DATE
      D = ARG(3) & 8%077777
      A(6) = 100*(MOD(D, 12*31)/31 + 1) + MOD(MOD(D, 12*31), 31) + 1
      !
   IF (N >= 7)%%# A(7) = ACCESS YEAR
      A(7) = D/(12*31) + 1964
   IF (N >= 8)%%# A(8) = BLOCKS ALLOCATED
      A(8) = ARG(9)
   IF (N >= 9)%%# A(9) = STATUS BITS
      A(9) = ARG(15)
   RETURN(N)
   END
#-H- GETARG.RAT 1071 1980 103 2148
INCLUDE RATDEF
DEFINE(EFLAG,8%400000)
 
# GETARG - GET ARGUMENT  N  FROM COMMAND STRING INTO  ARRAY
   INTEGER FUNCTION GETARG(N, ARRAY, MAXSIZ)
   CHARACTER ARRAY(ARB)
   INTEGER N, MAXSIZ
   CHARACTER C
   INTEGER I, J, P
   INTEGER ESC
   INCLUDE CARGS
 
   ARRAY(1) = EOS
   IF (N == -1)
      GETARG = NARGS
   ELSE IF (N > NARGS \ N < 0)
      GETARG = EOF
   ELSE <
      J = ARGPTR%# WALK DOWN LIST TO PROPER ARGUMENT
      FOR (I = 0; I < N; I = I + 1)
         J = MEM(J+MEMOFF)
      C = EOS
      IF (MEM(J+MEMOFF+2) == DQUOTE \ MEM(J+MEMOFF+2) == SQUOTE) <
         C = MEM(J+MEMOFF+2)
         J = J + 1
         !
      FOR (I = 1; I < MAXSIZ; I = I + 1) <
         ARRAY(I) = MEM(J+MEMOFF+2) & ^EFLAG
         J = J + 1
         IF (ARRAY(I) == C)
            BREAK
         !
      ARRAY(I) = EOS
      IF (C == EOS) <%# EXPAND ESCAPES
         I = 1
         FOR (J = 1; ARRAY(J) ^= EOS; J = J + 1) <
            ARRAY(I) = ESC(ARRAY, J)
            I = I + 1
            !
         ARRAY(I) = EOS
         !
      GETARG = I - 1
      !
   RETURN
   END
#-H- GETCH.MAC 958 1980 103 2148
SEARCH%IOPARM
TITLE.%GETCH
; GETCH(C,F) - GET NEXT CHARACTER FROM F INTO C AND AS FUNCTION VALUE.
; IGNORES LINE NUMBERS ON DISK FILES.
;
GETCH::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVE%F,@1(A)%%; POINT TO FILE BLOCK
%MOVE%F,FDTAB$##(F)
%MOVEI%F,FLTAB$##-1(F)
%MOVE%Z,OPNMODE(F)%; GET MODE
%TRNE%Z,1%%; OPEN FOR WRITE ONLY?
% JRST%[MOVE%R,[ERR]
%% JRST%$2]%; OPEN FOR WRITE ONLY
%SKIPE%EOFFLAG(F)
% JRST%[MOVE%R,[EOF]
%% JRST%$2]%; PREVIOUS EOF SO RETURN
%MOVEI%Z,^D3%%; DISK?
%CAMN%Z,MAJOR(F)
% JRST%DSKGC$##%; YES
$1:%MOVEI%T1,@0(A)%; NO, JUST READ A CHARACTER
%HRLI%T1,(POINT 36)
%MOVEI%T2,1
%MOVE%C,MAJOR(F)%; GET DEVICE NUMBER
%PUSHJ%P,@RDSW$##(C)%; READ A CHARACTER
%CAME%R,[ERR]%%; ERROR OR EOF?
%CAMN%R,[EOF]
% JRST%$2%%; YES
%JUMPE%R,$2%%; OR 0 CHARACTERS READ
%MOVE%R,@0(A)%%; GET CHARACTER
%MOVE%T1,[X.SKP]%; GET SKIP BITS
%LSH%T1,@R
%JUMPL%T1,$1%%; IGNORE THESE
%POPJ%P,%%; RETURN
$2:%MOVEM%R,@0(A)%%; STASH ERR OR EOF
%POPJ%P,%%; RETURN
END
#-H- GETPPN.MAC 124 1980 103 2148
SEARCH%IOPARM
TITLE.%GETPPN
; GETPPN(JUNK) - RETURNS PPN OF CURRENT JOB.
;
GETPPN::CALLI%R,24%; GET PPN
% JFCL
%POPJ%P,
END
#-H- GETSW.RAT 598 1980 103 2148
INCLUDE RATDEF
 
# GETSW - SEPARATE SWITCHES FROM FILE NAME IN ARG
   SUBROUTINE GETSW(ARG, SW1, NAME, SW2)
   CHARACTER ARG(MAXNAME), SW1(MAXNAME), NAME(MAXNAME), SW2(MAXNAME)
   INTEGER I
   CHARACTER C
 
   I = 1
   CALL SKIPBL(ARG, I)
   J = 1
   IF (ARG(I) == SLASH) <
      FOR (; ARG(I) ^= EOS & ARG(I) ^= BLANK & ARG(I) ^= TAB; J = J + 1) <
         SW1(J) = ARG(I)
         I = I + 1
         !
      !
   SW1(J) = EOS
   FOR (J = 1; ARG(I) ^= EOS & ARG(I) ^= SLASH; J = J + 1) <
      NAME(J) = ARG(I)
      I = I + 1
      !
   CALL SCOPY(ARG, I, SW2, 1)
   NAME(J) = EOS
   RETURN
   END
#-H- GETTAB.MAC 438 1980 103 2148
SEARCH%IOPARM
TITLE.%GETTAB
; GETTAB(TABLE,INDEX,RESULT:INTEGER):INTEGER - DO A GETTAB UUO; VALUE IS
; RETURNED IN RESULT (IF PRESENT) AND AS FUNCTION VALUE.
;
GETTAB::HRR%R,@0(A)%%; GET TABLE NUMBER
%HRL%R,@1(A)%%; GET INDEX
%CALLI%R,41%%; DO GETTAB
% MOVE%R,[ERR]%%; SIGNAL ERROR
%HLRE%T1,-1(A)%; GET NUMBER OF ARGUMENTS
%CAMGE%T1,[-2]%%; IS THIRD ARGUMENT PRESENT?
% MOVEM%R,@2(A)%%; YES, STORE RESULT THERE TOO
%POPJ%P,%%; RETURN
END
#-H- GOBSTR.MAC 226 1980 103 2148
SEARCH%IOPARM
TITLE.%GOBSTR
; GOBSTR(A:ARRAY,N:INTEGER):INTEGER -- DO A GOBSTR UUO.
;
GOBSTR::HRL%Z,@1(A)%%; GET COUNT
%HRRI%Z,@0(A)%%; POINT TO ARGUMENT BLOCK
%CALLI%Z,66%%; DO IT
% SKIPA
%TDZA%Z,Z
%MOVE%Z,[ERR]
%POPJ%P,
END
#-H- HIBER.MAC 174 1980 103 2148
SEARCH%IOPARM
TITLE.%HIBER
; HIBER(N) - DO HIBER UUO WITH ARGUMENT OF N.
;
HIBER::%MOVE%Z,@0(A)%%; GET ARGUMENT
%CALLI%Z,72%%; NIGHTY NITE
% CLEAR%R,%%; MMMM...
%POPJ%P,
END
#-H- INCHRW.MAC 214 1980 103 2148
SEARCH%IOPARM
TITLE.%INCHRW
; INCHRW(C) -- READ NEXT CHARACTER FROM TTY; WAIT IF NECESSARY
;
INCHRW::TTCALL%0,R%%; GET CHARACTER
%MOVEM   R,@0(16)        ; STORE IN ARG
        POPJ    P,              ; RETURN
END
#-H- INMAP.MAC 215 1980 103 2148
SEARCH%IOPARM
TITLE.%INMAP
; INMAP(C:A1 CHARACTER):CHAR -- CONVERT LEFT-JUSTIFIED CHARACTER TO
; ASCII EQUIVALENT.
;
INMAP::%MOVE%R,@0(A)%%; LOAD WORD
%LSH%R,-^D29%%; SHIFT TO RIGHMOST 7 BITS
%POPJ%P,%%; RETURN
END
#-H- IODEFS 667 1980 103 2148
DEFINE(MAXFILES,16)%# NUMBER OF OPENED FILES PERMITTED
 
# FILE BLOCK FORMAT
DEFINE(USECNT,0)%# USE COUNT
DEFINE(MAJOR,1)%%# MAJOR DEVICE NUMBER
DEFINE(MINOR,2)%%# MINOR DEVICE NUMBER
DEFINE(BYTEPTR,3)%# BYTE POINTER FOR I/O
DEFINE(PACKPTR,4)%# BYTE POINTER TO CHECK FOR PACKED BUFFER
DEFINE(OPNMODE,5)%# OPEN MODE
DEFINE(EOFFLAG,6)%# END OF FILE FLAG
DEFINE(DEVPTR,7)%# POINTER TO DEVICE DEPENDENT DATA
DEFINE(CHANNEL,8)%# IO CHANNEL IF NEEDED
DEFINE(BYTEPW,9)%# NUMBER OF BYTES PER WORD
DEFINE(FBLEN,10)%# LENGTH OF EACH BLOCK
 
# NEW MODE MODIFIERS
DEFINE(WORDMODE,8*36)%# 36-BIT BYTES
DEFINE(SIXBIT,8*6)%# 6-BIT BYTES
DEFINE(READPACKED,8*64*1)%# PACK INPUT RECORDS
#-H- IOPARM.MAC 1520 1980 103 2148
UNIVERSAL IOPARM - I/O SYSTEM PARAMETERS
 
R==0%%; RESULT REGISTER FOR FORTRAN
Z==0
T1==1%%; TEMPORARY
T2==2
F==5%%; FILE BLOCK
C==6%%; CHARACTERS OR POINTER TO DEVICE-SPECIFIC BLOCK
A==16%%; FORTRAN ARGUMENT POINTER
P==17%%; STACK
 
STKSIZ==^D200%; STACK SIZE
 
EOL==12%%; END OF LINE INDICATOR
EOF==^D10003%; END OF FILE CHARACTER
ERR==^D10001%; OPEN ERROR CHARACTER
EOS==^D10002%; END OF STRING INDICATOR
 
C.NL==0%%; NULL
C.HT==11%; HORIZONTAL TAB
C.LF==12%; LINE FEED
C.VT==13%; VERTICAL TAB
C.FF==14%; FORM FEED
C.CR==15%; CARRIAGE RETURN
C.ES==33%; ALTMODE
C.CZ==32%; CONTROL-Z
 
X.SKP==1B<C.NL>!1B<C.CR>%; IGNORE ON INPUT
X.EOL==1B<C.LF>!1B<C.VT>!1B<C.ES>%; DEFINES END OF LINE
 
; FILE BLOCK LAYOUT (SEE IODEFS)
MAXFILES==^D16%%; MAXIMUM NUMBER OF FILES
USECNT==0%%; USE COUNT
MAJOR==1%%; MAJOR DEVICE NUMBER
MINOR==2%%; MINOR DEVICE NUMBER
BYTEPTR==3%%; BYTE POINTER FOR I/O
PACKPTR==4%%; BYTE POINTER TO CHECK FOR PACKED BUFFER
OPNMODE==5%%; OPEN MODE
EOFFLAG==6%%; END OF FILE FLAG
DEVPTR==7%%; POINTER TO DEVICE DEPENDENT DATA
CHANNEL==^D8%%; CHANNEL IN PROPER PLACE IF NEEDED
BYTEPW==^D9%%; NUMBER OF BYTES PER WORD
FBLEN==^D10%%; LENGTH OF EACH BLOCK
 
; MODES
READ==0%%; OPEN CODE FOR READING
WRITE==1%; OPEN CODE FOR WRITING
READWRITE==2%; OPEN CODE FOR READING AND WRITING
MODEPTR==POINT 3,OPNMODE(F),35%; TO GET MODE
SIZEPTR==POINT 6,OPNMODE(F),32%; TO GET BYTE SIZE
READPACKED==1B26%%; INDICATES PACKED INPUT RECORDS
 
OPDEF%OPEN.%[050000000000]
 
DEFINE%TITLE.(X),<
TITLE%X
TWOSEG
RELOC%400000
ENTRY%X
>
END
#-H- JOBSTS.MAC 322 1980 103 2148
SEARCH%IOPARM
TITLE.%JOBSTS
; JOBSTS(FD) - RETURN STATUS OF PTY ON FD.
;
JOBSTS::PUSHJ%P,SAVR$##%; SAVE REGISTERS
%MOVE%F,@0(A)%%; POINT TO FILE BLOCK
%MOVE%F,FDTAB$##(F)
%MOVEI%F,FLTAB$##-1(F)
%MOVE%R,CHANNEL(F)%; GET CHANNEL WORD
%LSH%R,-^D23%%; RIGHT JUSTIFY
%CALLI%R,61
% MOVE%R,[ERR]%%; ERROR INDICATION
%POPJ%P,
END
#-H- LDC.MAC 104 1980 103 2148
SEARCH%IOPARM
TITLE.%LDC
; LDC(C,A,I):C - GET THE ITH CHARACTER (0-BASED) FROM A IN C.
;
LDC==LLC##
END
#-H- LKPUUO.MAC 365 1980 103 2148
SEARCH%IOPARM
TITLE.%LKPUUO
; LKPUUO(BUF:ARRAY):INTEGER -- DO A LOOKUP UUO ON GIVEN BLOCK.
;
LKPUUO::PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVEI%T1,@0(A)%; POINT TO BLOCK
%OPEN.%0,0(T1)%%; OPEN THE DEVICE
% JRST%$1%%; CAN'T OPEN
%LOOKUP%0,3(T1)%%; FIND THE FILE
% JRST%$1%%; CAN'T FIND
%RELEAS%0,0
%TDZA%R,R%%; RETURN SUCCESS
$1:%MOVE%R,[ERR]%%; OOPS
%POPJ%P,
END
#-H- LLC.MAC 106 1980 103 2148
SEARCH%IOPARM
TITLE.%LLC
; LLC(C,A,I):C - GET THE ITH CHARACTER (0-BASED) FROM A IN C.
;
LLC==QQLLC##
END
#-H- LOC.MAC 95 1980 103 2148
SEARCH%IOPARM
TITLE.%LOC
; LOC(V:VAR):ADDR -- RETURN ADDRESS OF VARIABLE V.
;
LOC==QQLOC##
END
#-H- LPT.MAC 291 1980 103 2148
TITLE%LPT - LINE PRINTER DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%LPTOP$
RELOC%400000
 
; LPTOP$ - OPEN A LINE PRINTER; JUST VALIDATES BYTE SIZE
;
LPTOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE
%CAIN%Z,7%%; MUST BE CHARACTER
% JRST%DEVOP$##%; GO OPEN AS GENERAL DEVICE
%MOVE%R,[ERR]%%; LOSER
%POPJ%P,
 
END
#-H- MAKNAM.RAT 558 1980 103 2148
INCLUDE RATDEF
 
# MAKNAM - MAKE A FILE NAME IN FNAME USING PREFIX, NAME & SUFFIX.
   SUBROUTINE MAKNAM(PREFIX, NAME, SUFFIX, FNAME)
   CHARACTER PREFIX(MAXNAME), NAME(MAXNAME), SUFFIX(MAXNAME), FNAME(ARB)
   CHARACTER BUF(MAXLINE)
   INTEGER I
   INTEGER LENGTH, FCANON
 
   BUF(1) = EOS
   I = 1
   IF (PREFIX(1) ^= 0)
      CALL SCOPY(PREFIX, 1, BUF, I)
   I = LENGTH(BUF) + 1
   IF (NAME(1) ^= 0)
      CALL SCOPY(NAME, 1, BUF, I)
   I = LENGTH(BUF) + 1
   IF (SUFFIX(1) ^= 0)
      CALL SCOPY(SUFFIX, 1, BUF, I)
   I = FCANON(BUF, FNAME)
   RETURN
   END
#-H- MEM.MAC 3337 1980 103 2148
TITLE%MEM - MEMORY DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%MEMOP$, MEMCL$, MEMRD$, MEMWR$, MEMSK$
 
RELOC%400000
PHASE%%; MEM BLOCK LAYOUT
MEMADR:%BLOCK%1%%; ADDRESS OF STREAM
MEMSIZ::BLOCK%1%%; CURRENT SIZE OF STREAM
MEMPOS:%BLOCK%1%%; CURRENT POSITION IN STREAM
MEMPTR:%BLOCK%1%%; POINTER TO CURRENT POSITION
MEMMAX:%BLOCK%1%%; MAXIMUM SIZE OF STREAM
MEMLEN==.
DEPHASE
RELOC%400000
 
; MEMOP$ - OPEN A MEMORY STREAM; F CONTAINS FILE BLOCK ADDRESS.
;
MEMOP$::MOVEI%Z,MEMLEN%; ALLOCATE A MEMORY BLOCK
%PUSHJ%P,ALCBK$##
% JRST%$99%%; FAILED
%MOVE%Z,OPNBK$##%; GET ADDRESS OF STREAM
%MOVEM%Z,MEMADR(C)%; SAVE IT
%SKIPN%T2,OPNBK$+1%; CHECK AND LOAD SIZE
% MOVEI%T2,-1%%; 0 MEANS HUGE
%IMUL%T2,BYTEPW(F)%; COMPUTE TOTAL NUMBER OF BYTES
%SUBI%T2,1%%; 0 BASED
%MOVEM%T2,MEMMAX(C)%; SAVE HI WATER MARK
%MOVE%T2,OPNBK$+2%; COMPUTE INITIAL SIZE
%IMUL%T2,BYTEPW(F)
%SKIPE%T2%%; MAKE ZERO BASED UNLESS 0
% SUBI%T2,1
%MOVEM%T2,MEMSIZ(C)
%CLEARM%MEMPOS(C)%; START AT POSITION 0
%MOVE%Z,BYTEPTR(F)%; GET BYTE POINTER
%ADDI%Z,@MEMADR(C)%; CONSTRUCT STREAM POINTER
%MOVEM%Z,MEMPTR(C)
%MOVEM%C,DEVPTR(F)%; SAVE POINTER TO THIS MEM BLOCK
%CLEAR%R,%%; INDICATE SUCCESS
%POPJ%P,
$99:%MOVE%R,[ERR]%%; INDICATE ERROR
%POPJ%P,
 
; MEMCL$ - CLOSE A MEMORY STREAM; FREES UP A MEM BLOCK
;
MEMCL$::MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK
%JRST%FREBK$##%; FREE IT
 
; MEMRD$ - READ FROM A STREAM; POINTER TO STRING IN T1, MAX COUNT IN T2.
;
MEMRD$::PUSH%P,T2%%; SAVE COUNT
%MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK
$4:%MOVE%Z,MEMPOS(C)%; GET CURRENT POSITION
%CAMLE%Z,MEMSIZ(C)%; HIT THE END YET?
% JRST%$6%%; YES
%ILDB%Z,MEMPTR(C)%; READ A BYTE
%IDPB%Z,T1%%; STASH IT
%AOS%MEMPOS(C)%; BUMP POSITION
%SOJG%T2,$4%%; LOOP UNTIL DONE
$5:%POP%P,R%%; GET BACK ORIGINAL COUNT
%SUB%R,T2%%; COMPUTE NUMBER OF BYTES READ
%POPJ%P,%%; RETURN
$6:%AOS%EOFFLAG(F)%; INDICATE EOF
%CAME%T2,(P)%%; GET ANYTHING?
% JRST%$5%%; YES, DON'T RETURN EOF YET
%POP%P,R%%; NO, TOSS ORIGINAL COUNT
%MOVE%R,[EOF]%%; INDICATE EOF
%POPJ%P,%%; RETURN
 
; MEMWR$ - WRITE TO A STREAM; POINTER TO STRING IN T1, COUNT IN T2.
;
MEMWR$::MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK
$8:%MOVE%Z,MEMPOS(C)%; GET CURRENT POSITION
%CAMLE%Z,MEMMAX(C)%; OVER THE EDGE YET?
% JRST%$9%%; YES
%ILDB%Z,T1%%; GET A BYTE
%IDPB%Z,MEMPTR(C)%; WRITE IT
%AOS%MEMPOS(C)%; BUMP POSITION
%SOJG%T2,$8%%; LOOP UNTIL DONE
%MOVE%Z,MEMPOS(C)%; GET CURRENT POSITION
%CAMLE%Z,MEMSIZ(C)%; DID WE EXTEND THE SIZE?
% MOVEM%Z,MEMSIZ(C)%; YES, SAVE NEW SIZE
%MOVE%R,@1(A)%%; RETURN COUNT
%POPJ%P,%%; RETURN
$9:%MOVE%T1,MEMMAX(C)%; PUT POSITION BACK
%PUSHJ%P,MEMSK$
%MOVE%R,[ERR]%%; INDICATE ERROR
%POPJ%P,
 
; MEMSK$ - SEEK IN A STREAM; T1 CONTAINS NEW POSITION
;
MEMSK$::MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK
%SKIPGE%T1%%; POSITION < 0 MEANS THE END
% MOVE%T1,MEMSIZ(C)
%CAMLE%T1,MEMMAX(C)%; WITHIN RANGE?
% JRST%$12%%; NOPE
%MOVEM%T1,MEMPOS(C)%; ESTABLISH NEW POSITION
%CAMLE%T1,MEMSIZ(C)%; EXTENDING STREAM?
% MOVEM%T1,MEMSIZ(C)%; YES
%IDIV%T1,BYTEPW(F)%; COMPUTE WORD AND BYTE OFFSET
%MOVE%Z,BYTEPTR(F)%; BUILD NEW BYTE POINTER
%ADDI%Z,@MEMADR(C)%; ADD IN ADDRESS
%ADDI%Z,(T1)%%; ADD IN WORD OFFSET
%LDB%T1,[SIZEPTR]%; GET BYTE SIZE
%IMULI%T1,(T2)%%; COMPUTE POSITION
%MOVNS%T1
%ADDI%T1,^D36
%DPB%T1,[POINT 6,Z,5]%; STASH IN POINTER
%MOVEM%Z,MEMPTR(C)%; STORE IT
%CLEAR%R,%%; INDICATE SUCCESS
%POPJ%P,
$12:%MOVE%R,[ERR]%%; INDICATE AN ERROR
%POPJ%P,
 
END
#-H- MEMORY.RAT 969 1980 103 2148
INCLUDE RATDEF
INCLUDE IODEFS
 
# MEMORY - OPEN ARRAY A FOR I/O ACCORDING TO MODE, RETURN FILE DESCRIPTOR
INTEGER FUNCTION MEMORY(A, N, M, MODE)
   INTEGER A(ARB), N, M, MODE
   INTEGER I, FD
   INTEGER LOC, QQOPN
   INCLUDE CIOSYS
 
   FOR (FD = 1; FD <= MAXFILES; FD = FD + 1)  # FIND A DESCRIPTOR
      IF (FDTAB(FD) == 0)
         BREAK
   IF (FD > MAXFILES)
      RETURN (ERR)
   FOR (I = 1; I < FBLEN*MAXFILES; I = I + FBLEN)   # FIND A FILE BLOCK
      IF (FILTAB(I+USECNT) == 0)
         BREAK
   IF (I >= FBLEN*MAXFILES)
      RETURN (ERR)
   FILTAB(I+MAJOR) = 2
   FILTAB(I+MINOR) = 1
   FILTAB(I+OPNMODE) = MODE
   FILTAB(I+EOFFLAG) = NO
   OPNBLK(1) = LOC(A(1))%# USE OPNBLK FOR ARGUMENTS TO MEMOPN
   OPNBLK(2) = N%# MAXIMUM SIZE
   OPNBLK(3) = M%# INITIAL SIZE
   IF (QQOPN(FILTAB(I+MAJOR), FILTAB(I+MINOR), FILTAB(I+USECNT)) == ERR)
      RETURN (ERR)
   FDTAB(FD) = I   # CONNECT FILE DESCRIPTOR TO FILE BLOCK
   FILTAB(I+USECNT) = 1
   RETURN (FD-1)
END
#-H- MTA.MAC 669 1980 103 2148
TITLE%MTA - MAGNETIC TAPE DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%MTAOP$
 
RELOC%400000
 
; MTAOP$ - OPEN MTA; HANDLES MINOR DEVICE 2 (MT:) OR 8-BIT BYTES
; IN ASCII MODE
;
MTAOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE
%CAIN%Z,8%%; 8 = MINOR DEVICE 2
% MOVEI%T1,2
%MOVEM%T1,MINOR(F)%; RESET MINOR DEVICE NUMBER
%CAIE%T1,2%%; MT: (8-BIT BYTES; ASCII MODE)?
% JRST%DEVOP$##%; NO, JUST OPEN IT
%MOVEI%Z,4%%; YES, 8-BIT BYTES
%MOVEM%Z,BYTEPW(F)%; RESET NUMBER BYTES PER WORD
%MOVEI%Z,8
%DPB%Z,[SIZEPTR]%; SET EIGHT BIT BYTES
%PUSHJ%P,DEVOP$##%; OPEN THE DEVICE
%CAMN%R,[ERR]%%; ERROR?
% POPJ%P,%%; OOPS
%PUSHJ%P,XUUO$##%; SET INDUSTRY COMPATIBLE MODE
%MTIND.%0,0
%POPJ%P,%%; RETURN
 
END
#-H- MTAPE.MAC 848 1980 103 2148
SEARCH%IOPARM
TITLE.%MTAPE
OPDEF%MTAPE.%[072000000000]
; MTAPE(N:INTEGER;F:FILE) - PERFORM THE INDICATED MAGNETIC TAPE FUNCTION
; ON FILE F (WHICH SHOULD BE A MAGNETIC TAPE).  BACKSPACE FILE IS
; HANDLED CORRECTLY.
;
MTAPE::%PUSHJ   P,SAVR$##%; SAVE SOME REGISTERS
        MOVE    F,@1(A)         ; GET THE FILE DESCRIPTOR
%MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB
%MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK
%MOVE%T1,@0(A)%; GET THE FUNCTION CODE
%CAIE%T1,17%%; BACKSPACE FILE?
% JRST%$1%%; NO
%PUSHJ%P,XUUO$##%; YES, DO A BACKSPACE FILE
%MTBSF.%0,
%PUSHJ%P,XUUO$%%; WAIT FOR COMPLETION
%MTWAT.%0,
%PUSHJ%P,XUUO$%%; AT BEGINNING OF TAPE?
%STATZ%0,4000
% POPJ%P,%%; YES, JUST RETURN
%PUSHJ%P,XUUO$%%; NO, JUMP OVER FILE MARK
%MTSKF.%0,
%POPJ%P,%%; NOW RETURN
$1:%PUSHJ%P,XUUO$%%; DO APPROPRIATE CODE
%MTAPE.%0,(T1)
%POPJ%P,%%; RETURN
END
#-H- OPEN.RAT 264 1980 103 2148
INCLUDE RATDEF
INCLUDE IODEFS
 
# OPEN - OPEN FILE NAME ACCORDING TO MODE, RETURN FILE DESCRIPTOR
INTEGER FUNCTION OPEN(NAME, MODE)
   CHARACTER NAME(ARB)
   INTEGER MODE
   INTEGER QQOPEN, FD
   EXTERNAL QQOPN
 
   FD = QQOPEN(QQOPN, NAME, MODE)
   RETURN (FD)
END
#-H- OUTMAP.MAC 256 1980 103 2148
SEARCH%IOPARM
TITLE.%OUTMAP
; OUTMAP(C:CHAR):A1 CHARACTER -- CONVERT ASCII CODE TO LEFT-JUSTIFIED
; CHARACTER.
;
OUTMAP::MOVE%R,@0(A)%%; GET CHARACTER
%LSH%R,^D29%%; SHIFT TO HIGH 7 BITS
%TDO%R,[<ASCII/     />_<-^D7>]%; OR IN BLANKS
%POPJ%P,%%; RETURN
END
#-H- PACK.MAC 963 1980 103 2148
SEARCH%IOPARM
TITLE.%PACK
; PACK(N:INTEGER,S:STRING,D:PACKED STRING):INTEGER -- PACK N CHARACTERS
; FROM S INTO D.  STOPS IF AN EOS IS ENCOUNTERED.  RETURNS THE NUMBER OF
; CHARACTERS PACKED AND PUTS A NULL AT THE END OF D.
;
PACK::  PUSHJ   P,SAVR$##        ; SAVE SOME REGISTERS
        MOVEI   T1,@1(A)        ; GET ADDRESS OF S
        HRLI    T2,(POINT 7)    ; SET UP A POINTER ...
        HRRI    T2,@2(A)        ;  TO D
%MOVE%R,@0(A)%%; GET N
%JUMPLE%R,$2%%; DONE ALREADY
$1:%MOVE    C,(T1)          ; GET A CHARACTER FROM S
        CAMN    C,[EOS]         ; CHECK FOR EOS
         JRST   $2%%; QUIT IF EOS
        IDPB    C,T2            ; STASH IN D
        ADDI    T1,1            ; BUMP ADDRESS OF S
        SOJG    R,$1%%; CONTINUE TILL DONE
$2:%MOVEI   C,0             ; GET A NULL
        IDPB    C,T2            ; PUT AT END OF D
        MOVE    R,T1            ; COMPUTE LENGTH
        SUBI    R,@1(A)
        POPJ    P,              ; RETURN
END
#-H- PATH.MAC 218 1980 103 2148
SEARCH%IOPARM
TITLE.%PATH
; PATH(A:ARRAY,N:INTEGER):INTEGER -- DO A PATH. UUO.
;
PATH::%HRL%Z,@1(A)%%; GET COUNT
%HRRI%Z,@0(A)%%; POINT TO ARGUMENT BLOCK
%PATH.%Z,%%; DO IT
% SKIPA
%TDZA%Z,Z
%MOVE%Z,[ERR]
%POPJ%P,
END
#-H- PJOB.MAC 172 1980 103 2148
SEARCH%IOPARM
TITLE.%PJOB
; PJOB(N:INTEGER):INTEGER - RETURNS JOB NUMBER IN N AND AS VALUE.
;
PJOB::%CALLI%R,30%%; GET IT
%MOVEM%R,@1(A)%%; STASH IT
%POPJ%P,%%; RETURN
END
#-H- PRINTF.RAT 4212 1980 103 2148
INCLUDE RATDEF
 
DEFINE(MAXCHARS,30)
# PRINTF - PRINT ARGUMENTS ACCORDING TO S
   SUBROUTINE PRINTF(S)
   CHARACTER S(ARB)
   INTEGER LLC, LOC, ARG, UNPACK, CTOI, LENGTH, FTOC, XTOC, R50TOC, SIXTOC
   INTEGER FD, I, J, C, W, P, AP, LEN, ADR
   INTEGER FMT(MAXLINE), BUF(MAXCHARS)
   INTEGER MEMOFF, MEM(1)
 
   MEMOFF = 1 - LOC(MEM(1))   # FIND ADDRESSING OFFSET
   FD = STDOUT
   AP = 2
   IF (S(1) > 127 \ S(1) < 0)
      LEN = UNPACK(MAXLINE, S, FMT)
   ELSE
      CALL SCOPY(S, 1, FMT, 1)
   FOR (I = 1; FMT(I) ^= EOS; I = I + 1) <
      C = FMT(I)
      IF (C == BACKSLASH) <    # SPECIAL CHARACTER
         I = I + 1
         C = FMT(I)
         IF (C == DIG0)
            RETURN
         ELSE IF (C == LETT \ C == BIGT)
            C = TAB
         ELSE IF (C == LETN \ C == BIGN)
            C = NEWLINE
         ELSE IF (C == LETB \ C == BIGB)
            C = BACKSPACE
         CALL PUTCH(C, FD)
         !
      ELSE IF (C ^= PERCENT)  # ORDINARY CHARACTER
         CALL PUTCH(C, FD)
      ELSE <    # FORMAT CODE
         I = I + 1
         W = CTOI(FMT, I)
         IF (FMT(I) == PERIOD) <
            I = I + 1
            P = CTOI(FMT, I)
            !
         ELSE
            P = -1
         C = FMT(I)
         ADR = ARG(AP) + MEMOFF  # COMPUTE INDEX IN MEM OF ARGUMENT
         IF (C == LETD \ C == BIGD)         # %WD PRINT DECIMAL INTEGER
            CALL PUTINT(MEM(ADR), W, FD)
         ELSE IF (C == LETO \ C == BIGO) <  # %WO PRINT OCTAL INTEGER
            LEN = XTOC(MEM(ADR), BUF, MAXCHARS, 8)
            CALL PUTSTR(BUF, W, FD)
            !
         ELSE IF (C == LETX \ C == BIGX) <  # %W.BX PRINT INTEGER IN BASE B
            IF (P < 2 \ P > 36)%# DEFAULT IS HEX
               P = 16
            LEN = XTOC(MEM(ADR), BUF, MAXCHARS, P)
            CALL PUTSTR(BUF, W, FD)
            !
         ELSE IF (C == LETS \ C == BIGS) <  # %WS PRINT STRING
            IF (MEM(ADR) <= 127 & MEM(ADR) > 0)  # UNPACKED STRING
               LEN = LENGTH(MEM(ADR))
            ELSE     # PACKED STRING
               FOR (LEN = 0; LLC(C, MEM(ADR), LEN) ^= 0; LEN = LEN + 1)
                  IF (C == BACKSLASH)
                     IF (LLC(C, MEM(ADR), LEN+1) == DIG0)
                        BREAK
            IF (P > 0 & P < LEN)  # TRUNCATE IF PRECISION GIVEN
               LEN = P
            FOR ( ; W > LEN; W = W - 1)
               CALL PUTCH(BLANK, FD)
            IF (MEM(ADR) <= 127 & MEM(ADR) > 0)  # UNPACKED STRING
               FOR (J = 0; J < LEN; J = J + 1)
                  CALL PUTCH(MEM(ADR+J), FD)
            ELSE   # PACKED STRING
               FOR (J = 0; J < LEN; J = J + 1)
                  CALL PUTCH(LLC(C, MEM(ADR), J), FD)
            FOR ( ; W < -LEN; W = W + 1)
               CALL PUTCH(BLANK, FD)
            !
         ELSE IF (C == LETF \ C == BIGF) <  # %W.DF PRINT REAL NUMBER
            IF (P == -1)%# DEFAULT PRECISION IS 6
               P = 6
            LEN = FTOC(MEM(ADR), BUF, P, MAXCHARS)
            CALL PUTSTR(BUF, W, FD)
            !
         ELSE IF (C == LETE \ C == BIGE) <  # %W.DE PRINT REAL NUMBER
            IF (P == -1)
               P = 6
            LEN = FTOC(MEM(ADR), BUF, -P, MAXCHARS)  # FORCE E FORMAT
            CALL PUTSTR(BUF, W, FD)
            !
         ELSE IF (C == LETC \ C == BIGC) <  # %WC PRINT CHARACTER
            FOR ( ; W > 1; W = W - 1)
               CALL PUTCH(BLANK, FD)
            IF (MEM(ADR) <= 127 & MEM(ADR) > 0)
               CALL PUTCH(MEM(ADR), FD)
            ELSE
               CALL PUTCH(LLC(C, MEM(ADR), 0), FD)
            FOR ( ; W < -1; W = W + 1)
               CALL PUTCH(BLANK, FD)
            !
         ELSE IF (C == LETN \ C == BIGN)    # %N CHANGE OUTPUT FILE
            FD = MEM(ADR)
         ELSE IF (C == LETR \ C == BIGR) <  # %WR PRINT RADIX50 SYMBOL
            LEN = R50TOC(MEM(ADR), BUF, MAXCHARS)
            CALL PUTSTR(BUF, W, FD)
            !
         ELSE IF (C == LETK \ C == BIGK) <  # %WK PRINT SIXBIT SYMBOL
            LEN = SIXTOC(MEM(ADR), BUF, MAXCHARS)
            CALL PUTSTR(BUF, W, FD)
            !
         ELSE <   # FUNNY CODE
            CALL PUTCH(C, FD)
            NEXT
            !
         AP = AP + 1
         !
      !
   END
#-H- PTY.MAC 2990 1980 103 2149
TITLE%PTY - PSEUDO TTY DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%PTYOP$, PTYCL$, PTYRD$, PTYWR$
 
RELOC%400000
PHASE%%; PTY BLOCK LAYOUT
PTYIBH:%BLOCK%3%%; INPUT BUFFER HEADER
PTYOBH:%BLOCK%3%%; OUTPUT BUFFER HEADER
PTYIBF:%BLOCK%23%%; INPUT BUFFER
PTYOBF:%BLOCK%23%%; OUTPUT BUFFER
PTYLEN==.
DEPHASE
RELOC%400000
 
; PTYOP$ - OPEN A PTY; F CONTAINS FILE BLOCK ADDRESS.
;
PTYOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE
%CAIE%Z,7%%; MUST BE CHARACTER
% JRST%$99
%MOVEI%Z,PTYLEN%; ALLOCATE A PTY BLOCK
%PUSHJ%P,ALCBK$##
% JRST%$99%%; CAN'T ALLOCATE
%MOVEM%C,DEVPTR(F)%; STASH POINTER IN FILE BLOCK
%PUSHJ%P,FDCHN$##%; FIND A CHANNEL
%JUMPE%Z,$98%%; NONE AVAILABLE
%MOVEM%Z,CHANNEL(F)%; STORE IN FILE BLOCK
%MOVEI%Z,1%%; OPEN IN ASCII LINE MODE
%MOVEM%Z,OPNBK$##
%HRRI%Z,PTYIBH(C)
%HRLI%Z,PTYOBH(C)%; FORM AND STORE BUFFER HEADER POINTERS
%MOVEM%Z,OPNBK$+2
%PUSHJ%P,XUUO$##%; OPEN THE PTY
%OPEN.%0,OPNBK$##
% JRST%$98%%; FAILED
%PUSH%P,.JBFF##%; SAVE FIRST FREE POINTER
%MOVEI%Z,PTYIBF(C)%; POINT TO BUFFER SPACE
%MOVEM%Z,.JBFF%%; FAKE .JBFF FOR BUFFER FORMATION
%PUSHJ%P,XUUO$%%; FORMAT INPUT AND OUTPUT BUFFERS
%INBUF%0,1%%; NOTE ORDER IS IMPORTANT!
%PUSHJ%P,XUUO$
%OUTBUF%0,1
%POP%P,.JBFF%%; RESTORE .JBFF
%CLEAR%R,%%; INDICATE SUCCESS
%POPJ%P,
$98:%PUSHJ%P,FREBK$##%; FREE CORE BLOCK
$99:%MOVE%R,[ERR]%%; RETURN ERROR INDICATION
%POPJ%P,
 
; PTYCL$ - CLOSE A PTY; FREES UP A PTY BLOCK.
;
PTYCL$::MOVE%C,DEVPTR(F)%; GET POINTER TO PTY BLOCK
%JUMPE%C,$4%%; IGNORE CLOSE ON CLOSED PTYS
%PUSHJ%P,XUUO$%%; CLOSE AND RELEASE THE PTY
%CLOSE%0,0
%PUSHJ%P,XUUO$
%RELEAS%0,0
%PUSHJ%P,FREBK$##%; FREE THE PTY BLOCK
$4:%CLEAR%R,%%; INDICATE SUCCESS
%POPJ%P,
 
; PTYRD$ - READ A PTY; POINTER TO STRING IN T1, MAX COUNT IN T2.
;
PTYRD$::PUSH%P,T2%%; SAVE COUNT
%MOVE%C,DEVPTR(F)%; POINT TO PTY BLOCK
$6:%SOSGE%PTYIBH+2(C)%; DECREMENT AND TEST BYTE COUNT
% JRST%$8%%; GO GET ANOTHER BUFFER FULL
%ILDB%Z,PTYIBH+1(C)%; GET A CHARACTER
%IDPB%Z,T1%%; STASH IT
%SOJLE%T2,$7%%; DECREMENT AND TEST COUNT
%CAIE%Z,C.LF%%; CHECK FOR END OF LINE
% JRST%$6%%; CONTINUE UNLESS HIT EOL
$7:%POP%P,R%%; GET BACK ORIGINAL COUNT
%SUB%R,T2%%; COMPUTE NUMBER OF CHARACTERS READ
%POPJ%P,%%; RETURN
$8:%PUSHJ%P,XUUO$%%; FILL A BUFFER
%IN%0,0
% SKIPA%%%; MUST CHECK FOR EMPTY BUFFER
%JRST%$9%%; END OF FILE
%SKIPE%PTYIBH+2(C)%; GET ANYTHING?
% JRST%$6%%; YES, GO GET IT
%JRST%$7%%; NO, RETURN FROM READ CALL
$9:%AOS%EOFFLAG(F)%; HERE ON EOF, LIGHT EOF FLAG
%CAME%T2,(P)%%; DID WE GET ANYTHING?
% JRST%$7%%; YES, DON'T GIVE EOF YET
%POP%P,R%%; NO, TOSS COUNT
%MOVE%R,[EOF]%%; GIVE AN EOF
%POPJ%P,
 
; PTYWR$ - WRITE TO A PTY; POINTER TO STRING IN T1, COUNT IN T2.
;
PTYWR$::MOVE%C,DEVPTR(F)%; POINT TO PTY BLOCK
$12:%SOSG%PTYOBH+2(C)%; DECREMENT AND TEST BYTE COUNT
% JRST%$14%%; DUMP THE BUFFER
$13:%ILDB%Z,T1%%; GET A BYTE
%IDPB%Z,PTYOBH+1(C)%; DEPOSIT THE BYTE
%SOJG%T2,$12%%; CONTINUE UNTIL DONE
%PUSHJ%P,XUUO$##%; BUT DUMP BUFFER ONCE MORE
%OUTPUT%0,0
%POPJ%P,%%; RETURN
$14:%PUSHJ%P,XUUO$%%; DO THE OUTPUT
%OUTPUT%0,0
%JRST%$13%%; GO ON
 
END
#-H- PUTCH.RAT 247 1980 103 2149
INCLUDE RATDEF
 
# PUTCH - WRITE  C  TO FILE  FD
CHARACTER FUNCTION PUTCH(C, FD)
   CHARACTER C
   INTEGER FD, JUNK, WRITEF
 
   IF (C == NEWLINE)
      JUNK = WRITEF(13, 1, FD)  # NEED A CARRIAGE RETURN
   JUNK = WRITEF(C, 1, FD)
   RETURN (C)
END
#-H- QQALLC.KA 1320 1980 103 2149
DEFINE(JBFF,8%0121+MEMOFF)%# FOR KA'S
DEFINE(JBREL,8%044+MEMOFF)
# QQALLC(N) - ALLOCATE N WORDS, RETURN ADDRESS OF FIRST WORD (KA10)
INTEGER FUNCTION QQALLC(N)
   INTEGER N
   INTEGER I, M, QQLOC, QQCORE
   INCLUDE CALLOC
 
   IF (MEMOFF == 0) <%# INITIALIZE
      MEMOFF = 1 - QQLOC(MEM(1))
      M = MEM(JBREL) - MEM(JBFF) + 1
      MEM(MEM(JBFF)+MEMOFF) = M
      MEM(MEM(JBREL)+MEMOFF) = M
      !
   REPEAT <
      M = N + 2%# ACCOUNT FOR OVERHEAD
      FOR (I = MEM(JBFF) + MEMOFF; I <= MEM(JBREL) + MEMOFF; )
         IF (MEM(I) < 0)
            I = I - MEM(I)%# BUMP PAST ALLOCATED BLOCK
         ELSE IF (MEM(I) < M)
            I = I + MEM(I)%# FREE, BUT TOO SMALL
         ELSE <%# FOUND A HOLE
            IF (MEM(I) > M + 2) <%# DIVIDE HOLE INTO TWO SMALLER ONES
               MEM(I+M) = MEM(I) - M
               MEM(I+MEM(I)-1) = MEM(I) - M
               MEM(I) = M
               MEM(I+M-1) = M
               !
            MEM(I+MEM(I)-1) = -MEM(I)
            MEM(I) = -MEM(I)
            RETURN(I - MEMOFF + 1)
            !
      I = MEM(JBREL)
      IF (QQCORE(I + M) == NO)%# NEED TO GET MORE CORE
         RETURN(-1)%# DIDN'T GET ENOUGH
      M = MEM(JBREL) - I%# DETERMINE ACTUAL AMOUNT OBTAINED
      MEM(I+MEMOFF+1) = M
      MEM(I+MEMOFF+M) = M
      !%# DO IT AGAIN (GUARANTEED SUCCESS)
END
#-H- QQALLC.RAT 1315 1980 103 2149
# QQALLC(N) - ALLOCATE N WORDS, RETURN ADDRESS OF FIRST WORD
INTEGER FUNCTION QQALLC(N)
   INTEGER N
   INTEGER I, M, QQLOC, QQAPAG
   INCLUDE CALLOC
 
   IF (MEMOFF == 0) <%# INITIALIZE
      MEMOFF = 1 - QQLOC(MEM(1))
      LOWPAG = 448
      !
   REPEAT <
      M = N + 2%# ACCOUNT FOR OVERHEAD
      FOR (I = LOWPAG*512 + MEMOFF; I < 448*512 + MEMOFF; )
         IF (MEM(I) < 0)
            I = I - MEM(I)%# BUMP PAST ALLOCATED BLOCK
         ELSE IF (MEM(I) < M)
            I = I + MEM(I)%# FREE, BUT TOO SMALL
         ELSE <%# FOUND A HOLE
            IF (MEM(I) > M + 2) <%# DIVIDE HOLE INTO TWO SMALLER ONES
               MEM(I+M) = MEM(I) - M
               MEM(I+MEM(I)-1) = MEM(I) - M
               MEM(I) = M
               MEM(I+M-1) = M
               !
            MEM(I+MEM(I)-1) = -MEM(I)
            MEM(I) = -MEM(I)
            RETURN(I - MEMOFF + 1)
            !
      I = LOWPAG%# MAP IN SOME MORE PAGES
      FOR (M = M/512 + 1; M > 0; M = M - 1) <
         IF (QQAPAG(I - 1) == NO)
            BREAK
         I = I - 1
         !
      IF (I < LOWPAG) <
         MEM(I*512+MEMOFF) = (LOWPAG - I)*512
         MEM(LOWPAG*512+MEMOFF-1) = (LOWPAG - I)*512
         LOWPAG = I
         !
      IF (M > 0)
         RETURN(-1)%# DIDN'T GET ENOUGH
      !%# DO IT AGAIN (GUARANTEED SUCCESS)
END
#-H- QQAPAG.RAT 180 1980 103 2149
# QQAPAG - ADD PAGE N TO WORKING SET
INTEGER FUNCTION QQAPAG(N)
   INTEGER N
   INTEGER ARG(2), QQPAGE
 
   ARG(1) = 1%# SET UP ARGUMENTS
   ARG(2) = N
   RETURN(QQPAGE(1,ARG))
END
#-H- QQARG.MAC 269 1980 103 2149
SEARCH%IOPARM
TITLE.%QQARG
; QQARG(I:INT):ADDR -- RETURN ADDRESS OF ARGUMENT I
;
QQARG::%MOVE%1,-1(17)%; ->INST FOLLOWING CALL TO CALLER
%MOVEI%1,@-2(1)%; ->CALLER'S ARG LIST
%ADD%1,@0(16)%; POINT AT HIS ARG I+1
%MOVEI%R,@-1(1)%; FETCH HIS ARG I
%POPJ%P,%%; RETURN
END
#-H- QQCLS.MAC 312 1980 103 2149
SEARCH%IOPARM
TITLE.%QQCLS
; QQCLS(MAJOR,MINOR,FILTAB BLOCK) - SWITCH ON CLOSE TABLE.
;
QQCLS::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVEI%F,@2(A)%%; POINT TO FILTAB BLOCK
%MOVE%T2,@0(A)%; GET MAJOR DEVICE NUMBER
%MOVE%T1,@1(A)%; GET MINOR DEVICE NUMBER
%JRST%@CLSW$##(T2)%; SWITCH TO PROPER CLOSE ROUTINE
END
#-H- QQCORE.MAC 241 1980 103 2149
SEARCH%IOPARM
TITLE.%QQCORE
; QQCORE(ARG) - PERFORM CORE UUO.  RETURNS NO IF UUO FAILED, YES OTHERWISE.
QQCORE::MOVE%T1,@0(A)%; GET ARGUMENT
%MOVEI%R,1%%; ASSUME SUCCESS
%CORE%T1,%%; DO IT
% CLEAR%R,%%; INDICATE ERROR
%POPJ%P,%%; RETURN
END
#-H- QQCRT.MAC 811 1980 103 2149
SEARCH%IOPARM
TITLE.%QQCRT
; QQCRT(MAJOR,MINOR,FILTAB BLOCK) - SWITCH ON CREATE TABLE.
;
QQCRT::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVEI%F,@2(A)%%; POINT TO FILTAB BLOCK
%CLEARM%DEVPTR(F)%; CLEAR DEVICE DATA POINTER
%LDB%T1,[SIZEPTR]%; GET BYTE SIZE
%SKIPN%T1
% MOVEI%T1,7%%; CHARACTER IS DEFAULT
%DPB%T1,[SIZEPTR]%; PUT IT BACK IN CASE DEFAULT
%MOVEI%Z,(POINT 0)%; CONSTRUCT BYTE POINTERS
%DPB%T1,[POINT 6,Z,29]
%HRLZM%Z,BYTEPTR(F)
%ORI%Z,(POINT 0,(T1))
%MOVNS%T1
%ADDI%T1,^D36%%; COMPUTE POSITION INDICATOR
%DPB%T1,[POINT 6,Z,23]
%HRLZM%Z,PACKPTR(F)
%MOVEI%T1,^D36%%; COMPUTE BYTES PER WORD
%LDB%Z,[SIZEPTR]
%IDIV%T1,Z
%MOVEM%T1,BYTEPW(F)%; SAVE FOR DEVICE DRIVERS
%MOVE%T2,@0(A)%; GET MAJOR DEVICE NUMBER
%MOVE%T1,@1(A)%; GET MINOR DEVICE NUMBER
%JRST%@CRSW$##(T2)%; SWITCH TO PROPER CREATE ROUTINE
END
#-H- QQCTOK.RAT 1723 1980 103 2149
INCLUDE RATDEF
DEFINE(MAXARG,60)
 
# QQCTOK - GET A COMMAND TOKEN
   INTEGER FUNCTION QQCTOK(T, TOK, FD)
   CHARACTER T, TOK(MAXARG)
   INTEGER FD
   CHARACTER QQGETC, C
   INTEGER I, NCOMMA
   INCLUDE CARGS
 
   FOR (C = QQGETC(C, FD, ESCAPE); C == BLANK \ C == TAB;
      C = QQGETC(C, FD, ESCAPE))
         ;
   IF (C == NEWLINE \ C == EOF) <
      TOK(1) = C
      TOK(2) = EOS
      T = EOF
      !
   ELSE IF (C == DQUOTE \ C == SQUOTE) <      # QUOTED ARGUMENT
      T = C
      TOK(1) = C
      FOR (I = 2; QQGETC(TOK(I), FD, -1) ^= EOF; I = I + 1)
         IF (TOK(I) == C \ TOK(I) == NEWLINE)
            BREAK
         ELSE IF (I > MAXARG)
            CALL QQERR1("ARGUMENT TOO LONG\0")
      IF (TOK(I) ^= C)
         CALL QQERR1("MISSING QUOTE\0")
      TOK(I+1) = EOS
      !
   ELSE IF (C == SEMICOL \ C == BAR) <%# COMMAND TERMINATOR
      TOK(1) = C
      TOK(2) = EOS
      T = C
      !
   ELSE  <   # REGULAR ARGUMENT
      NCOMMA = 0
      I = 1
      REPEAT <
         IF (C == NEWLINE \ C == BLANK \ C == TAB \
             C == SEMICOL \ C == BAR) <
                PEEK = C
                BREAK
                !
         IF (I >= MAXARG)
            CALL QQERR1("ARGUMENT TOO LONG\0")
         TOK(I) = C
         IF (C == STAR \ (I > 1 & C == QMARK))
            NMETA = NMETA + 1
         ELSE IF (C == LBRACK)
            NCOMMA = 0
         ELSE IF (C == RBRACK & NCOMMA == 0 & I >= 3) <
            IF (TOK(I-2) ^= LBRACK \ TOK(I-1) ^= MINUS)%# [-] CASE
               NMETA = NMETA + 1
            !
         ELSE IF (C == COMMA)
            NCOMMA = NCOMMA + 1
         I = I + 1
         ! UNTIL (QQGETC(C, FD, ESCAPE) == EOF)
      TOK(I) = EOS
      T = ALPHA
      !
   RETURN(T)
   END
#-H- QQDEV.MAC 210 1980 103 2149
SEARCH%IOPARM
TITLE.%QQDEV
; QQDEV(NAME) - DO DEVTYP UUO FOR DEVICE NAME (IN SIXBIT).
;
QQDEV::MOVE%R,@0(A)%%; GET THE NAME
%CALLI%R,53%%; GET GOOD BITS
% MOVE%R,[ERR]%%; FAILED, RETURN ERROR CODE
%POPJ%P,
END
#-H- QQERR1.RAT 156 1980 103 2149
INCLUDE RATDEF
 
# QQERR1 - PRINT ERROR MESSAGE AND DIE
   SUBROUTINE QQERR1(BUF)
   INTEGER BUF(ARB)
 
   CALL QQPUTS(ERROUT, BUF, "\N\0", 0)
   STOP
   END
#-H- QQERR2.RAT 193 1980 103 2149
INCLUDE RATDEF
 
# QQERR2 - PRINT CAN'T OPEN FILE MESSAGE AND DIE
   SUBROUTINE QQERR2(BUF)
   INTEGER BUF(MAXLINE)
 
   CALL QQPUTS(ERROUT, BUF, ": CAN'T OPEN\N\0", 0)
   STOP
   RETURN
   END
#-H- QQEXIT.MAC 775 1980 103 2149
SEARCH%IOPARM
RUNPTR==CARGS##+1
TITLE.%QQEXIT
ENTRY%EXIT.
; QQEXIT -- EXIT TO THE MONITOR.  CLOSES ALL FILES.
;
EXIT.::
QQEXIT::MOVEI%Z,MAXFILES-1%; INITIALIZE TO CLOSE ALL FILES
%MOVEM%Z,FD
%MOVEI%A,[EXP <-1,,0>,FD]+1
$2:%PUSHJ%P,CLOSE##%; CLOSE A FILE
%SOSL%FD%%; DECREMENT TO NEXT DESCRIPTOR
% JRST%$2%%; LOOP TILL DONE
%SKIPN%T1,RUNPTR%; ANOTHER PROGRAM TO RUN?
% JRST%$3%%; NOPE
%MOVEM%T1,NAMPTR%; YES, SAVE ITS ADDRESS
%MOVEI%A,[EXP <-2,,0>,1B13!NAMPTR,[1]]+1
%PUSHJ%P,QQRUN##%; YES, RUN IT
$3:%MOVEI%A,[EXP <-1,,0>,[ASCIZ "PIP.TMP[,]"]]+1%; REMOVE PIPE
%PUSHJ%P,QQRM##
%MOVEI%A,[EXP <-1,,0>,[ASCIZ "TMP:ARG"]]+1%; REMOVE ARG FILE
%PUSHJ%P,QQRM##
%CALLI%1,12%%; EXIT EXIT
%JRST%.-1%%; DON'T CONTINUE
RELOC
NAMPTR:
FD:%BLOCK%1%%; HOLDS ARGUMENT TO CLOSE & RUN
RELOC
END
#-H- QQFREE.KA 691 1980 103 2149
DEFINE(JBFF,8%0121+MEMOFF)%# FOR KA'S
DEFINE(JBREL,8%044+MEMOFF)
# QQFREE - FREE CORE POINTED TO BY P.
SUBROUTINE QQFREE(P)
   INTEGER P
   INTEGER I, M
   INCLUDE CALLOC
 
   I = P + MEMOFF - 1
   MEM(I) = -MEM(I)%# FREE UP THIS BLOCK
   MEM(I+MEM(I)-1) = MEM(I)
   WHILE (I > MEM(JBFF) + MEMOFF) <%# COALESCE PREDECESSORS
      IF (MEM(I-1) < 0)
         BREAK
      M = MEM(I-1) + MEM(I)
      I = I - MEM(I-1)
      MEM(I) = M
      MEM(I+M-1) = M
      !
   I = I + MEM(I) - 1
   WHILE (I < MEM(JBREL) + MEMOFF) <%# COALESCE SUBSEQUENTS
      IF (MEM(I+1) < 0)
         BREAK
      M = MEM(I) + MEM(I+1)
      I = I + MEM(I+1)
      MEM(I) = M
      MEM(I-M+1) = M
      !
   RETURN
END
#-H- QQFREE.RAT 628 1980 103 2149
# QQFREE - FREE CORE POINTED TO BY P.
SUBROUTINE QQFREE(P)
   INTEGER P
   INTEGER I, M
   INCLUDE CALLOC
 
   I = P + MEMOFF - 1
   MEM(I) = -MEM(I)%# FREE UP THIS BLOCK
   MEM(I+MEM(I)-1) = MEM(I)
   WHILE (I > LOWPAG*512 + MEMOFF) <%# COALESCE PREDECESSORS
      IF (MEM(I-1) < 0)
         BREAK
      M = MEM(I-1) + MEM(I)
      I = I - MEM(I-1)
      MEM(I) = M
      MEM(I+M-1) = M
      !
   I = I + MEM(I) - 1
   WHILE (I < 448*512 - 1 + MEMOFF) <%# COALESCE SUBSEQUENTS
      IF (MEM(I+1) < 0)
         BREAK
      M = MEM(I) + MEM(I+1)
      I = I + MEM(I+1)
      MEM(I) = M
      MEM(I-M+1) = M
      !
   RETURN
END
#-H- QQGETC.RAT 510 1980 103 2149
INCLUDE RATDEF
DEFINE(EFLAG,8%400000)
 
# QQGETC - GET A COMMAND CHARACTER, USING EC AS ESCAPE CHARACTER
   CHARACTER FUNCTION QQGETC(C, FD, EC)
   CHARACTER C, EC
   INTEGER FD
   CHARACTER GETCH
   INCLUDE CARGS
 
   IF (PEEK ^= 0)
      C = PEEK
   ELSE
      C = GETCH(C, FD)
   PEEK = 0
   IF (C == EC)
      IF (GETCH(PEEK, FD) == NEWLINE) <
         C = BLANK
         PEEK = 0
         !
      ELSE
         PEEK = PEEK \ EFLAG
   ELSE IF (C == NEWLINE & FD ^= STDIN)
      C = BLANK
   RETURN(C)
   END
#-H- QQGLOB.RAT 1386 1980 103 2149
INCLUDE RATDEF
DEFINE(EFLAG,8%400000)
 
# QQGLOB - EXECUTE GLOB TO EXPAND ARGUMENTS
   SUBROUTINE QQGLOB
   INTEGER FDI, FDO, I, P
   CHARACTER C
   INTEGER OPEN, CREATE
   CHARACTER GETCH
   INCLUDE CARGS
   STRING GLOB "STDN:GLOB[5,13,TOOLS]"
 
   FDI = OPEN("TMP:ARG", READ)
   IF (FDI == ERR)
      FDI = CREATE("TMP:ARG", READ)
   FDO = CREATE("TMP:ARG", WRITE)
   IF (FDI == ERR \ FDO == ERR)
      CALL QQERR1("CAN'T CREATE ARG FILE FOR GLOB\0")
   CALL QQPUTS(FDO, GLOB, 0)
   IF (GETCH(C, FDI) ^= EOF) <
      CALL PUTCH(SEMICOL, FDO)
      CALL PUTCH(C, FDO)
      !
   WHILE (GETCH(C, FDI) ^= EOF)
      CALL PUTCH(C, FDO)
   CALL CLOSE(FDI)
   CALL CLOSE(FDO)
   FDO = CREATE("TMP:GLB", WRITE)
   IF (FDO == ERR)
      CALL QQERR1("CAN'T CREATE TEMPORARY FILE FOR GLOB\0")
   FOR (P = ARGPTR; P ^= 0; P = MEM(P+MEMOFF)) <
      CALL WRITEF(QQLEN(MEM(P+MEMOFF+2)), 1, FDO)
      CALL QQPUTS(FDO, MEM(P+MEMOFF+2), 0)
      !
   IF (INPTR ^= 0) <
      CALL WRITEF(QQLEN(MEM(INPTR+MEMOFF+2)), 1, FDO)
      CALL QQPUTS(FDO, MEM(INPTR+MEMOFF+2), 0)
      !
   IF (OUTPTR ^= 0) <
      CALL WRITEF(QQLEN(MEM(OUTPTR+MEMOFF+2)), 1, FDO)
      CALL QQPUTS(FDO, MEM(OUTPTR+MEMOFF+2), 0)
      !
   IF (ERRPTR ^= 0) <
      CALL WRITEF(QQLEN(MEM(ERRPTR+MEMOFF+2)), 1, FDO)
      CALL QQPUTS(FDO, MEM(ERRPTR+MEMOFF+2), 0)
      !
   CALL CLOSE(FDO)
   CALL RUN(GLOB, 1)
   RETURN
   END
#-H- QQINIT.RAT 4533 1980 103 2149
INCLUDE RATDEF
DEFINE(MAXARG,60)
DEFINE(NFILES,5)%# MAXIMUM DEPTH OF INCLUDE ARGUMENTS
DEFINE(EFLAG,8%400000)
 
# QQINIT - INITIALIZE STDIN, STDOUT, AND ERROUT AND THE COMMAND ARGS
   SUBROUTINE QQINIT
   INTEGER I, FD, FDO, P, META, LEVEL, IFILES(NFILES), PEEKED(NFILES)
   INTEGER QQLOC, OPEN, CREATE, QQALLC, QQLEN
   CHARACTER C, T, ARG(MAXARG)
   CHARACTER QQCTOK, QQGETC
   INCLUDE CARGS
   STRING PIPE "  >PIP.TMP[,]"
   STRING RUN "RUN"
 
   MEMOFF = 1 - QQLOC(MEM(1))%# GET ADDRESSING OFFSET
   IF (OPEN("TTY:", READ) ^= STDIN \ OPEN("TTY:", WRITE) ^= STDOUT \
       OPEN("TTY:", WRITE) ^= ERROUT)
          STOP 100
   ARG(1) = EOS
   PEEK = 0
   FD = STDIN
   IF (TTYFLG == NO)
      FD = OPEN("TMP:ARG", READ)%# READ ARGS FROM COMMAND FILE
   IF (FD == STDIN) <
      CALL QQRM("TMP:ARG")
      IF (QQCTOK(T, ARG, FD) == ALPHA) <
         FOR (I = 1; ARG(I) ^= EOS & RUN(I) ^= EOS; I = I + 1)
            IF (ARG(I) ^= RUN(I) & ARG(I) ^= RUN(I) - LETA + BIGA)
                BREAK
         IF (ARG(I) == EOS) <%# RUN COMMAND SEEN
            FOR (I = 1; QQGETC(C, FD, -1) ^= EOF; ) <
               ARG(I) = C
               IF (I < MAXARG)
                  I = I + 1
               IF (C == SEMICOL \ C == MINUS \ C == NEWLINE)
                  BREAK
               !
            ARG(I-1) = EOS
            IF (C == NEWLINE)
               PEEK = C
            !
         !
      !
   ELSE IF (FD ^= ERR)
      T = QQCTOK(T, ARG, FD)
   ARGPTR = QQALLC(QQLEN(ARG) + 3)
   MEM(ARGPTR+MEMOFF) = 0
   MEM(ARGPTR+MEMOFF+1) = ALPHA
   CALL QQSCPY(ARG, 1, MEM, ARGPTR + MEMOFF + 2)
   IF (FD == ERR)
      RETURN
   LEVEL = 0
   META = 0
   P = ARGPTR
   REPEAT <
      NMETA = 0
      IF (QQCTOK(T, ARG, FD) == EOF) <
         IF (LEVEL == 0)
            BREAK
         CALL CLOSE(FD)
         FD = IFILES(LEVEL)
         PEEK = PEEKED(LEVEL)
         LEVEL = LEVEL - 1
         NEXT
         !
      IF (LEVEL == 0 & (T == SEMICOL \ T == NEWLINE \ T == BAR))
         BREAK
      I = QQALLC(QQLEN(ARG) + 3)
      IF (I == -1)
         CALL QQERR1("TOO MANY ARGUMENTS\0")
      MEM(I+MEMOFF) = 0
      MEM(I+MEMOFF+1) = T
      CALL QQSCPY(ARG, 1, MEM, I + MEMOFF + 2)
      IF (ARG(1) == LESS)
         INPTR = I
      ELSE IF (ARG(1) == GREATER)
         OUTPTR = I
      ELSE IF (ARG(1) == QMARK)
         ERRPTR = I
      ELSE IF (ARG(1) == BANG)
         RUNPTR = I + 3%%# POINT DIRECTLY TO NAME
      ELSE IF (ARG(1) == ACCENT) <
         LEVEL = LEVEL + 1
         IF (LEVEL > NFILES)
            CALL QQERR1("INCLUDE FILES NESTED TOO DEEPLY\0")
         IFILES(LEVEL) = FD
         PEEKED(LEVEL) = PEEK
         FD = OPEN(ARG(2), READ)
         IF (FD == ERR)
            CALL QQERR2(ARG(2))
         PEEK = 0
         !
      ELSE <
         NARGS = NARGS + 1
         MEM(P+MEMOFF) = I
         P = I
         IF (NMETA > 0)
            META = META + 1
         !
      !
   IF (T == BAR \ T == SEMICOL) <%# MORE COMMANDS COMING
      IF (QQCTOK(C, ARG, FD) == EOF)
         CALL QQERR1("SYNTAX ERROR\0")
      RUNPTR = QQLOC(ARG)
      FDO = CREATE("TMP:ARG", WRITE)
      IF (FDO == ERR)
         CALL QQERR1("CAN'T CREATE TEMPORARY FILE\0")
      CALL QQPUTS(FDO, ARG, 0)
      IF (T == BAR) <%# THIS IS A PIPE; WRITE <PIPE TO TMP FILE
         OUTPTR = QQLOC(PIPE)
         CALL QQPUTS(FDO, " <\0", PIPE(4), 0)
         !
      WHILE (QQGETC(C, FD, ESCAPE) ^= EOF) <
         CALL PUTCH(C & ^EFLAG, FDO)
         IF (C == NEWLINE)
            BREAK
         !
      CALL CLOSE(FDO)
      !
   ELSE IF (FD ^= STDIN)
      CALL QQRM("TMP:ARG")
   IF (INPTR ^= 0) <  # RE-DIRECT STANDARD INPUT
      I = INPTR + MEMOFF + 2
      CALL CLOSE(STDIN)
      IF (OPEN(MEM(I+1), READ) == ERR)
         CALL QQERR2(MEM(I+1))
      !
   IF (OUTPTR ^= 0) <  # RE-DIRECT STANDARD OUTPUT
      I = OUTPTR + MEMOFF + 2
      CALL CLOSE(STDOUT)
      IF (MEM(I+1) == GREATER) <%# APPEND TO STANDARD OUTPUT
         IF (OPEN(MEM(I+2), WRITE) == ERR)
            IF (CREATE(MEM(I+2), WRITE) == ERR)
               CALL QQERR2(MEM(I+2))
         CALL SEEK(-1, STDOUT)
         !
      ELSE
         IF (CREATE(MEM(I+1), WRITE) == ERR)
            CALL QQERR2(MEM(I+1))
      !
   IF (ERRPTR ^= 0) <  # RE-DIRECT ERROR OUTPUT
      I = ERRPTR + MEMOFF + 2
      CALL CLOSE(ERROUT)
      IF (CREATE(MEM(I+1), WRITE) == ERR) <
         IF (OPEN("TTY:", WRITE) == ERR)
            STOP 102
         CALL QQERR2(MEM(I+1))
         !
      !
   IF (FD ^= STDIN)
      CALL CLOSE(FD)
   IF (META > 0)
      CALL QQGLOB
   RETURN
   END
#-H- QQLEN.RAT 188 1980 103 2149
INCLUDE RATDEF
 
# QQLEN - COMPUTE LENGTH OF STRING
   INTEGER FUNCTION QQLEN(STR)
   INTEGER STR(ARB)
 
   FOR (QQLEN = 0; STR(QQLEN+1) ^= EOS; QQLEN = QQLEN + 1)
      ;
   RETURN
   END
#-H- QQLLC.MAC 401 1980 103 2149
SEARCH%IOPARM
TITLE.%QQLLC
; QQLLC(C,A,I):C - GET THE ITH CHARACTER (0-BASED) FROM A IN C.
;
QQLLC::%HRRZ%1,@2(16)%; GET I
%IDIVI%1,5%%; COMPUTE WORD AND BYTE OFFSET
%ADDI%1,@1(16)%; ADD IN ADDRESS
%HLL%1,[POINT 7,0%; MAKE IT A POINTER
%%   POINT 7,0,6
%%   POINT 7,0,13
%%   POINT 7,0,20
%%   POINT 7,0,27](2)
%ILDB%0,1%%; EXTRACT THE CHARACTER
%MOVEM%0,@0(16)%; STORE RESULT
%POPJ%17,%%; RETURN
END
#-H- QQLOC.MAC 190 1980 103 2149
SEARCH%IOPARM
TITLE.%QQLOC
; QQLOC(V:VAR):ADDR -- RETURN ADDRESS OF VARIABLE V.
;
QQLOC:: MOVEI   R,@0(16)        ; MOVE ADDR TO RESULT REGISTER
        POPJ    P,              ; RETURN
END
#-H- QQOPEN.RAT 1513 1980 103 2149
INCLUDE RATDEF
INCLUDE IODEFS
DEFINE(NULLDEV,-18426626048)%# NUL IN SIXBIT
DEFINE(TMPDEV,-12117344256)%# TMP IN SIXBIT
DEFINE(TMPCORDEV,-12117197838)%# TMPCOR IN SIXBIT
DEFINE(MTDEV,-19528679424)%# MT IN SIXBIT
 
# QQOPEN - CREATE/OPEN NAME ACCORDING TO MODE, RETURN FILE DESCRIPTOR
INTEGER FUNCTION QQOPEN(FCT, NAME, MODE)
   CHARACTER NAME(ARB)
   INTEGER MODE, FCT
   EXTERNAL FCT
   INTEGER FD, I, M, DEVTAB(14)
   INTEGER QQPARS, QQDEV
   INCLUDE CIOSYS
   DATA DEVTAB/3, 0, 4, 5, 0, 0, 0, 6, 0, 0, 7, 0, 0, 0/
 
   FOR (FD = 1; FD <= MAXFILES; FD = FD + 1)  # FIND A DESCRIPTOR
      IF (FDTAB(FD) == 0)
         BREAK
   IF (FD > MAXFILES)
      RETURN (ERR)
   FOR (I = 1; I < FBLEN*MAXFILES; I = I + FBLEN)   # FIND A FILE BLOCK
      IF (FILTAB(I+USECNT) == 0)
         BREAK
   IF (I >= FBLEN*MAXFILES)
      RETURN (ERR)
   IF (QQPARS(NAME, OPNBLK, 9) == ERR)
      RETURN (ERR)
   M = QQDEV(OPNBLK(2))   # DETERMINE DEVICE NUMBERS
   IF (M == ERR \ (M & 63) > 13)
      M = 0
   ELSE
      M = DEVTAB((M&63)+1)
   IF (OPNBLK(2) == NULLDEV)
      M = 1
   ELSE IF (OPNBLK(2) == TMPDEV \ OPNBLK(2) == TMPCORDEV)
      M = 8
   FILTAB(I+MAJOR) = M    # FILL IN FILE BLOCK
   FILTAB(I+MINOR) = 1
   IF (M == 4 & OPNBLK(2) == MTDEV)
      FILTAB(I+MINOR) = 2
   FILTAB(I+OPNMODE) = MODE
   FILTAB(I+EOFFLAG) = NO
   IF (FCT(FILTAB(I+MAJOR), FILTAB(I+MINOR), FILTAB(I+USECNT)) == ERR)
      RETURN (ERR)
   FDTAB(FD) = I   # CONNECT FILE DESCRIPTOR TO FILE BLOCK
   FILTAB(I+USECNT) = 1
   RETURN (FD-1)
END
#-H- QQOPN.MAC 807 1980 103 2149
SEARCH%IOPARM
TITLE.%QQOPN
; QQOPN(MAJOR,MINOR,FILTAB BLOCK) - SWITCH ON OPEN TABLE.
;
QQOPN::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVEI%F,@2(A)%%; POINT TO FILTAB BLOCK
%CLEARM%DEVPTR(F)%; CLEAR DEVICE DATA POINTER
%LDB%T1,[SIZEPTR]%; GET BYTE SIZE
%SKIPN%T1
% MOVEI%T1,7%%; CHARACTER IS DEFAULT
%DPB%T1,[SIZEPTR]%; PUT IT BACK IN CASE DEFAULT
%MOVEI%Z,(POINT 0)%; CONSTRUCT BYTE POINTERS
%DPB%T1,[POINT 6,Z,29]
%HRLZM%Z,BYTEPTR(F)
%ORI%Z,(POINT 0,(T1))
%MOVNS%T1
%ADDI%T1,^D36%%; COMPUTE POSITION INDICATOR
%DPB%T1,[POINT 6,Z,23]
%HRLZM%Z,PACKPTR(F)
%MOVEI%T1,^D36%%; COMPUTE BYTES PER WORD
%LDB%Z,[SIZEPTR]
%IDIV%T1,Z
%MOVEM%T1,BYTEPW(F)%; SAVE FOR DEVICE DRIVERS
%MOVE%T2,@0(A)%; GET MAJOR DEVICE NUMBER
%MOVE%T1,@1(A)%; GET MINOR DEVICE NUMBER
%JRST%@OPSW$##(T2)%; SWITCH TO PROPER OPEN ROUTINE
END
#-H- QQPAGE.MAC 545 1980 103 2149
SEARCH%IOPARM
TITLE.%QQPAGE
; QQPAGE(FCN,A) - PERFORM PAGE. UUO OPERATION PER FCN.  A IS PAGE.
; UUO ARGUMENT BLOCK.  RETURNS NO IF UUO FAILED, YES OTHERWISE.
;
QQPAGE::MOVE%T1,@0(A)%; GET FCN WORD
%TLNE%T1,-1%%; CHECK FOR CODE 6
% JRST%$1%%; DON'T ANYTHING ELSE
%MOVEI%T1,@1(A)%; GET ADDRESS OF ARGUMENT BLOCK
%HRL%T1,@0(A)%; INDICATE FUNCTION
%MOVEI%R,1%%; ASSUME SUCCESS
%PAGE.%T1,%%; DO IT
% CLEAR%R,%%; INDICATE ERROR
%POPJ%P,%%; RETURN
$1:%MOVE%R,T1%%; FUNCTION 6 REQUIRES SPECIAL TREATMENT
%PAGE.%R,
% MOVE%R,[ERR]%%; FAILED
%POPJ%P,
END
#-H- QQPARS.MAC 9102 1980 103 2149
SEARCH%IOPARM
TITLE.%QQPARS
; QQPARS(NAME,A,N) - PARSE FILE SPECIFICATION NAME INTO A.  RETURNS
; BLOCK IN A AS FOLLOWS: A(1) = 0, A(2) = DEVICE NAME IN SIXBIT
; (DEFAULT IS DSK), A(3) = 0, A(4) = N (N >= 5), A(5) = POINTER TO
; A(N+5) WHERE PATH IS STORED OR 0, A(6) = FILE NAME IN SIXBIT,
; A(7) = EXTENSION IN SIXBIT, A(8) = PRIVILEGE LEFT JUSTIFIED, A(9)
; THROUGH A(N+6) = 0, A(N+7) = PPN IF PRESENT, A(N+8) THROUGH A(N+13)
; = SFD NAMES IN SIXBIT, A(N+14) = 0.  A(1)...A(3) ARE IN THE CORRECT
; FORMAT FOR AN OPEN UUO, AND A(4)...A(N+14) ARE SUITABLE FOR LOOKUP
; AND ENTER UUOS.  NOTE THAT A(N+5)...A(N+14) ARE IN THE PROPER
; FORM FOR A PATH. UUO. RETURNS ERR IF THERE IS A SYNTAX ERROR.
;
DEV==1%%; OFFSETS TO FIELDS IN A
CNT==3
PTR==4
NAM==5
EXT==6
PRV==7
PTH==4%%; REALLY N+5
PPN==2%%; REALLY N+7
SFD==3%%; REALLY N+8
SFDEND==13%; REALLY N+14
ALPHA==1111%; RETURNED BY GTOK
;
QQPARS::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVEI%T1,@0(A)%; GET ADDRESS OF STRING
%MOVEM%T1,STPTR%; SAVE IT
        MOVE    T1,@STPTR       ; GET FIRST WORD OF STRING
        TLNE    T1,-1           ; PACKED OR UNPACKED?
         SKIPA  T1,[POINT 7,0,6]; PACKED
        MOVE    T1,[POINT 36,0,35]; UNPACKED
        ADDM    T1,STPTR        ; COMPLETE THE POINTER
%CLEARM%PSHDBK%%; CLEAR LOOKAHEAD
%MOVEI%F,@1(A)%%; GET ADDRESS OF ARRAY A
%ADD%F,@2(A)%%; MAKE LEFT HALF POINT TO PATH
%ADDI%F,PTH
%HRLS%F
%HRRI%F,@1(A)
%HRL%T1,F%%; ZAP A
%HRRI%T1,1(F)
%MOVE%T2,@2(A)%; COMPUTE END
%ADDI%T2,SFDEND(F)
%CLEARM%-1(T1)
%BLT%T1,(T2)%%; SPRAY IT WITH 0'S
%MOVSI%T1,'DSK'%; SET UP DEFAULT DEVICE
%MOVEM%T1,DEV(F)
%MOVE%T1,@2(A)%; LENGTH OF EXTENDED LOOKUP BLOCK
%MOVEM%T1,CNT(F)
%CLEAR%T1,%%; GET READY TO GO
 
LOOP:%PUSHJ%P,GTOK%%; GET A TOKEN
%CAIN%C,ALPHA%%; NAME?
% JRST%DONAM%%; YES
%CAIN%C,":"%%; COLON?
% JRST%DODEV%%; YES
%CAIN%C,"."%%; PERIOD?
% JRST%DOEXT%%; YES
%CAIN%C,"["%%; PPN?
% JRST%DOPPN%%; YES
%CAIN%C,"<"%%; BRACKET?
% JRST%DOPRV%%; YES
%CAMN%C,[EOS]%%; END OF STRING?
% JRST%DOEOS%%; YES
%MOVE%T2,[X.SKP!X.EOL]; WE SKIP THESE
%LSH%T2,(C)%%; SHIFT TO SIGN BIT
%JUMPL%T2,LOOP%%; IGNORE IF ONE OF THEM
%JRST%DOERR%%; YOU LOSE
 
DONAM:%PUSHJ%P,SKIPBL%; SKIP BLANKS
%PUSHJ%P,PEEKN%%; IS THERE A NAME COMING?
% JRST%LOOP%%; NO
%MOVEM%T1,NAM(F)%; YES, SAVE CURRENT NAME AS FILE NAME
%CLEAR%T1,%%; ZAP NAME
%JRST%LOOP%%; BACK FOR MORE
 
DODEV:%SKIPN%T1%%; IS THERE A NAME?
% JRST%DOERR%%; NO, YOU LOSE
%MOVEM%T1,DEV(F)%; YES, SAVE IT AS DEVICE
%CLEAR%T1,%%; CLEAR NAME
%JRST%LOOP%%; BACK FOR MORE
 
DOEXT:%SKIPE%T1%%; WAS THERE A FILE NAME?
% MOVEM%T1,NAM(F)%; YES
%CLEARB%T1,EXT(F)%; CLEAR NAME AND EXTENSION
%PUSHJ%P,PEEKN%%; IS THERE A NAME COMING
% JRST%LOOP%%; NO
%PUSHJ%P,GTOK%%; YES, GET NEXT TOKEN
%EXCH%T1,EXT(F)%; SAVE IT AND CLEAR T1
%CAIE%C,ALPHA%%; WAS THERE A NAME?
% HRROM%C,PSHDBK%; NO, PUT TOKEN BACK
%JRST%LOOP%%; BACK FOR MORE
 
DOPPN:%SKIPE%T1%%; WAS THERE A FILE NAME?
% MOVEM%T1,NAM(F)%; YES
%CLEARM%PTR(F)%%; ZAP POINTER TO PATH
%PUSHJ%P,SKIPBL%; SKIP BLANKS
%PUSHJ%P,GETCHR%; CHECK FOR [-] AND [] CASE
%CAIN%C,"]"
% JRST%LOOP%%; LEAVE PPN ZAPPED
%HLRZM%F,PTR(F)%; STASH POINTER TO PATH
%CAIE%C,"-"
% JRST%$6%%; NOPE TRY USUAL PPN
%PUSHJ%P,GTOK%%; GET NEXT TOKEN
%CAIE%C,"]"%%; MUST BE THIS
% JRST%DOERR
%HLR%T2,F%%; POINT TO PATH BLOCK
%HRLI%T2,10
%SETOM%(T2)%%; TO GET CURRENT PATH
%PATH.%T2,%%; GET DEFAULT PATH
% HALT%%%; CAN'T HAPPEN
%CLEAR%T1,%%; CLEAR NAME
%JRST%LOOP%%; BACK FOR MORE
$6:%HRROM%C,PSHDBK%; PUSH BACK CHARACTER
%MOVSS%F%%; SWAP HALVES SO POINTING TO PATH
%CLEAR%T1,%%; CLEAR NAME
%GETPPN%T2,%%; GET USER'S PPN
%MOVEM%T2,PPN(F)%; SAVE IT
%CLEARM%PPN+1(F)%; ZAP ANY OLD SFD NAMES
%PUSHJ%P,GETOCT%; GET PROJECT NUMBER
%SKIPG%T2%%; ZERO?
% HLRZ%T2,PPN(F)%; YES, USE DEFAULT
%PUSHJ%P,GTOK%%; GET NEXT TOKEN
%CAIG%T2,377777%; PROJECT NUMBER CAN'T BE TOO BIG
%CAIE%C,","%%; ALSO MUST TERMINATE WITH A COMMA
% JRST%DOERR%%; ERROR, TOO BIG OR NO COMMA
%HRLM%T2,PPN(F)%; STASH PROJECT NUMBER
%PUSHJ%P,GETOCT%; GET PROGRAMMER NUMBER
%SKIPG%T2%%; ZERO?
% HRRZ%T2,PPN(F)%; YES, USE DEFAULT
%PUSHJ%P,GTOK%%; GET NEXT TOKEN
%CAIE%C,"]"%%; TERMINATOR MUST BE A RIGHT BRACKET
%CAIN%C,","%%;  OR A COMMA
%CAILE%T2,377777%; AND IT MUST BE IN RANGE
% JRST%DOERR%%; LOSER
%HRRM%T2,PPN(F)%; STASH PROGRAMMER NUMBER
%CAIE%C,","%%; SFDS COMING?
% JRST%NOSFD%%; NO, GO BACK FOR MORE
%MOVEI%T2,SFD(F)%; POINT TO FIRST SFD SLOT
DOSFD:%PUSHJ%P,GTOK%%; GET A NAME
%CAIE%C,ALPHA%%; MUST BE A NAME
% JRST%DOERR%%; OR IT'S AN ERROR
%MOVEM%T1,(T2)%%; STASH IT
%ADDI%T2,1%%; BUMP POINTER
%PUSHJ%P,GTOK%%; GET NEXT TOKEN
%CAIN%C,","%%; DONE?
% JRST%DOSFD%%; NOPE, GO ON
%CLEARM%(T2)%%; YES, CLEAR LAST HOLE
%CAIE%C,"]"%%; MUST BE A BRACKET
% JRST%DOERR%%; ERROR
%CLEAR%T1,%%; CLEAR NAME
NOSFD:%MOVSS%F%%; PUT PROPER POINTER BACK
%JRST%LOOP%%; BACK FOR MORE
 
DOPRV:%SKIPE%T1%%; WAS THERE A FILE NAME?
% MOVEM%T1,NAM(F)%; YES
%CLEAR%T1,%%; CLEAR NAME
%PUSHJ%P,GETOCT%; GET PROTECTION
%PUSHJ%P,GTOK%%; AND NEXT TOKEN
%CAIG%T2,777%%; OUT OF RANGE?
%CAIE%C,">"%%; NO, BUT DO WE HAVE PROPER TERMINATOR?
% JRST%DOERR%%; NOPE, LOSER
%LSH%T2,^D27%%; PROTECTION OK, SHIFT TO BITS 0-8
%MOVEM%T2,PRV(F)%; STORE IT
%JRST%LOOP%%; BACK FOR MORE
 
DOEOS:%CLEAR%R,%%; ASSUME SUCCESS
%SKIPE%T1%%; WAS THERE A FILE NAME?
% MOVEM%T1,NAM(F)%; YES
%HLRZ%T1,EXT(F)%; GET EXTENSION
%MOVE%T2,DEV(F)%; GET DEVICE
%CAIN%T1,'TMP'%; DSK:XXXYYY.TMP ?
%CAME%T2,['DSK   ']
% JRST%$9%%; NOPE
%HRRZ%T1,NAM(F)%; YES, GET RIGHT PART OF NAME
%JUMPN%T1,$9%%; LONG NAMES DON'T GET MODIFIED
%PUSHJ%P,JOBNO$##%; GET JOB NUMBER AS XXX
%HLR%T1,NAM(F)%; FORM NNNXXX
%HRL%T1,Z
%MOVEM%T1,NAM(F)%; NO, STORE NEW NAME
%CLEAR%R,
$9:%SKIPE%NAM(F)%%; NULL FILE NAME?
% POPJ%P,%%; NO, WE'RE DONE
%SKIPE%EXT(F)%%; EXTENSION?
% POPJ%P,%%; NOPE, WE'RE DONE
%MOVSS%F%%; POINT TO PATH
%SKIPN%T1,PPN(F)%; PATH HERE MEANS OPEN DIRECTORY
% POPJ%P,%%; RETURN
%MOVEI%T2,SFD(F)%; POINT TO SFD NAMES
$7:%SKIPE%(T2)%%; END OF LIST YET?
% AOJA%T2,$7
%CAIE%T2,SFD(F)%; SFDS?
% JRST%$8%%; THERE IS A PATH
%CALLI%T2,41%%; NO SFDS, GET MFD AREA
% MOVE%T2,[1,,1]%; OOPS, ASSUME THE USUAL
%EXCH%T2,PPN(F)
%MOVSS%F%%; POINT BACK TO TOP OF A
%MOVEM%T2,NAM(F)%; STASH NAME
%MOVSI%T2,'UFD'
%MOVEM%T2,EXT(F)%; SET USUAL EXTENSION
%POPJ%P,%%; RETURN
$8:%MOVE%T1,-1(T2)%; GET LAST SFD NAME
%CLEARM%-1(T2)%%; RESET END OF SFD LIST
%MOVSS%F%%; POINT BACK TO TOP OF A
%MOVEM%T1,NAM(F)%; STASH NAME
%MOVSI%T1,'SFD'%; SET EXTENSION
%MOVEM%T1,EXT(F)
%POPJ%P,%%; RETURN
 
DOERR:%MOVE%R,[ERR]%%; INDICATE ERROR
%POPJ%P,%%; RETURN
 
; GETOCT -- GET AN OCTAL NUMBER.  CALL IS
;%PUSHJ%P,GETOCT
;%RETURN, RESULT IN T2
;
GETOCT:%CLEAR%T2,%%; CLEAR RESULT
%PUSHJ%P,SKIPBL%; SKIP BLANKS
$1:%PUSHJ%P,GETCHR%; GET A CHARACTER
%CAIL%C,"0"%%; IN RANGE?
%CAILE%C,"7"
% JRST%[HRROM%C,PSHDBK%; NO, PUT TOKEN BACK
%% POPJ%P,]%%; RETURN
%LSH%T2,3%%; SHIFT PREVIOUS RESULT
%ADDI%T2,-"0"(C)%; ADD IT NEW DIGIT
%JRST%$1%%; LOOP
 
; GETCHR -- GET NEXT CHARACTER FROM THE STRING.  CALL IS
;%PUSHJ%P,GETCHR
;%RETURN, CHARACTER IN C
GETCHR:%SKIPL%PSHDBK%%; IS THERE A PUSHED BACK CHARACTER?
% JRST%$2%%; NO
%HRRZS%C,PSHDBK%; YES, GET IT AND CLEAR FLAG
%POPJ%P,%%; RETURN
$2:%LDB %C,STPTR         ; GET A REGULAR CHARACTER
        SKIPN   C               ; NULL?
         MOVE   C,[EOS]%%; YES, ASSUME EOS
 %CAMN%C,[EOS]%%; END OF STRING?
% POPJ%P,%%; YES, RETURN AND DON'T BUMP POINTER
%IBP%STPTR%%; NO, BUMP POINTER
%CAIL%C,"A"%%; LOWER CASE?
%CAILE%C,"^"
% POPJ%P,%%; NO
%SUBI%C,40%%; YES, CONVERT IT
%POPJ%P,%%; RETURN
 
; GTOK -- GET NEXT TOKEN FROM THE FILE SPECIFICATION.  CALL IS
;%PUSHJ%P,GTOK
;%RETURN, C HAS TOKEN AND T1 HAS NAME IF C HAS ALPHA CODE
GTOK:%PUSHJ%P,SKIPBL%; SKIP BLANKS AND TABS
%PUSHJ%P,PEEKN%%; IS THERE A NAME COMING?
% JRST%GETCHR%%; NO, JUST RETURN THE CHARACTER
%CLEAR%T1,%%; YES, SET UP FOR NAME
$3:%PUSHJ%P,GETCHR%; GET ANOTHER CHARACTER
%PUSHJ%P,ISALPH%; PART OF A NAME?
% JRST%$4%%; NO
%TLNE%T1,770000%; GOT 6 ALREADY?
% JRST%$3%%; YES
%LSH%T1,6%%; SHIFT PREVIOUS NAME
%ADDI%T1,-40(C)%; ADD IN NEW CHARACTER
%JRST%$3%%; AND GO BACK FOR MORE
$4:%HRROM%C,PSHDBK%; PUT BACK LAST CHARACTER
%MOVEI%C,ALPHA%%; GET ALPHA CODE
$5:%TLNE%T1,770000%; LEFT JUSTIFY NAME
% POPJ%P,%%; DONE, RETURN
%LSH%T1,6%%; MOVE OVER ANOTHER 6
%JRST%$5%%; LOOP
 
; ISALPH -- CHECKS IF A CHARACTER IS ALPHNUMERIC OR NOT.  CALL IS
;%MOVE%C,CHARACTER
;%PUSHJ%P,ISALPH
;% NO
;%YES
ISALPH:%CAIL%C,"0"%%; A DIGIT?
%CAILE%C,"Z"%%; OR LETTER?
% POPJ%P,%%; NO WAY
%CAILE%C,"9"%%; A DIGIT?
%CAIL%C,"A"%%; OR LOWER CASE LETTER?
% JRST%CPOPJ1%%; YES
%CAIL%C,"A"%%; UPPER CASE?
%CAILE%C,"Z"
% POPJ%P,%%; NO
CPOPJ1:%AOS%(P)%%; BUMP FOR SKIP RETURN
%POPJ%P,%%; RETURN
 
; PEEKN -- CHECK TO SEE IF A NAME IS COMING.  CALL IS
;%PUSHJ%P,PEEKN
;% NO
;%YES
PEEKN:%PUSHJ%P,GETCHR%; GET NEXT CHARACTER
%HRROM%C,PSHDBK%; BUT PUT IT BACK
%PUSHJ%P,ISALPH%; IS IT BEGINNING OF A NAME?
% POPJ%P,%%; NO
%JRST%CPOPJ1%%; YES
 
; SKIPBL -- SKIP BLANKS AND TABS.  CALL IS
;%PUSHJ%P,SKIPBL
SKIPBL:%PUSHJ%P,GETCHR%; GET A CHARACTER
%CAIE%C," "%%; BLANK?
%CAIN%C,"I"-100%; OR TAB?
% JRST%SKIPBL%%; YES
%HRROM%C,PSHDBK%; NO, PUT IT BACK
%POPJ%P,%%; RETURN
RELOC
STPTR:%BLOCK%1%%; POINTER TO NAME
PSHDBK:%BLOCK%1%%; PUSHED BACK CHARACTER
RELOC
END
#-H- QQPUTS.RAT 775 1980 103 2149
INCLUDE RATDEF
 
# QQPUTS - WRITES STRINGS S1... TO FILE F
   SUBROUTINE QQPUTS(F, S1)
   INTEGER F
   CHARACTER S1(ARB)
   INTEGER I, AP, MEMOFF, MEM(1)
   CHARACTER QQLLC
   INTEGER QQARG, QQLOC
   CHARACTER C
 
   MEMOFF = 1 - QQLOC(MEM(1))   # GET ADDRESSING OFFSET
   FOR (AP = 2; MEM(QQARG(AP)+MEMOFF) ^= 0; AP = AP + 1) <
      ADR = QQARG(AP) + MEMOFF
      FOR (I = 0; QQLLC(C, MEM(ADR), I) ^= 0; I = I + 1) <
         IF (C == BACKSLASH) <
            I = I + 1
            IF (QQLLC(C, MEM(ADR), I) == DIG0)
               BREAK
            ELSE IF (C == LETN)
               C = NEWLINE
            !
         CALL PUTCH(C, F)
         !
      IF (I == 0)
         FOR (; MEM(ADR) ^= EOS; ADR = ADR + 1)
            CALL PUTCH(MEM(ADR), F)
      !
   RETURN
   END
#-H- QQRM.MAC 1527 1980 103 2149
SEARCH%IOPARM
TITLE.%QQRM
; QQRM(NAME:STRING) -- DELETE FILE NAME.
;
QQRM::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVEI%T1,@0(A)%; POINT TO NAME
%MOVEM%T1,NAMPTR
%MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1
%PUSHJ%P,QQPARS##%; CRACK THE FILE SPEC
%CAMN%R,[ERR]%%; DIE IF ERROR
% POPJ%P,
%CLEARM%OPNBK$%%; CLEAR OTHER WORDS IN OPNBK$
%CLEARM%OPNBK$+2
%MOVE%Z,OPNBK$+1%; GET DEVICE NAME
%DEVTYP%Z,%%; GET ITS TYPE
% MOVEI%Z,100%%; ASSUME DISK
%SKIPN%Z%%; IF NOT LEGAL DEVICE
% MOVEI%Z,77%%; FAKE IT
%ANDI%Z,77%%; GET DEVICE TYPE CODE
%CAIE%Z,0%%; DISK?
% JRST%$2%%; NOPE
$1:%OPEN.%0,OPNBK$%; YES, OPEN IT
% JRST%$99%%; CAN'T OPEN
%LOOKUP%0,UUOBK$##
% JRST%$99%%; CAN'T FIND
%CLEARM%UUOBK$%%; SET UP FILE BLOCK FOR DELETION
%RENAME%0,UUOBK$
% JRST%$99%%; OOPS
%JRST%$98%%; SUCCESS
$2:%MOVE%Z,OPNBK$+1%; GET DEVICE
%CAME%Z,['TMP   ']%; TMPCOR?
%CAMN%Z,['TMPCOR']
% SKIPA%%%; YEP
%JRST%$98%%; NOPE, JUST RETURN
%HLLZ%T1,UUOBK$+2%; GET NAME
%CLEAR%T2,
%MOVE%Z,[2,,T1]
%TMPCOR%Z,%%; READ AND DELETE IT
% JFCL%%%; SO WHAT
%MOVSI%Z,'DSK'%%; ALSO DELETE DSK:XXXNAM.TMP
%MOVEM%Z,OPNBK$+1
%PJOB%Z,%%; FORM FILE NAME XXXNAM
%IDIVI%Z,^D100
%IDIVI%T1,^D10
%ADDI%Z,'0'
%LSH%Z,6
%ADDI%Z,'0'(T1)
%LSH%Z,6
%ADDI%Z,'0'(T2)
%HLL%Z,UUOBK$+2%; GET NAME PART
%MOVSM%Z,UUOBK$+2%; SWAP HALVES AND STORE
%MOVSI%Z,'TMP'%%; EXTENSION
%MOVEM%Z,UUOBK$+3
%JRST%$1%%; GO DELETE DISK FILE
$98:%TDZA%R,R%%; INDICATE SUCCESS
$99:%MOVE%R,[ERR]%%; INDICATE ERROR
%RELEAS%0,0%%; RELEASE CHANNEL IF USED
%POPJ%P,%%; RETURN
RELOC
NAMPTR:%BLOCK%1
RELOC
END
#-H- QQRUN.MAC 758 1980 103 2149
SEARCH%IOPARM
TITLE.%QQRUN
; QQRUN(NAME,OFFSET) - RUN NAME AT RUN OFFSET (0 OR 1).
;
QQRUN::%PUSHJ%P,SAVR$##%; SAVE REGISTERS
%MOVEI%Z,@0(A)%%; GET ADDRESS OF STRING
%MOVEM%Z,NAMPTR
%PUSH%P,A%%; SAVE ARGUMENT LIST POINTER
%MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1
%PUSHJ%P,QQPARS##%; PARSE FILE SPEC
%POP%P,A%%; GET ARGUMENT LIST POINTER BACK
%CAMN%Z,[ERR]%%; ERROR?
% JRST%$99
%MOVE%Z,OPNBK$##+1%; GET DEVICE NAME
%EXCH%Z,UUOBK$##+1%; STASH FOR RUN UUO
%MOVEM%Z,UUOBK$+5
%CLEARM%UUOBK$+4
%CLEARM%UUOBK$+6
%HRL%Z,@1(A)%%; GET RUN OFFSET
%HRRI%Z,UUOBK$+1%; POINT TO RUN BLOCK
%JRST%$1%%; GO TO LOW SEGMENT TO DO RUN UUO
RELOC
$1:%CALLI%Z,35
% HALT
RELOC
$99:%MOVE%R,[ERR]%%; ERROR
%POPJ%P,
RELOC
NAMPTR:%BLOCK%1%%; FOR POINTER TO NAME
RELOC
END
#-H- QQSCPY.RAT 295 1980 103 2149
INCLUDE RATDEF
 
# QQSCPY - COPY STRING AT FROM(I) TO TO(J)
   SUBROUTINE QQSCPY(FROM, I, TO, J)
   CHARACTER FROM(ARB), TO(ARB)
   INTEGER I, J, K1, K2
 
   K2 = J
   FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) <
      TO(K2) = FROM(K1)
      K2 = K2 + 1
      !
   TO(K2) = EOS
   RETURN
   END
#-H- R50TOC.RAT 825 1980 103 2149
INCLUDE RATDEF
 
# R50TOC - CONVERT RADIX50 SYMBOL INT TO STRING IN STR
   INTEGER FUNCTION R50TOC(INT, STR, SIZE)
   INTEGER MOD
   INTEGER I, INT, INTVAL, J, K, SIZE
   CHARACTER STR(ARB)
 
   INTVAL = INT
   STR(1) = EOS
   I = 1
   REPEAT <            # GENERATE CHARACTERS
      I = I + 1
      K = MOD(INTVAL, 40)
      IF (K >= 11 & K <= 36)
         STR(I) = LETA - 11 + K
      ELSE IF (K >= 1 & K <= 10)
         STR(I) = DIG0 - 1 + K
      ELSE IF (K == 38 \ K == 39)
         STR(I) = DOLLAR - 38 + K
      ELSE IF (K == 37)
         STR(I) = PERIOD
      ELSE
         I = I - 1
      INTVAL = INTVAL / 40
      ! UNTIL (INTVAL == 0 \ I >= SIZE)
   R50TOC = 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
#-H- RATDEF 2690 1980 103 2149
#========== STANDARD RATFOR DEFINITIONS ==========
 
DEFINE(ACCENT,96)
DEFINE(ALPHA,10100)
DEFINE(AND,38)
DEFINE(ANDIF,IF)
DEFINE(ARB,100)
DEFINE(ATSIGN,64)
DEFINE(BACKSLASH,92)
DEFINE(BACKSPACE,8)
DEFINE(BANG,33)
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(BLANK,32)
DEFINE(CARET,94)
DEFINE(COLON,58)
DEFINE(COMMA,44)
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(DIGIT,2)
DEFINE(DOLLAR,36)
DEFINE(DQUOTE,34)
DEFINE(EOF,10003)
DEFINE(EOS,10002)
DEFINE(EQUALS,61)
DEFINE(ERR,10001)
DEFINE(ERROUT,2)
DEFINE(GREATER,62)
DEFINE(HUGE,30000)
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(LETTER,1)
DEFINE(LETU,117)
DEFINE(LETV,118)
DEFINE(LETW,119)
DEFINE(LETX,120)
DEFINE(LETY,121)
DEFINE(LETZ,122)
DEFINE(LPAREN,40)
DEFINE(MAXCHARS,20)
DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH
DEFINE(MAXNAME,30)   %# TYPICAL FILE NAME SIZE
DEFINE(MINUS,45)
DEFINE(NEWLINE,10)
DEFINE(NO,0)
DEFINE(NOERR,0)
DEFINE(NOT,126)   # SAME AS TILDE
DEFINE(OK,-2)
DEFINE(OR,BAR)   # SAME AS BAR
DEFINE(PERCENT,37)
DEFINE(PERIOD,46)
DEFINE(PLUS,43)
DEFINE(QMARK,63)
DEFINE(RBRACE,125)
DEFINE(RBRACK,93)
DEFINE(READ,0)
DEFINE(READWRITE,2)
DEFINE(RPAREN,41)
DEFINE(SEMICOL,59)
DEFINE(SHARP,35)
DEFINE(SLASH,47)
DEFINE(SQUOTE,39)
DEFINE(STAR,42)
DEFINE(STDIN,0)
DEFINE(STDOUT,1)
DEFINE(STDERR,ERROUT)
DEFINE(TAB,9)
DEFINE(TILDE,126)
DEFINE(UNDERLINE,95)
DEFINE(WRITE,1)
DEFINE(YES,1)
DEFINE(ESCAPE,ATSIGN)
DEFINE(CHARACTER,INTEGER)
DEFINE(ABS,IABS)
DEFINE(MIN,MIN0)
DEFINE(MAX,MAX0)
 
# HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE
DEFINE(BPI,36)%%# BITS PER INTEGER
DEFINE(BPC,7)%%# BITS PER CHARACTER
DEFINE(CPI,5)%%# CHARACTERS PER INTEGER
DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER
DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN)
DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN)
DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL
#-H- READF.MAC 803 1980 103 2149
SEARCH%IOPARM
TITLE.%READF
; READF(BUF,COUNT,FD) -- READ FROM FILE FD.
;
READF::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%SKIPG%T2,@1(A)%; COUNT
% JRST%[CLEAR%R,
%% POPJ%P, ]%; EMPTY BUFFER SO RETURN
%MOVEI%T1,@0(A)%; POINTER TO BUFFER
%MOVE%F,@2(A)
%MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB
%MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK
%MOVE%Z,OPNMODE(F)%; GET MODE
%TRNE%Z,1%%; OPEN FOR WRITE ONLY?
% JRST%[MOVE%R,[ERR]
%% POPJ%P,    ] ; OPEN FOR WRITE ONLY
%SKIPE%EOFFLAG(F)
% JRST%[MOVE%R,[EOF]
%% POPJ%P,  ]%; PREVIOUS EOF, RETURN EOF
%MOVE%C,MAJOR(F)%; DEVICE NUMBER FOR COMPUTED CALL
%TRNN%Z,READPACKED%; CHECK FOR PACKED BUFFER
% JRST%.+3
%HLL%T1,BYTEPTR(F)%; USE PACKED POINTER
%JRST%@RDSW$##(C)%; DISPATCH TO DEVICE DRIVER
%HRLI%T1,(POINT 36)%; USE UNPACKED POINTER
%JRST%@RDSW$(C)
END
#-H- REMARK.RAT 593 1980 103 2149
INCLUDE RATDEF
 
# REMARK - PRINT WARNING MESSAGE
   SUBROUTINE REMARK(BUF)
   INTEGER BUF(ARB), I, LLC
   CHARACTER C
 
   FOR (I = 0; LLC(C, BUF, I) ^= PERIOD; I = I + 1) <
      IF (C == 0)
         BREAK
      IF (C == ESCAPE) <
         I = I + 1
         IF (LLC(C, BUF, I) == DIG0)
            BREAK
         ELSE IF (C == LETN \ C == BIGN)
            C = NEWLINE
         ELSE IF (C == LETB \ C == BIGB)
            C = BACKSPACE
         ELSE IF (C == LETT \ C == BIGT)
            C = TAB
         !
      CALL PUTCH(C, ERROUT)
      !
   CALL PUTCH(NEWLINE, ERROUT)
   RETURN
   END
#-H- REMOVE.RAT 146 1980 103 2149
INCLUDE RATDEF
 
# REMOVE - DELETE FILE NAME
   INTEGER FUNCTION REMOVE(NAME)
   CHARACTER NAME(ARB)
   INTEGER QQRM
 
   RETURN(QQRM(NAME))
   END
#-H- RESET.MAC 653 1980 103 2149
SEARCH%IOPARM
TTYFLG==CARGS##
TITLE.%RESET.
; RESET. -- SIMULATES FORTRAN RESET FUNCTION TO INITIALIZE STACK.
; NOTE CALLING SEQUENCE IS
;%JSA%16,RESET.
;%0
;
RESET.::MOVE%P,.JBFF##%; GET FIRST FREE ADDRESS
%HRLI%P,-STKSIZ+1%; SET UP STACK POINTER
%MOVEI%T1,STKSIZ(P)%; COMPUTE NEW FIRST FREE
%HRRM%T1,.JBFF%; STASH IT
%CAMGE%T1,.JBREL##%; GOT ENOUGH CORE?
% JRST%$1%%; YES
%CORE%T1,%%; CORE UP
% HALT%%%; OOPS
$1:%HLLZS%.JBERR##%; CLEAR ERROR INDICATOR
%CLEARM%TTYFLG%%; ASSUME ARG FILE
%TTCALL%10,1%%; RESCAN THE COMMAND LINE
%SKPINL%%%; ANYTHING THERE?
% SKIPA%%%; NOPE
%AOS%TTYFLG%%; YES
%PUSHJ%P,QQINIT##%; INITIALIZE I/O
%JRST%1(16)%%; RETURN
END
#-H- RUN.MAC 98 1980 103 2149
SEARCH%IOPARM
TITLE.%RUN
; RUN(NAME,OFFSET) - RUN NAME AT RUN OFFSET (0 OR 1).
;
RUN==QQRUN##
END
#-H- SAVR.MAC 469 1980 103 2149
SEARCH%IOPARM
TITLE.%SAVR$
; SAVR$ -- SAVE REGISTERS.  MODIFIES STACK TO DO AUTO-RESTORE.  CALL IS
;%PUSHJ%P,SAVR$
;
SAVR$::%EXCH%T1,(P)%%; SAVE T1 AND GET RETURN POINT
%HRLI%T1,(P)%%; POINT TO WHERE T1 IS SAVED
%PUSH%P,T2%%; SAVE THE REST
%PUSH%P,F
%PUSH%P,C
%PUSHJ%P,[JRA T1,(T1)]%; RETURN RESTORING T1
% SKIPA%%%; GIVE NONSKIP RETURN
%AOS%-4(P)%%; GIVE SKIP RETURN
%POP%P,C%%; RESTORE THE REGISTERS
%POP%P,F
%POP%P,T2
%POP%P,T1
%POPJ%P,%%; RETURN TO REAL CALLER
END
#-H- SEEK.MAC 327 1980 103 2149
SEARCH%IOPARM
TITLE.%SEEK
; SEEK(OFFSET,FD) - SEEK TO OFFSET IN FILE FD.
;
SEEK::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVE%F,@1(A)%%; POINT TO FILE BLOCK
%MOVE%F,FDTAB$##(F)
%MOVEI%F,FLTAB$##-1(F)
%MOVE%T1,@0(A)%; GET OFFSET
%MOVE%T2,MAJOR(F)%; GET MAJOR DEVICE NUMBER
%JRST%@SKSW$##(T2)%; SWITCH TO PROPER SEEK ROUTINE
END
#-H- SHIFT.MAC 201 1980 103 2149
SEARCH%IOPARM
TITLE.%SHIFT
; SHIFT(X,N) - RETURN X SHIFTED BY N BITS AS IN LSH INSTRUCTION.
;
SHIFT::%MOVE%0,@0(16)%; GET N
        MOVE%1,@1(16)%; GET SHIFT COUNT
%LSH%0,(1)%%; SHIFT IT
%POPJ%17,
END
#-H- SIXTOC.RAT 528 1980 103 2149
INCLUDE RATDEF
 
# SIXTOC - CONVERT SIXBIT SYMBOL INT TO STRING IN STR
   INTEGER FUNCTION SIXTOC(INT, STR, SIZE)
   INTEGER SHIFT
   INTEGER I, INT, SIZE, N
   CHARACTER STR(ARB)
 
   N = MIN0(6, SIZE-1)
   FOR (I = 1; I <= N; I = I + 1) <
      STR(I) = (SHIFT(INT, -36 + 6*I) & 8%077) + BLANK
      IF (STR(I) >= BIGA & STR(I) <= BIGZ)
         STR(I) = STR(I) + LETA - BIGA
      !
   FOR (I = MIN0(6, SIZE-1); I > 0; I = I - 1)   # TRIM BLANKS
      IF (STR(I) ^= BLANK)
         BREAK
   STR(I+1) = EOS
   RETURN(I)
   END
#-H- STC.MAC 381 1980 103 2149
SEARCH%IOPARM
TITLE.%STC
; STC(C,A,I):C - STORE C AT ITH CHARACTER (0-BASED) IN A.
;
STC::%HRRZ%1,@2(16)%; GET I
%IDIVI%1,5%%; COMPUTE WORD AND BYTE OFFSET
%ADDI%1,@1(16)%; ADD IN ADDRESS
%HLL%1,[POINT 7,0%; MAKE IT A POINTER
%%   POINT 7,0,6
%%   POINT 7,0,13
%%   POINT 7,0,20
%%   POINT 7,0,27](2)
%MOVE%0,@0(16)%; GET C
%IDPB%0,1%%; STORE THE CHARACTER
%POPJ%17,%%; RETURN
END
#-H- STOP.MAC 549 1980 103 2149
SEARCH%IOPARM
RUNPTR==CARGS##+1
TITLE.%STOP.
; STOP. -- ABNORMAL TERMINATION.
;
STOP.::%CLEARM%RUNPTR%%; DON'T RUN SUBSEQUENTS IN THIS CASE
%SKIPL%-1(A)%%; EXPLICIT ARGUMENT?
% JRST%EXIT.##%%; NO, JUST EXIT
%OUTSTR%[ASCIZ /STOP /]
%MOVE%Z,@0(A)%%; YES, GET ARGUMENT
%PUSHJ%P,$1%%; PRINT NUMBER
%OUTSTR%[ASCIZ /
/]
%JRST%EXIT.%%; THEN EXIT
$1:%IDIVI%Z,8%%; PRINT STOP NUMBER IN OCTAL
%PUSH%P,T1
%SKIPE%Z%%; DONE YET?
% PUSHJ%P,$1%%; NO, KEEP GOING
%POP%P,Z%%; YES, GET A DIGIT
%ADDI%Z,"0"%%; MAKE IT ASCII
%OUTCHR%Z%%; PRINT IT
%POPJ%P,%%; GO ON
END
#-H- TAPOP.MAC 2036 1980 103 2149
SEARCH%IOPARM
TITLE.%TAPOP
; TAPOP(FCN:INTEGER,F:FILE/NAME:STRING,A:ARRAY,N:INTEGER):INTEGER --
; PERFORM THE MAG TAPE OPERATION INDICATED BY FCN ON FILE F OR TAPE
; UNIT NAME.  IF THE FIRST WORD OF NAME IS < MAXFILES, IT IS ASSUMED TO
; BE A FILE DESCRIPTOR, NOT A NAME.  ARGUMENTS ARE PASSED OR RECEIVED
; IN A(1)..A(N).
;
TAPOP::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%MOVEI%T1,@1(A)%; GET ADDRESS OF NAME OR FILE DESCRIPTOR
%MOVE%F,(T1)%%; GET FIRST WORD
%CAIGE%F,MAXFILES%; CHANNEL NUMBER?
% JRST%$A%%; YES
%MOVEM%T1,NAMPTR%; NO, PREPARE TO PARSE THE NAME
%PUSH%P,A
%MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1
%PUSHJ%P,QQPARS##%; CRACK THE NAME
%POP%P,A
%CAMN%R,[ERR]
% JRST%$7%%; BAD SYNTAX
%MOVE%T1,OPNBK$+1%; USE DEVICE NAME
%MOVEM%T1,TAPARG+1%; IN TAPOP. ARGUMENT LIST
%JRST%$B%%; HOP AROUND
$A:%MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB
%MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK
%LDB%Z,[POINT 4,CHANNEL(F),12]
%MOVEM%Z,TAPARG+1%; STORE CHANNEL NUMBER
$B:%MOVE%T1,@0(A)%; GET THE FUNCTION CODE
%MOVEM%T1,TAPARG%; STORE IT
%MOVEI%T2,@2(A)%; GET ADDRESS OF ARRAY
%CAILE%T1,777%%; PERFORM A SPECIFIC ACTION?
% JRST%$1%%; NO
%MOVE%T1,[2,,TAPARG]%; YES, DO IT
%TAPOP.%T1,
% JRST%$7%%; ERROR
%CLEAR%R,
%POPJ%P,%%; RETURN SUCCESSFULLY
$1:%CAILE%T1,1777%%; READ A PARAMETER?
% JRST%$4%%; NO
%MOVE%T1,[2,,TAPARG]%; SET UP ARGUMENT POINTER
%TAPOP.%T1,
% JRST%$7%%; ERROR
%MOVE%R,@3(A)%%; GET N
%CAIL%R,1%%; MUST BE ONE
% MOVEM%T1,(T2)%%; STORE VALUE OF PARAMETER
%CLEAR%R,
%POPJ%P,%%; RETURN SUCCESSFULLY
$4:%CAILE%T1,2777%%; SET A PARAMETER ?
% JRST%$7%%; NO
%MOVEI%T1,1%%; INITIALIZE FOR COPY LOOP
$5:%CAMLE%T1,@3(A)%; DONE?
% JRST%$6%%; YES
%MOVE%R,(T2)%%; COPY ITEM
%MOVEM%R,TAPARG+1(T1)
%ADDI%T2,1%%; BUMP ARRAY ADDRESS
%AOJA%T1,$5%%; CONTINUE
$6:%HRLZ%T1,@3(A)%; POINT TO ARGUMENTS
%ADD%T1,[2,,TAPARG]
%TAPOP.%T1,
% JRST%$7%%; ERROR
%CLEAR%R,
%POPJ%P,%%; RETURN SUCCESSFULLY
$7:%MOVE%R,[ERR]%%; ERROR RETURN
%POPJ%P,
RELOC
NAMPTR:%BLOCK%1%%; POINTS TO NAME
TAPARG:%BLOCK%12%%; FOR TAPOP. ARGUMENTS
RELOC
END
#-H- TMP.MAC 4666 1980 103 2149
TITLE%TMP - TEMP CORE DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%TMPCR$, TMPOP$, TMPCL$, JOBNO$
 
BUFSIZ==1000%; BUFFER SIZE
RELOC%400000
PHASE%%; TMP BLOCK LAYOUT
TMPNAM:%BLOCK%1%%; FILE NAME
TMPBUF:%BLOCK%1%%; THE ACTUAL BUFFER
TMPLEN==.+BUFSIZ
DEPHASE
RELOC%400000
 
; TMPCR$ - CREATE AND OPEN A TEMP CORE FILE
;
TMPCR$::HLLZ%T1,UUOBK$##+2%; GET NAME
%CLEAR%T2,
%MOVE%Z,[3,,T1]%; WRITE EMPTY TEMP CORE FILE
%TMPCOR%Z,
% SKIPA%%%; COULD NOT CREATE
%JRST%TMPOP$%%; MERGE BELOW
%HLRM%T1,UUOBK$+2%; STASH NAME
%PUSHJ%P,JOBNO$%; GET JOB NUMBER PART
%HRLM%Z,UUOBK$+2%; STASH IT
%MOVEI%C,UUOBK$+2-TMPNAM%; FAKE C FOR OPNDSK
%PUSHJ%P,OPNDSK%; OPEN THE DISK
%ENTER%0,UUOBK$%; ENTER THE FILE
% JRST%[RELEAS%0,0%%; FAILED, DIE
%% MOVE%R,[ERR]
%% POPJ%P,]
%RELEAS%0,0%%; WRITE ZERO-LENGTH FILE
%MOVSS%UUOBK$+2%; PUT NAME BACK IN PROPER POSITION
%JRST%TMPOP$%%; GO OPEN IT
 
; TMPOP$ - OPEN A TEMP CORE FILE; F CONTAINS FILE BLOCK ADDRESS.
;
TMPOP$::MOVEI%Z,TMPLEN%; ALLOCATE A TEMP BLOCK
%PUSHJ%P,ALCBK$##
% JRST%$99%%; FAILED
%PUSHJ%P,JOBNO$%; FORM FILE NAME XXXNAM
%HLL%Z,UUOBK$+2%; GET NAME PART
%MOVSM%Z,TMPNAM(C)%; SWAP HALVES AND STORE
%HRLZ%T1,TMPNAM(C)%; GET NAME,,0
%HRLI%T2,-BUFSIZ%; TRY READING TMPCOR FILE
%HRRI%T2,TMPBUF-1(C)
%MOVE%Z,[1,,T1]
%TMPCOR%Z,%%; READ IT
% SKIPA%%%; FAILED, MUST TRY DISK
%JRST%$1%%; GOT IT
%PUSHJ%P,OPNDSK%; PREPARE AND OPEN DISK
%LOOKUP%0,UUOBK$%; LOOKUP FILE
% JRST%$97%%; FAILED
%MOVE%Z,UUOBK$+5%; GET SIZE
%CAILE%Z,BUFSIZ%; SMALL ENOUGH?
% JRST%$97%%; NOPE
%HRLI%T1,-BUFSIZ%; READ DISK FILE
%HRRI%T1,TMPBUF-1(C)
%CLEAR%T2,
%INPUT%0,T1
%RELEAS%0,0
$1:%MOVEM%Z,OPNBK$+2%; SET CURRENT SIZE
%MOVEI%Z,BUFSIZ%; SET MAXIMUM SIZE
%MOVEM%Z,OPNBK$+1
%MOVEI%Z,TMPBUF(C)%; SET BUFFER ADDRESS
%MOVEM%Z,OPNBK$
%PUSH%P,C%%; SAVE TMP BLOCK POINTER
%PUSHJ%P,MEMOP$##%; OPEN AS A MEMORY STREAM
%POP%P,C%%; RESTORE C
%CAMN%R,[ERR]%%; OK?
% JRST%$98%%; NOPE
%HRLM%C,DEVPTR(F)%; SAVE TMP BLOCK POINTER
%CLEAR%R,%%; INDICATE SUCCESS
%POPJ%P,%%; RETURN
$97:%RELEAS%0,0%%; RELEASE CHANNEL
$98:%PUSHJ%P,FREBK$##%; FREE TMP BLOCK
%CLEARM%DEVPTR(F)
$99:%MOVE%R,[ERR]%%; INDICATE ERROR
%POPJ%P,%%; RETURN
 
; TMPCL$ - CLOSE A TMP CORE FILE; MAY WRITE THE ACTUAL FILE
;
TMPCL$::LDB%Z,[MODEPTR]%; GET MODE
%CAIN%Z,READ%%; OPEN FOR READ ONLY?
% JRST%$5%%; YES, ALL DONE
%HLRZ%C,DEVPTR(F)%; POINT TO TMP BLOCK
%HRLZ%T1,TMPNAM(C)%; DELETE OLD TMP FILE
%CLEAR%T2,
%MOVE%Z,[2,,T1]
%TMPCOR%Z,%%; READ AND DELETE IT
% JFCL%%%; DON'T CARE
%PUSHJ%P,OPNDSK%; DELETE DSK:XXXNAM.TMP
%LOOKUP%0,UUOBK$
% JRST%$2%%; CAN'T FIND
%CLEARM%UUOBK$%%; SET UP FILE BLOCK FOR DELETION
%RENAME%0,UUOBK$
% JFCL%%%; CAN'T DELETE
$2:%RELEAS%0,0%%; RELEASE CHANNEL
%HRRZ%C,DEVPTR(F)%; POINT TO MEM BLOCK
%MOVE%Z,MEMSIZ##(C)%; GET CURRENT SIZE
%HLRZ%C,DEVPTR(F)%; POINT BACK TO TMP BLOCK
%IDIV%Z,BYTEPW(F)%; COMPUTE SIZE IN WORDS, T1=BYTE IN WORD
%SKIPN%T1%%; NEED TO ADJUST FOR ODD SIZE?
% JRST%$3%%; NO
%LDB%T2,[SIZEPTR]%; GET BYTE SIZE
%IMUL%T1,T2%%; COMPUTE SHIFT AMOUNT
%MOVNS%T1
%SETO%T2,%%; GET A BUNCH OF 1'S
%LSH%T2,(T1)%%; SLIDE OVER A BIT
%MOVEI%T1,TMPBUF(C)%; POINT TO LAST WORD
%ADD%T1,Z
%ANDCAM%T2,(T1)%%; CLEAR OUT TRAILING BITS IN LAST WORD
%ADDI%Z,1%%; ONE MORE WORD
$3:%MOVNS%Z%%; FORM -N
%HRLZ%T1,TMPNAM(C)%; GET NAME,,0
%HRL%T2,Z%%; FORM I/O WORD
%HRRI%T2,TMPBUF-1(C)
%MOVE%Z,[3,,T1]
%TMPCOR%Z,%%; ATTEMPT TO WRITE TMPCOR FILE
% SKIPA%%%; FAILED, TRY DISK
%JRST%$5%%; SUCCESS, ALL DONE
%PUSHJ%P,OPNDSK%; OPEN DISK
%ENTER%0,UUOBK$%; ENTER THE FILE
% JRST%$4%%; FAILED
%MOVE%T1,T2%%; PUT I/O WORD IN T1
%CLEAR%T2,
%OUTPUT%0,T1%%; WRITE FILE
%RELEAS%0,0%%; RELEASE CHANNEL
%CLEAR%T2,%%; SET RETURN CODE
%JRST%$5%%; MERGE BELOW
$4:%RELEAS%0,0%%; SOME ERROR
%MOVE%T2,[ERR]%; SET RETURN CODE
$5:%HLRZ%C,DEVPTR(F)%; RELEASE TMP BLOCK
%PUSHJ%P,FREBK$##
%HRRZ%C,DEVPTR(F)%; RELEASE MEM BLOCK
%PUSHJ%P,FREBK$
%CLEARM%DEVPTR(F)
%MOVE%R,T2%%; SET RETURN CODE
%POPJ%P,%%; RETURN
 
; OPNDSK - OPEN THE DISK FOR LOOKUP/ENTER.  CALL IS
;%PUSHJ%P,OPNDSK
;%CHANNEL 0 OPENED
;%FAILED%(NOTE FUNNY ORDER)
OPNDSK:%MOVEI%Z,17%%; SET DUMP MODE
%MOVEM%Z,OPNBK$##
%MOVSI%Z,'DSK'%%; DEFAULT DEVICE
%MOVEM%Z,OPNBK$+1
%CLEARM%OPNBK$+2%; NO HEADERS
%OPEN.%0,OPNBK$
% AOS%(P)%%; CAUSE A SKIP
%MOVEI%Z,5%%; SET UP UUOBK$ FOR LOOKUP/ENTER
%MOVEM%Z,UUOBK$##
%CLEARM%UUOBK$+1%; DEFAULT PATH
%MOVE%Z,TMPNAM(C)%; USE FULL NAME
%MOVEM%Z,UUOBK$+2
%MOVSI%Z,'TMP'
%MOVEM%Z,UUOBK$+3
%CLEARM%UUOBK$+4%; DEFAULT PRIVILEGE
%POPJ%P,%%; RETURN FOR LOOKUP/ENTER
 
; JOBNO$ - RETURN JOB NUMBER IN Z AS XXX IN SIXBIT.
JOBNO$::PUSH%P,T1%%; SAVE T1 AND T2
%PUSH%P,T2
%PJOB%Z,%%; GET CURRENT JOB NUMBER
%IDIVI%Z,^D100
%IDIVI%T1,^D10
%ADDI%Z,'0'
%LSH%Z,6
%ADDI%Z,'0'(T1)
%LSH%Z,6
%ADDI%Z,'0'(T2)
%POP%P,T2
%POP%P,T1
%POPJ%P,%%; RETURN
 
END
#-H- TRMNO.MAC 251 1980 103 2149
SEARCH%IOPARM
TITLE.%TRMNO
; TRMNO(J:INTEGER,R:INTEGER):INTEGER -- DO A TRMNO UUO.  RESULT IS
; RETURNED AS FUNCTION VALUE AND IN R.
;
TRMNO::%MOVE%Z,@0(A)%%; GET JOB NUMBER
%TRMNO.%Z,
% MOVE%Z,[ERR]%%; LOSER
%MOVEM%Z,@1(A)%%; STORE IN R
%POPJ%P,
END
#-H- TRMOP.MAC 222 1980 103 2149
SEARCH%IOPARM
TITLE.%TRMOP
; TRMOP(A:ARRAY,N:INTEGER):INTEGER -- DO A TRMOP UUO.
;
TRMOP::%HRL%Z,@1(A)%%; GET COUNT
%HRRI%Z,@0(A)%%; POINT TO ARGUMENT BLOCK
%TRMOP.%Z,%%; DO IT
% SKIPA
%TDZA%Z,Z
%MOVE%Z,[ERR]
%POPJ%P,
END
#-H- TTY.MAC 5657 1980 103 2149
TITLE%TTY - TTY DRIVER
SEARCH%IOPARM
TWOSEG
ENTRY%TTYOP$, TTYCL$, TTYRD$, TTYWR$, TTYCN$
 
RAW==1B29%; RAW MODE
COOKED==1%; COOKED MODE
NOECHO==1B28%; ECHO BIT
RELOC%0
TTYCHN:%BLOCK%1%%; I/O CHANNEL FOR STATUS
ICALL:%BLOCK%1%%; CURRENT MODE INPUT CALL
OCALL:%BLOCK%1%%; CURRENT MODE OUTPUT CALL
OLDRT:%BLOCK%1%%; ORIGINAL ^R ^T SETTING
OLDSQ:%BLOCK%1%%; ORIGINAL ^S ^Q SETTING
TARGS:%BLOCK%3%%; TRMOP. ARGUMENTS
LINBUF:%BLOCK%^D16%%; LINE BUFFER FOR COOKED OUTPUT
%BLOCK%1
LBPTR:%BLOCK%1%%; LINE BUFFER POINTER
COUNT:%BLOCK%1%%; CHARACTER COUNT
RELOC%400000
 
; TTYOP$ - OPEN TTY; SETS UP DEVICE-DEPENDENT DATA.
;
TTYOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE
%CAIE%Z,7%%; MUST BE CHARACTER
% JRST%ERRDV$##%; OR IT'S AN ERROR
%MOVE%Z,TTYCHN%; COPY CHANNEL
%MOVEM%Z,CHANNEL(F)
%SKIPE%LBPTR%%; FIRST TIME?
% POPJ%P,%%; NO, JUST RETURN
%MOVE%Z,[INCHWL C]%; YES, SET UP I/O CALLS
%MOVEM%Z,ICALL
%MOVE%Z,[PUSHJ P,OUTC]
%MOVEM%Z,OCALL
%PUSHJ%P,FDCHN$##%; FIND A CHANNEL
%JUMPE%Z,ERRDV$%; NONE AVAILABLE
%MOVEM%Z,TTYCHN%; SAVE FOR LATER
%MOVEM%Z,CHANNEL(F)
%PUSHJ%P,XUUO$##%; OPEN THE TTY
%OPEN%0,[EXP COOKED,'TTY   ',0]
% JRST%ERRDV$%%; OOPS
%SETO%Z,%%; GET UNIVERSAL I/O INDEX
%TRMNO.%Z,
% JRST%$1%%; SHOULDN'T HAPPEN
%MOVEM%Z,TARGS+1%; SET FOR TRMOP.
%MOVSI%Z,1036%%; READ CURRENT ^R^T SETTING
%PUSHJ%P,TRMOP
% JRST%ERRDV$
%MOVEM%Z,OLDRT%%; SAVE FOR SETTING COOKED MODE
%MOVSI%Z,1021%%; DO SAME FOR ^S^Q SETTING
%PUSHJ%P,TRMOP
% JRST%ERRDV$
%MOVEM%Z,OLDSQ
$1:%MOVE%Z,[POINT 7,LINBUF]%; INITIALIZE OUTPUT BUFFER
%MOVEM%Z,LBPTR
%MOVEI%Z,^D80%
%MOVEM%Z,COUNT
%CLEAR%R,
%POPJ%P,%%; RETURN
 
; TTYCL$ - CLOSE THE TTY; JUST FLUSHES THE OUTPUT BUFFER.
;
TTYCL$::JRST%FLUSH
 
; TTYRD$ - READ THE TTY; POINTER TO STRING IN T1, MAX COUNT IN T2.
;
TTYRD$::PUSH%P,T2%%; SAVE COUNT
%PUSHJ%P,FLUSH%%; FLUSH ANY PENDING OUTPUT
$2:%XCT%ICALL%%; GET A CHARACTER
%CAIN%C,"Z"-100%; END OF FILE?
% JRST%$4%%; YES
%IDPB%C,T1%%; STASH CHARACTER
%SOJLE%T2,$3%%; DECREMENT AND TEST COUNT
%MOVE%Z,[X.EOL]%; CHECK FOR END OF LINE
%LSH%Z,(C)
%JUMPGE%Z,$2%%; CONTINUE UNLESS HIT EOL
$3:%POP%P,R%%; GET BACK ORIGINAL COUNT
%SUB%R,T2%%; COMPUTE NUMBER OF CHARACTERS READ
%POPJ%P,%%; RETURN
$4:%AOS%EOFFLAG(F)%; LIGHT EOF FLAG
%PUSHJ%P,XUUO$%%; CLOSE BUT CONTINUE FOR OTHER FILES
%CLOSE%0,0
%CAME%T2,(P)%%; DID WE GET SOMETHING?
% JRST%$3%%; YES, DON'T GIVE EOF YET
%POP%P,R%%; NO, TOSS ORIGINAL COUNT
%MOVE%R,[EOF]%%; GIVE A REAL EOF
%POPJ%P,%%; RETURN
 
; TTYWR$ - WRITE TO THE TTY; POINTER TO STRING IN T1, COUNT IN T2.
;
TTYWR$::SOJL%T2,$5%%; DECREMENT COUNT AND RETURN IF DONE
%ILDB%C,T1%%; GET A BYTE
%XCT%OCALL%%; DO OUTPUT
%JRST%TTYWR$%%; LOOP UNTIL DONE
$5:%MOVE%R,@1(A)%%; RETURN ORIGINAL COUNT
%POPJ%P,
 
; OUTC - OUTPUT A CHARACTER IN COOKED MODE; CHAR IN C.
;
OUTC:%TRNN%C,177%%; IGNORE NULLS
% POPJ%P,
%SOSG%COUNT%%; DECREMENT AND TEST COUNT
% PUSHJ%P,FLUSH%%; GO DUMP LINE BUFFER
%IDPB%C,LBPTR%%; DEPOSIT CHARACTER
%CAIN%C,C.LF%%; NEWLINE?
% PUSHJ%P,FLUSH%%; YES, FLUSH THE LINE
%POPJ%P,
 
; FLUSH - DUMP CURRENT LINE BUFFER
;
FLUSH:%PUSH%P,Z%%; SAVE CHARACTER
%MOVE%Z,COUNT%%; GET COUNT
%CAIN%Z,^D80%%; ANYTHING THERE?
% JRST%$6%%; NOTHING TO DO
%CLEAR%Z,%%; TERMINATE LINE BUFFER WITH A NULL
%IDPB%Z,LBPTR
%OUTSTR%LINBUF%%; DUMP IT
%PUSHJ%P,$1%%; RESET BUFFER POINTERS
$6:%POP%P,Z%%; RESTORE Z
%POPJ%P,%%; RETURN
 
; TTYCN$ - CONTROL OPERATIONS; T1 = FUNCTION CODE, T2 = VALUE
;  FCT%VALUE%EFFECT
;    2%  0%TURN OFF ECHO
;%  1%TURN ON ECHO
;    3%  0%SET COOKED MODE
;%  1%SET RAW MODE
;   15%  0%BLANK LINES PERMITTED
;%  1%BLANK LINES SUPPRESSED
;
TTYCN$::PUSHJ%P,FLUSH%%; FLUSH PENDING OUTPUT
%SETO%Z,%%; GET I/O INDEX FOR TERMINAL
%TRMNO.%Z,
% JRST%ERRDV$##%; OOPS
%MOVEM%Z,TARGS+1%; SAVE FOR TRMOP.
%CAIN%T1,^D2%%; DISPATCH ACCORDING TO FUNCTION
% JRST%SETECHO
%CAIN%T1,^D3
% JRST%SETMODE
%CAIN%T1,^D15
% JRST%SETBLANKS
%JRST%ERRDV$%%; BAD FUNCTION
SETECHO:%; FCT 2: SET ECHO
%PUSHJ%P,XUUO$%%; READ CURRENT ECHO
% GETSTS%0,T1
%TRNE%T1,NOECHO%; TEST ECHO BIT
% TDZA%R,R%%; ECHO IS OFF
%MOVEI%R,1%%; ECHO IS ON
%JUMPL%T2,$10%%; EXIT IF READ ONLY
%SKIPL%T2%%; LEGAL VALUE?
%CAILE%T2,1
% JRST%ERRDV$%%; NOPE
%TRNN%T2,1%%; TURN ECHO ON?
% TROA%T1,NOECHO%; NO
%TRZ%T1,NOECHO%; YES
%PUSHJ%P,XUUO$%%; SET NEW MODE
%SETSTS%0,(T1)
%POPJ%P,%%; RETURN
SETMODE:%; FCT 3: SET RAW OR COOKED MODE
%PUSHJ%P,XUUO$%%; GET CURRENT MODE
%GETSTS%0,T1
%TRNE%T1,COOKED%; COOKED?
% TDZA%C,C%%; YES
%MOVEI%C,1%%; NO, RAW
%JUMPL%T2,$9%%; EXIT IF READ ONLY
%SKIPL%T2%%; LEGAL VALUE?
%CAILE%T2,1
% JRST%ERRDV$%%; NOPE
%TRZ%T1,RAW!COOKED%; CLEAR OUT MODE
%CAIE%T2,0%%; SET TO COOKED?
% JRST%$7%%; NOPE
%TRO%T1,COOKED%; YES
%PUSH%P,[INCHWL C]%; SET NEW I/O CALLS
%PUSH%P,[PUSHJ P,OUTC]
%HRL%T2,OLDRT%; USE ORIGINAL ^R^T AND ^S^Q SETTINGS
%HRR%T2,OLDSQ
%JRST%$8%%; MERGE BELOW
$7:%TRO%T1,RAW%%; SET TO RAW
%PUSH%P,[INCHRW C]%; CHANGE I/O CALLS
%PUSH%P,[OUTCHR C]
%MOVSI%T2,1%%; MAKE ^R^T ^S^Q ORDINARY CHARACTERS
$8:%POP%P,OCALL%%; RESET I/O CALLS
%POP%P,ICALL
%PUSHJ%P,XUUO$%%; RESET STATUS
%SETSTS%0,(T1)
%HLR%Z,T2%%; RESET ^R^T
%HRLI%Z,2036
%PUSHJ%P,TRMOP
% JFCL%%%; IGNORE THIS
%HRR%Z,T2%%; RESET ^S^Q
%HRLI%Z,2021
%PUSHJ%P,TRMOP
% JFCL
%JRST%$9%%; RETURN OLD VALUE
SETBLANKS:%; FCT 15: SET BLANKS
%MOVSI%Z,1025%%; GET OLD SETTING
%PUSHJ%P,TRMOP
% JRST%ERRDV$%%; SHOULDN'T HAPPEN
%JUMPL%T2,$10%%; RETURN IF READ ONLY
%MOVE%C,Z%%; SAVE IT
%HRR%Z,T2%%; SET NEW SETTING
%HRLI%Z,2025
%PUSHJ%P,TRMOP
% JRST%ERRDV$%%; OOPS
$9:%MOVE%R,C%%; RETURN OLD SETTING
$10:%POPJ%P,%%; RETURN
 
; TRMOP - DO TRMOP UUO; SET Z TO FCT,,VALUE; RESULT RETURNED IN Z
;
TRMOP:%HLRZM%Z,TARGS%%; SET UP ARG BLOCK FOR TRMOP.
%HRRZM%Z,TARGS+2
%MOVE%Z,[3,,TARGS]%; DO IT
%TRMOP.%Z,
% SKIPA%%%; OOPS
%AOS%(P)%%; GIVE SKIP RETURN
%POPJ%P,
 
END
#-H- UNPACK.MAC 952 1980 103 2149
SEARCH%IOPARM
TITLE.%UNPACK
; UNPACK(N:INTEGER,S:PACKED STRING,D:STRING):INTEGER -- UNPACK N
; CHARACTERS FROM S TO D.  STOPS IF A NULL CHARACTER IS ENCOUNTERED.
; RETURNS THE NUMBER OF CHARACTERS UNPACKED AND PUTS A EOS ON THE
; END OF D.
;
UNPACK::PUSHJ   P,SAVR$##        ; SAVE REGISTERS
        HRRI    T1,@1(A)        ; SET UP POINTER ...
        HRLI    T1,(POINT 7)    ;  TO S
        MOVEI   T2,@2(A)        ; GET ADDRESS OF D
        MOVE%R,@0(A)         ; GET N
        JUMPE%R,$2%%; DONE ALREADY?
$1:%ILDB    C,T1%%; GET A CHARACTER FROM S
        JUMPE   C,$2%%; QUIT IF IT IS NULL
        MOVEM   C,(T2)          ; STORE IN D
        ADDI    T2,1            ; INCREMENT ADDRESS OF D
        SOJG    R,$1%%; LOOP TILL DONE
$2:%MOVE%C,[EOS]%%; GET END OF STRING INDICATOR
        MOVEM   C,(T2)          ; PUT AT END OF D
        MOVE    R,T2            ; COMPUTE LENGTH
        SUBI    R,@2(A)
        POPJ    P,              ; RETURN
END
#-H- WRITEF.MAC 732 1980 103 2149
SEARCH%IOPARM
TITLE.%WRITEF
; WRITEF(BUF,COUNT,FD) -- WRITE TO FILE FD.
;
WRITEF::PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS
%SKIPG%T2,@1(A)%; COUNT
% JRST%[CLEAR%R,
%% POPJ%P, ]%; EMPTY BUFFER SO RETURN
%MOVEI%T1,@0(A)%; POINTER TO BUFFER
%MOVE%F,@2(A)
%MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB
%MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK
%MOVE%Z,OPNMODE(F)%; GET MODE
%TRNN%Z,3%%; OPEN FOR READ ONLY?
% JRST%[MOVE%R,[ERR]
%% POPJ%P,    ] ; RETURN ERROR READ ONLY MODE
%MOVE%C,MAJOR(F)%; DEVICE NUMBER FOR COMPUTED CALL
%LDB%Z,PACKPTR(F)%; CHECK FOR PACKED BUFFER
%JUMPE%Z,.+3
%HLL%T1,BYTEPTR(F)%; USE PACKED POINTER
%JRST%@WRSW$##(C)%; DISPATCH TO DEVICE DRIVER
%HRLI%T1,(POINT 36)%; USE UNPACKED POINTER
%JRST%@WRSW$(C)
END
#-H- XOR.MAC 165 1980 103 2149
SEARCH%IOPARM
TITLE.%XOR
; XOR(I:CHR,J:CHR):CHR -- RETURN I XOR J
;
XOR::%MOVE%R,@0(16)%; FETCH I
%XOR%R,@1(16)%; XOR J
        POPJ    P,              ; RETURN
END
#-H- XUUO.MAC 519 1980 103 2149
SEARCH%IOPARM
TITLE.%XUUO$
; XUUO$ -- EXECUTE AN I/O UUO.  CALL IS
;%MOVE%F,POINTER TO FILE BLOCK
;%PUSHJ%P,XUUO$
;%UUO%0,E
;% UUO DID NOT SKIP
;%UUO SKIPPED
;
XUUO$::PUSH%P,T1%%; SAVE AN AC
%MOVE%T1,CHANNEL(F)%; GET CHANNEL
%IOR%T1,@-1(P)%; OR IN THE UUO
%EXCH%T1,(P)%%; STASH ON TOP OF STACK AND RESTORE T1
%XCT%(P)%%; EXECUTE THE UUO
% SKIPA%%%; NONSKIP RETURN
%AOS%-1(P)           ; BUMP FOR SKIP RETURN
        SUB     P,[1,,1]        ; TOSS THE UUO
%AOS%(P)%%; BUMP RETURN POINT ONCE AGAIN
%POPJ%P,%%; RETURN
END
#========== CYBER I/O SYSTEM ==========
#-H- CLOSE.RAT 1843 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## CLOSE -- CYBER 175 VERSION OF CLOSE
#
SUBROUTINE CLOSE(FD)
  INTEGER FD
  INTEGER I, JUNK, PUTCH, DMASK
  INTEGER CURWORD, CURBYTE, BITPBYT
 
  INCLUDE CIOSYS
 
   DATA DMASK/77777777777777000000B/
 
   I = FDTAB(FD+1)
   IF (I == 0) RETURN   # ALLOW CLOSE OF UNOPENED FILE
 
   I = I - LOCF(FILTAB(1))              # GET OFFSET INTO FILTAB
 
   FDTAB(FD+1) = 0      # FREE SLOT
   FILTAB(USECNT+I) = FILTAB(USECNT+I) - 1
   IF (FILTAB(USECNT+I) <= 0) <
     IF (FILTAB(MODE+I) != READ) <     # FLUSH ALL BUFFERS
        CURWORD = FILTAB(CURRENTWORD+I)
        CURBYTE = FILTAB(CURRENTBYTE+I)
        BITPBYT = FILTAB(BITSPERBYTE+I)
        FILTAB(BUFSTART+CURWORD+I) = FILTAB(BUFSTART+CURWORD+I) &
           MASK(CURBYTE*BITPBYT)       # CLEAN JUNK OUT OF LAST WORD
                                # SET NEW SIZE OF I/O BUF
        FILTAB(FETSTART+2+I) = FILTAB(FETSTART+1+I) + CURWORD
        IF (CURBYTE > 0)                # INCLUDE CURWORD IN BUFFER
           FILTAB(FETSTART+2+I) = FILTAB(FETSTART+2+I) + 1
        CALL WRITER(FILTAB(FETSTART+I),0)
        CALL RECALL(FILTAB(FETSTART+I))
        !
     IF (((DMASK & FILTAB(FETSTART+I)) != 6LOUTPUT) &
         ((DMASK & FILTAB(FETSTART+I)) != 5LINPUT) ) < # PROTECTED LFNS
        CALL REWIND(FILTAB(FETSTART+I)) # SHOULD BE SUFFICIENT
        CALL RECALL(FILTAB(FETSTART+I)) # ENSURE REWIND GETS DONE
%IF (FILTAB(FDBLOC+I) != 0) <
%   IF (FILTAB(MODE+I) != READ) <
%      CALL QQPURG(FILTAB(FDBLOC+4+I))
%      CALL QQCATLG(FILTAB(FDBLOC+4+I))
%      JUNK = SHIFT(FILTAB(FDBLOC+4+I),-9) & 77B
%      IF (JUNK != 0) <
%% CALL MESSAGE("CANNOT CATALOG FILE.",0)
%% CALL MESSAGE(FILTAB(FDBLOC+I),0)
%% CALL MESSAGE(JUNK,0)
%% !
              !
           CALL QQCLOSE(FILTAB(FETSTART+I)) # LET SYSTEM DETACH PFN
           !
        !
     !
 
   RETURN
END
#-H- CREATE.RAT 865 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## CREATE -- CREATE A FET FOR A FILE (CYBER 175 VERSION)
#
INTEGER FUNCTION CREATE(NAME,FMODE)
   CHARACTER NAME(ARB)
   INTEGER FMODE, FD, I, J, L, FTYPE
   INTEGER QQFPARS, QQFTBL, PFNCMD
 
   INCLUDE CIOSYS
   INCLUDE CPFNS
 
   FTYPE = QQFPARS(NAME)           # GET PACKED FILE NAME
   IF (FTYPE == ERR)              # FILE NAME IS ILLEGAL
      RETURN (ERR)
 
   FOR (FD = 1; FD <= MAXFILES; FD = FD + 1)  # FIND OPEN SLOT
      IF (FDTAB(FD) == 0)
         BREAK
   IF (FD > MAXFILES) # ALL SLOTS USED
      RETURN (ERR)
 
   I = QQFTBL(FD,FMODE)%%# BUILD CYBER FILE TABLES
   IF (I == ERR)
      RETURN (ERR)
 
   IF (FTYPE == PERMFILE)%# PROCESS PERMANENT FILE
      IF (FBKTAB(MODE,I) == READ) <
         IF (PFNCMD(ATTACH,FD-1) != 0)
            CALL QQRQPF(TLFN)
% !
      ELSE
         CALL QQRQPF(TLFN)
 
   RETURN (FD-1)
 
END
#-H- DATE4.RAT 1687 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# NOTE: THESE ROUTINES WILL WORK ONLY UNTIL DEC 31, 1999!
 
# DATE4 -- GET THE TIME AND DATE FROM THE SYSTEM
#
SUBROUTINE DATE4(MTHDAY,YEAR,TIME,SECONDS)
INTEGER MTHDAY, YEAR, TIME, SECONDS
INTEGER CTMP, DTMP1, DTMP2, MONTH
CVTDIG(STR) = (STR & 77B) - 33B  #DISPLAY CODE TO INTEGER
CVTNUM(STR,CPOS) = 10 * CVTDIG(SHIFT(STR,6*CPOS)) +
%%        CVTDIG(SHIFT(STR,6*(CPOS+1)))
 
   CALL GETCLCK(DTMP1,1)
   CALL GETCLCK(CTMP,0)
   CALL GETCLCK(DTMP2,1)
   IF (DTMP1 != DTMP2)
      CALL GETCLCK(CTMP,0)
 
   SECONDS = CVTNUM(CTMP,8)      # CTMP IS HH:MM:SS
   TIME = 100 * CVTNUM(CTMP,2) + CVTNUM(CTMP,5)
 
   MONTH = CVTNUM(DTMP2,2) %# FIRST, ASSUME MM/DD/YY
   IF (MONTH == 0 \ MONTH > 12) < # WHOOPS, IT WAS YY/MM/DD
      YEAR = MONTH + 1900
      MTHDAY = 100*CVTNUM(DTMP2,5) + CVTNUM(DTMP2,8)
      !
   ELSE <
      YEAR = CVTNUM(DTMP2,8) + 1900
      MTHDAY = 100*MONTH + CVTNUM(DTMP2,5)
      !
 
   RETURN
END
 
## GETDAT():INTEGER -- RETURN MMDD AS INTEGER VALUE
INTEGER FUNCTION GETDAT(X)
   INTEGER DATE, YEAR, TIME, SECONDS
 
   CALL DATE4(DATE, YEAR, TIME, SECONDS)
   RETURN (DATE)
END
 
 
## GETYER():INTEGER -- RETURN YEAR AS INTEGER VALUE
INTEGER FUNCTION GETYER(X)
   INTEGER DATE, YEAR, TIME, SECONDS
 
   CALL DATE4(DATE, YEAR, TIME, SECONDS)
   RETURN (YEAR)
END
 
 
## GETTIM():INTEGER -- RETURN HHMMM AS INTEGER VALUE
INTEGER FUNCTION GETTIM(X)
   INTEGER DATE, YEAR, TIME, SECONDS
 
   CALL DATE4(DATE, YEAR, TIME, SECONDS)
   RETURN (TIME)
END
 
 
## GETSEC():INTEGER -- RETURN SECONDS AS INTEGER VALUE (TIME OF DAY)
INTEGER FUNCTION GETSEC(X)
   INTEGER DATE, YEAR, TIME, SECONDS
 
   CALL DATE4(DATE, YEAR, TIME, SECONDS)
   RETURN (SECONDS)
END
#-H- DELARG.RAT 447 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# DELARG - DELETE ARGUMENT  N  FROM COMMAND STRING
   SUBROUTINE DELARG(N)
   INTEGER N, I, ARGPTR, NXTARG
   INCLUDE CARGS
 
   IF (N > NARGS \ N <= 0)
      RETURN
   ARGPTR = 1   # WALK DOWN LIST TO N - 1 ARGUMENT (NXTARG IS N)
   NXTARG = AMEM(ARGPTR)
   FOR (I =1; I < N; I = I + 1) <
      ARGPTR = NXTARG
      NXTARG = AMEM(ARGPTR)
      !
   AMEM(ARGPTR) = AMEM(NXTARG)
   NARGS = NARGS - 1
   RETURN
   END
#-H- DUP.RAT 521 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# DUP - DUPLICATE FILE DESCRIPTOR FD. (CYBER VERSION)
INTEGER FUNCTION DUP(FD)
   INTEGER FD
   INTEGER I, J
   INCLUDE CIOSYS
 
   FOR (I = 1; I <= MAXFILES; I = I + 1)  # FIND A FREE DESCRIPTOR
      IF (FDTAB(I) == 0)
         BREAK
   IF (I > MAXFILES)
      RETURN (ERR)
   FDTAB(I) = FDTAB(FD+1)       # POINT TO SAME FILE BLOCK
   J = FDTAB(I) - LOCF(FILTAB(1))       # GET OFFSET INTO FILTAB
   FILTAB(USECNT+J) = FILTAB(USECNT+J) + 1      # BUMP REFERENCE COUNT
   RETURN (I-1)
END
#-H- ERROR.RAT 154 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## ERROR -- PRINT ERROR MESSAGE AND QUIT.
#
   SUBROUTINE ERROR(S)
   INTEGER S(1)
 
   CALL REMARK(S)
   CALL EXIT
 
   END
#-H- GETARG.RAT 743 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# GETARG - GET ARGUMENT  N  FROM COMMAND STRING INTO  ARRAY
   INTEGER FUNCTION GETARG(N, ARRAY, MAXSIZ)
   CHARACTER ARRAY(ARB)
   INTEGER N, MAXSIZ, I, ARGPTR
   INCLUDE CARGS
 
   ARRAY(1) = EOS
   IF (N == -1)
      GETARG = NARGS
   ELSE IF (N > NARGS \ N < 0)
      GETARG = EOF
   ELSE <
      ARGPTR = 1        # WALK DOWN LIST TO PROPER ARGUMENT
      FOR (I = 0; I < N; I = I + 1)
         ARGPTR = AMEM(ARGPTR)
      FOR (I = 1; I <= MAXSIZ; I = I + 1) <
         ARGPTR = ARGPTR + 1
         ARRAY(I) = AMEM(ARGPTR)
         IF (ARRAY(I) == EOS)
            BREAK
         !
      IF (I > MAXSIZ)
         ARRAY(MAXSIZ) = EOS       # INSURE END OF STRING
      GETARG = I - 1
      !
   RETURN
   END
#-H- OPEN.RAT 1014 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# OPEN - OPEN FILE NAME ACCORDING TO MODE
#               (CYBER VERSION)
INTEGER FUNCTION OPEN(NAME, FMODE)
   CHARACTER NAME(ARB)
   INTEGER FMODE
   INTEGER FD, QQFPARS, ISFILQQ, FTYPE, QQFTBL, I, PFNCMD
 
   INCLUDE CIOSYS
   INCLUDE CPFNS
 
   FTYPE = QQFPARS(NAME)             # GET FILE NAME
   IF (FTYPE == ERR)              # BAD FILE NAME
      RETURN (ERR)
   IF (FTYPE == LOCALFILE)
      IF (ISFILQQ(TLFN) == NO)       # SEE IF FILE EXISTS
         RETURN (ERR)              #  AND SIGNAL IF NOT
 
   FOR (FD = 1; FD <= MAXFILES; FD = FD + 1)  # FIND OPEN SLOT
      IF (FDTAB(FD) == 0)
         BREAK
   IF (FD > MAXFILES) # ALL SLOTS USED
      RETURN (ERR)
 
   I = QQFTBL(FD,FMODE)%# BUILD CYBER FILE TABLES
   IF (I == ERR)
      RETURN (ERR)
 
   IF (FTYPE == PERMFILE) <
      IF (PFNCMD(ATTACH,FD-1) != 0) <  # FILE NOT PRESENT
          FDTAB(FD) = 0
          FBKTAB(USECNT,I) = FBKTAB(USECNT,I) - 1
          RETURN (ERR)
          !
      !
 
   RETURN (FD-1)
END
#-H- PFNCMD.RAT 735 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## PFNCMD(CMD,FD) - EXECUTE PERMANENT FILE COMMAND CMD ON FILE FD
#
INTEGER FUNCTION PFNCMD(CMD,FD)
INTEGER CMD, FD
INTEGER I, RMASK
 
INCLUDE CIOSYS
 
DATA RMASK/77B/
 
I = FDTAB(FD+1)
IF (I <= 0)
   RETURN (ERR)
I = I - LOCF(FILTAB(1))
IF (FILTAB(FDBLOC+I) == 0)
   RETURN (ERR)
 
IF (CMD == ATTACH)
   CALL QQATTCH(FILTAB(FDBLOC+4+I))
ELSE IF (CMD == CATALOG)
   CALL QQCATLG(FILTAB(FDBLOC+4+I))
ELSE IF (CMD == PURGE)
   CALL QQPURG(FILTAB(FDBLOC+4+I))
ELSE IF (CMD == ALTER)
   CALL QQALTER(FILTAB(FDBLOC+4+I))
ELSE IF (CMD == EXTEND)
   CALL QQXTND(FILTAB(FDBLOC+4+I))
ELSE IF (CMD == RENAME)
   CALL QQRENAM(FILTAB(FDBLOC+4+I))
ELSE
   RETURN (ERR)
 
RETURN (SHIFT(FILTAB(FDBLOC+4+I),-9) & RMASK)
 
END
#-H- QQCTOK.RAT 2029 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## QQCTOK -- GET THE NEXT COMMAND LINE TOKEN
   INTEGER FUNCTION QQCTOK(T,TOK)
   CHARACTER T, TOK(MAXARG)
   CHARACTER C, LLC
   INTEGER I, CURBYTE
   INCLUDE CARGS
   DATA CURBYTE/0/
 
   IF (PEEK != 0) <     # NEXT TOKEN IS EOF
        TOK(1) = NEWLINE
        TOK(2) = EOS
        RETURN (EOF)
        !
 
   REPEAT <             # SKIP LEADING BLANKS
        C = LLC(JUNK,AMEM(COMADDR+MEMOFF),CURBYTE)
        CURBYTE = CURBYTE + 1
        !
   UNTIL (C != BLANK)
   IF (C == 0)
      C = NEWLINE
 
   TOK(1) = EOS         # HAVE NULL ARGUMENT INITIALLY
 
   IF (C == COMMA \ C == LPAREN)
        RETURN (ALPHA)
   IF (C == PERIOD \ C == RPAREN \ C == NEWLINE) <
        PEEK = C
        RETURN (ALPHA)
        !
 
   IF (C == DQUOTE \ C == SQUOTE \ C == DOLLAR) <
      FOR (I = 1;LLC(TOK(I),AMEM(COMADDR+MEMOFF),CURBYTE) != 0;
           I = I + 1) <
        CURBYTE = CURBYTE + 1
        IF (TOK(I) == C)
           BREAK
        ELSE IF (I >= MAXARG)
           CALL QQERR1("QQCTOK:ARGUMENT TOO LONG.")
        !
      IF (TOK(I) != C)
        CALL QQERR1("QQCTOK:MISSING CLOSING DELIMITER.")
      TOK(I) = EOS
      T = DQUOTE
      C = BLANK         # FORCE SKIP OF TRAILING BLANKS
      !
   ELSE <               # NORMAL ARGUMENT
      TOK(1) = C
      FOR (I = 2;LLC(C,AMEM(COMADDR+MEMOFF),CURBYTE) != 0;
           I = I + 1) <
        CURBYTE = CURBYTE + 1
        IF (C == BLANK \ C == COMMA \ C == PERIOD \ C == LPAREN \
                C == RPAREN)
           BREAK
        ELSE IF (I >= MAXARG)
           CALL QQERR1("QQCTOK:ARGUMENT TOO LONG.")
        ELSE
           TOK(I) = C
        !
      TOK(I) = EOS
      T = ALPHA
      !
 
   WHILE (C == BLANK) <         # SKIP TRAILING BLANKS
      C = LLC(JUNK,AMEM(COMADDR+MEMOFF),CURBYTE)
      CURBYTE = CURBYTE + 1
      !
   IF (C == 0)
      C = NEWLINE
 
   IF (C == PERIOD \ C == RPAREN \ C == NEWLINE)
      PEEK = C
   ELSE IF (C != COMMA & C != LPAREN)   # PUSH BACK CHAR.
      CURBYTE = CURBYTE - 1
 
   RETURN (T)
   END
#-H- QQERR1.RAT 775 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# RUNTIME ROUTINES -- CYBER DEPENDENT FORTRAN ROUTINES TO PROVIDE
#  ICON WITH INFORMATION FROM MACHINE DEPENDENT SOURCES.
#
 
# - QQERR1(S): PRINT THE MESSAGE S IN THE DAYFILE, 40 CHARACTERS
# PER LINE, AND ABORT THE JOB.
 
SUBROUTINE QQERR1(S)
INTEGER LLC, S(1), OUTMSG(5), JUNK
INTEGER NCH, NWRD, NLIN
INTEGER CWRD, CLIN
 
                        # FIRST DETERMINE LENGTH OF MESSAGE S
FOR (NCH = 0; LLC(JUNK,S,NCH) != 0; NCH = NCH + 1)
   ;
NWRD = (NCH + 9) / 10
NLIN = (NCH + 39) / 40
 
FOR (CLIN = 0; CLIN < NLIN; CLIN = CLIN + 1) <
   FOR (CWRD = 1; CWRD <= MIN0(4,NWRD-4*CLIN); CWRD = CWRD + 1)
      OUTMSG(CWRD) = S(4*CLIN+CWRD)
   OUTMSG(CWRD) = 0             # EOL MARKER
   CALL MESSAGE(OUTMSG,0)
  !
 
CALL ABORT("ND,S")
END
#-H- QQEXIT.RAT 252 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## QQEXIT -- CLOSE ALL OPEN FILES, (FLUSHES OUTPUT BUFFERS)
#       CALLED BY FORTRAN EXECUTIVE UPON PROGRAM STOP, EXIT OR ABORT.
SUBROUTINE QQEXIT
   INTEGER I
 
   DO I = 1, MAXFILES
     CALL CLOSE (I-1)
 
   RETURN
END
#-H- QQFPAR.RAT 4095 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## - QQFPARS -- GET FILE NAME AND SWITCHES (PACKED OR UNPACKED)
#
INTEGER FUNCTION QQFPARS(NAME)
INTEGER NAME(1), VALFNQQ
INTEGER I, JUNK, K, FBUF(10), DBUF(8), XR, TK, PW1, PW2
CHARACTER QQGNXTC, C, QQPSTR, QQMKLFN
 
INCLUDE CMAP
INCLUDE CPFNS
 
TLFN = 0%%# ASSUME NO FILE NAME YET
SWITCH = -1%# AND NO SWITCH
PFN(1) = 0%# ALSO NO PERMANENT FILE NAME
ID = 0%%# ... NO ID
XR = 0%%# ... NO EXTEND PASSWORD
TK = 0%%# ... NO TURNKEY PASSWORD
RP = RPKEY%# ... NO RETENTION PERIOD
CY = SHIFT(1,6) \ CYKEY%    # ... CYCLE NUMBER 1 (DEFAULT)
 
I = 0
C = QQGNXTC(JUNK,NAME,I)
 
WHILE (C != EOS) <
  IF (C == SLASH) <%# HAVE A SWITCH
    SWITCH = -1
    C = QQGNXTC(JUNK,NAME,I)
    WHILE (C != SLASH & C != BLANK & C != EOS) <
      IF (C == LETA \ C == BIGA)%# 12-BIT ASCII
%SWITCH = 61
      ELSE IF (C == LETD \ C == BIGD)%# DISPLAY CODE
%SWITCH = 0
      ELSE IF (C == LETN \ C == BIGN)%# NORMAL CODE
%SWITCH = 0
      ELSE IF (C == LETW \ C == BIGW)%# WORD I/O
%SWITCH = 60
      ELSE IF (C == LETX \ C == BIGX)%# 6/12 'ASCII'
%SWITCH = 62
      ELSE IF (C >= DIG0 & C <= DIG9) <%# N-BIT I/O
%SWITCH = C - DIG0
%C = QQGNXTC(JUNK,NAME,I)
%WHILE (C >= DIG0 & C <= DIG9) <
%   SWITCH = 10*SWITCH + (C-DIG0)
%   C = QQGNXTC(JUNK,NAME,I)
%   !
%IF (SWITCH > 60)
%   SWITCH = -1
%NEXT
%!
      ELSE IF (C == LETI \ C == BIGI) < # ID PRESENT
%C = QQGNXTC(JUNK,NAME,I)
%IF ( C == LETD \ C == BIGD) <
%   C = QQGNXTC(JUNK,NAME,I)
%   IF (C == COLON) <
              C = QQPSTR(NAME,I,DBUF,QRIGHT)
              ID = (SHIFT(DBUF(1),6) & KEYMASK) \ IDKEY
%      !
%   !
        NEXT
        !
      ELSE IF (C == LETP \ C == BIGP) < # PW PRESENT
%C = QQGNXTC(JUNK,NAME,I)
%IF ( C == LETW \ C == BIGW) <
%   C = QQGNXTC(JUNK,NAME,I)
%   IF (C == COLON) <
              C = QQPSTR(NAME,I,DBUF,QRIGHT)
%      XR = (SHIFT(DBUF(1),6) & KEYMASK) \ XRKEY
%      PW1 = (SHIFT(DBUF(1),6) & KEYMASK) \ PW1KEY
%      !
%   !
        NEXT
        !
      ELSE IF (C == LETT \ C == BIGT) < # PW PRESENT
%C = QQGNXTC(JUNK,NAME,I)
%IF ( C == LETK \ C == BIGK) <
%   C = QQGNXTC(JUNK,NAME,I)
%   IF (C == COLON) <
              C = QQPSTR(NAME,I,DBUF,QRIGHT)
%      TK = (SHIFT(DBUF(1),6) & KEYMASK) \ TKKEY
%      PW2 = (SHIFT(DBUF(1),6) & KEYMASK) \ PW2KEY
%      !
%   !
        NEXT
        !
      ELSE IF (C == LETR \ C == BIGR) < # RP PRESENT
%C = QQGNXTC(JUNK,NAME,I)
%IF ( C == LETP \ C == BIGP) <
%   C = QQGNXTC(JUNK,NAME,I)
%   IF (C == COLON) <
%      RP = 0
              C = QQGNXTC(JUNK,NAME,I)
              WHILE (C >= DIG0 & C <= DIG9) <
                 RP = 10 * RP + (C - DIG0)
                 C = QQGNXTC(JUNK,NAME,I)
                 !
              IF (RP > 999)
                 RP = 999
              RP = SHIFT(RP,6) \ RPKEY
%      !
%   !
        NEXT
        !
      ELSE IF (C == LETC \ C == BIGC) < # CYCLE PRESENT
%C = QQGNXTC(JUNK,NAME,I)
%IF ( C == LETY \ C == BIGY) <
%   C = QQGNXTC(JUNK,NAME,I)
%   IF (C == COLON) <
%      CY = 0
              C = QQGNXTC(JUNK,NAME,I)
              WHILE (C >= DIG0 & C <= DIG9) <
                 CY = 10 * CY Y+ (C - DIG0)
                 C = QQGNXTC(JUNK,NAME,I)
                 !
              IF (CY > 999)
                 CY = 999
              CY = SHIFT(CY,6) \ CYKEY
%      !
%   !
        NEXT
        !
      C = QQGNXTC(JUNK,NAME,I)
      !
    !
 
   ELSE IF (C != BLANK) <%# HAVE A FILE NAME
      FOR (K=1; K<=10; K=K+1)
         FBUF(K) = 0
      I = I - 1
      C = QQPSTR(NAME,I,FBUF,QLEFT)
      !
 
   ELSE
      C = QQGNXTC(JUNK,NAME,I)
   !
 
IF (ID == 0)%# HAVE A PLAIN OLD LOCAL FILE.
   TLFN = FBUF(1) & LFNMASK
ELSE <
   TLFN = QQMKLFN(JUNK)
   FOR (K = 1; K <= 4; K= K+1)
     PFN(K) = FBUF(K)
   K = 1
   IF (TK != 0) <
      KEYTAB(K) = TK%%# SAVE TURNKEY PASSWORD IN FDB
      KEYTAB(K+1) = PW2
      K = K + 2
      !
   IF (XR != 0) <
      KEYTAB(K) = XR%%# SAVE XR PASSWORD IN FDB
      KEYTAB(K+1) = PW1
      K = K + 2
      !
   KEYTAB(K) = 0%%# END OF FDB MARK
   !
 
IF (VALFNQQ(TLFN) == YES)
   IF (ID == 0)
      RETURN (LOCALFILE)
   ELSE
      RETURN (PERMFILE)
 
RETURN (ERR)
 
END
#-H- QQFTBL.RAT 3201 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
DEFINE (XFNOR,1)
DEFINE (XFEXT,2)
DEFINE (TXOT,3)
 
## QQFTBL -- CREATE A FET FOR A FILE
#
INTEGER FUNCTION QQFTBL(FD,FMODE)
   INTEGER FD, I, J, L
   INTEGER RWMODE, MAP, BYTSIZE, BYTPWRD, BYTE
   INTEGER IFTRMNL, XFMODX, FILMODE, TRMMODE
 
   INCLUDE CIOSYS
   INCLUDE CPFNS
 
   FOR (I = 1; I <= MAXFILES; I = I + 1)        # FIND OPEN FETSPACE
      IF (FBKTAB(USECNT,I) == 0)
         BREAK
   IF (I > MAXFILES) # ALL FETS USED
      RETURN (ERR)
 
   RWMODE = FMODE & 7B
   IF (SWITCH < 0)
      BYTSIZE = SHIFT(FMODE, -3)
   ELSE
      BYTSIZE = SWITCH
   IF (BYTSIZE <= 0) <
      MAP = YES
      BYTSIZE = 6
      !
   ELSE IF (BYTSIZE  ==  61) <   # 12-BIT ASCII
      MAP = -1
      BYTSIZE = 12
      !
   ELSE IF (BYTSIZE == 62) <     # 6/12 EXTENDED CHARACTER SET
      MAP = 2
      BYTSIZE = 6
      !
   ELSE
      MAP = NO
   BYTPWRD = 60/BYTSIZE         # BYTES/WORD
 
   FDTAB(FD) = LOCF(FBKTAB(BKSTART,I))  # INITIALIZE PTR IN FD TABLE
 
                                        # FILL FILE BLOCK
   FBKTAB(USECNT,I) = 1
   FBKTAB(MODE,I) = RWMODE
   FBKTAB(MAPFLAG,I) = MAP
   FBKTAB(BUFSIZE,I) = MAXBUFSIZE - 1   # LEN. OF I/O BUF.(ZERO-BASED)
   FBKTAB(BYTESPERWORD,I) = BYTPWRD
   IF (RWMODE == WRITE)
      FBKTAB(CURRENTWORD,I) = 0
   ELSE
      FBKTAB(CURRENTWORD,I) = MAXBUFSIZE        # FORCE INITIAL READ
   FBKTAB(CURRENTBYTE,I) = 0
   FBKTAB(BITSPERBYTE,I) = BYTSIZE
   FBKTAB(EOFFLAG,I) = NO
                                # INITIALIZE FET
   FBKTAB(FETSTART,I) = TLFN \ FILENOTBUSY
   FBKTAB(FETSTART+1,I) = LOCF(FBKTAB(BUFSTART,I))              #FIRST
   FBKTAB(FETSTART+2,I) = FBKTAB(FETSTART+1,I)          #IN
   FBKTAB(FETSTART+3,I) = FBKTAB(FETSTART+1,I)          #OUT
   FBKTAB(FETSTART+4,I) = FBKTAB(FETSTART+1,I) + MAXBUFSIZE     #LIMIT
 
   IF (RWMODE == WRITE) <
        IF ((TLFN == 6LOUTPUT) & (MAP == YES) &
%    (IFTRMNL(TLFN) == NO)) <  # USE CARRIAGE CONTROL
         FBKTAB(CURRENTBYTE,I) = 1
         FBKTAB(BUFSTART,I) = 1L1       # TOP OF PAGE FLAG
         FBKTAB(COL1BLANK,I) = YES
         !
      ELSE
         FBKTAB(COL1BLANK,I) = NO
      !
 
# NOW, IF MODE IS UNSPECIFIED, TRY TO FIGURE OUT FILE CODE.
#%(NOS/BE USERS GET DISPLAY CODE)
 
   IF (MAP == YES & SWITCH < 0) <
      XFMODX = FILMODE(TLFN)
      IF (XFMODX == XFNOR)%# NORMAL DISPLAY CODE FILE.
% FBKTAB(MAPFLAG,I) = 1
      ELSE IF (XFMODX == XFEXT) # EXTENDED DISPLAY CODE FILE.
% FBKTAB(MAPFLAG,I) = 2
      ELSE IF (TRMMODE(0) > 0)%# NULL MODE FILE, USE TERMINAL MODE
% FBKTAB(MAPFLAG,I) = TRMMODE(0)
      ELSE%%%# USE NORMAL MODE FOR BATCH JOBS
% FBKTAB(MAPFLAG,I) = 1
      !
 
   IF (ID == 0) %%# PLAIN OLD LFN
     FBKTAB(FDBLOC,I) = 0
   ELSE%<%%%# IT'S A PERMANENT FILE
     FOR (J = 0; J < 4; J=J+1)
        FBKTAB(FDBLOC+J,I) = PFN(J+1)
     FBKTAB(FDBLOC+4,I) = TLFN
     FBKTAB(FDBLOC+5,I) = ID
     FBKTAB(FDBLOC+6,I) = CY
     FBKTAB(FDBLOC+7,I) = RP
     FOR (J = 1; KEYTAB(J) != 0; J = J + 1)
        FBKTAB(FDBLOC+7+J,I) = KEYTAB(J)
     IF (RWMODE == READ) <
        FBKTAB(FDBLOC+7+J,I) = SHIFT(1,6) \ MRKEY   # ALLOW MULTI-ACCESS
        J = J + 1
        !
     FBKTAB(FDBLOC+7+J,I) = 0%# END OF FDB MARK
     !
 
   RETURN (I)
 
END
#-H- QQGNXT.RAT 521 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## QQGNXTC -- RETURN NEXT CHARC FROM ARRAY, REGARDLESS OF PACKING
#       INCREMENT LOC AFTER GETTING CHARACTER
#
   CHARACTER FUNCTION QQGNXTC(C,ARRAY,LOC)
   CHARACTER C, LLC, JUNK
   INTEGER ARRAY(ARB), LOC, DISPLAY
 
   DATA DISPLAY /77B/   # DISPLAY CODE CHAR. MASK
 
   IF ((SHIFT(ARRAY(1),6) & DISPLAY) != 0B) <  # DISPLAY CODE
      C = LLC(JUNK,ARRAY,LOC)
      IF (C == 0 \ C == NEWLINE)
         C = EOS
      !
   ELSE
      C = ARRAY(LOC+1)
   LOC = LOC + 1
   RETURN (C)
   END
#-H- QQINIT.RAT 3765 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
DEFINE (TXOT,3)%%# NOS INTERACTIVE ORIGIN JOB
 
## QQINIT -- INITIALIZE I/O FILES, GET ARGUMENTS TO COMMAND.
#
   SUBROUTINE QQINIT
   INTEGER I, ARGLEN, ARGPTR, K, ERRFLG
   INTEGER OPEN, CREATE, DUP, QQLEN
   CHARACTER C, T, ARG(MAXARG), QQCTOK
   CHARACTER ONAME(7),BONAME(7)
   INCLUDE CARGS
   INCLUDE CIOSYS
 
   DATA FDTAB/MAXFILES*0/
   DATA FBKTAB/FILBLK*0/
 
   DATA ONAME/LETO,LETU,LETT,LETP,LETU,LETT,EOS/
   DATA BONAME/BIGO,BIGU,BIGT,BIGP,BIGU,BIGT,EOS/
 
   MEMOFF = 1 - LOCF(AMEM(1))   # GET ADDRESSING OFFSET
   INPTR = 0
   OUTPTR = 0
   ERRPTR = 0
   NARGS = 0
 
   ARG(1) = EOS
   ARGPTR = 1
   PEEK = 0
   IF (QQCTOK(T,ARG) == ALPHA) <  # GET COMMAND NAME (CYBER VERB)
      ARGLEN = QQLEN(ARG) + 2
      CALL QQSCPY(ARG,1,AMEM,ARGPTR+1)
      !
   ELSE
      CALL QQERR1("UNRECOGNIZABLE COMMAND LINE.")
 
   I = ARGPTR + ARGLEN          # POINT TO NEXT FREE SLOT IN LIST
   WHILE (QQCTOK(T,ARG) != EOF) < # PROCESS REMAINING ARGUMENTS
      IF (T == NEWLINE)
        BREAK
      ARGLEN = QQLEN(ARG) + 2
      IF (I + ARGLEN > AMEMSIZE)
        CALL QQERR1("TOO MANY ARGUMENTS.")
      CALL QQSCPY(ARG,1,AMEM,I+1)
      IF (ARG(1) == LESS & T != DQUOTE)
        INPTR = I + 2
      ELSE IF (ARG(1) == GREATER & T != DQUOTE)
        OUTPTR = I + 2
      ELSE IF (ARG(1) == QMARK & T != DQUOTE)
        ERRPTR = I + 2
      ELSE <
        NARGS = NARGS + 1
        AMEM(ARGPTR) = I
        ARGPTR = I
        !
      I = I + ARGLEN            # POINT TO NEXT FREE SLOT
      !
   AMEM(ARGPTR) = 0     # ZERO POINTER AT END OF LINKED LIST
 
   IF (INPTR == 0) <    # OPEN STANDARD INPUT
      IF (OPEN("INPUT",READ) == ERR)
         IF (JOBORGN(0) == TXOT) <%# IF NOS INTERACTIVE JOB
%    IF (CREATE("INPUT",READ) == ERR) # MAKE FET FOR TTY
%       CALL QQERR1("CANNOT CREATE FILE 'INPUT'.")
%    !
% ELSE
%    CALL QQERR1("CANNOT OPEN FILE 'INPUT'.")
      !
   ELSE                 # RE-DIRECT STANDARD INPUT
      IF (OPEN(AMEM(INPTR),READ) == ERR)
        CALL QQERR1("CANNOT OPEN REDIRECTED INPUT FILE.")
 
   IF (OUTPTR == 0) <   # OPEN STANDARD OUTPUT
      IF (CREATE("OUTPUT",WRITE) == ERR)
         CALL QQERR1("CANNOT OPEN FILE = OUTPUT.")
      !
   ELSE                 # RE-DIRECT STANDARD OUTPUT
      IF (CREATE(AMEM(OUTPTR),WRITE) == ERR)
        CALL QQERR1("CANNOT OPEN REDIRECTED OUTPUT FILE.")
 
   ERRFLG = NO          # ASSUME NEED ONLY DUP STANDARD OUTPUT
   IF (ERRPTR != 0 & OUTPTR != 0) <
      K = QQLEN(AMEM(ERRPTR))
      IF (K != QQLEN(AMEM(OUTPTR)))
         ERRFLG = YES
      ELSE <
         FOR (I = 0; I < K; I = I + 1)
            IF (AMEM(ERRPTR+I) != AMEM(OUTPTR+I))
               BREAK
         IF (I != K)
            ERRFLG = YES
         !
      !
   ELSE IF (ERRPTR != 0 & OUTPTR == 0) <
      IF (QQLEN(AMEM(ERRPTR)) != 6)
         ERRFLG = YES
      ELSE <
         FOR (I = 0; I < 6; I = I + 1)
            IF(AMEM(ERRPTR+I) != ONAME(I+1) &
               AMEM(ERRPTR+I) != BONAME(I+1))
                BREAK
         IF (I != 6)
            ERRFLG = YES
         !
      !
   ELSE IF (ERRPTR == 0 & OUTPTR != 0) <
      IF (QQLEN(AMEM(OUTPTR)) != 6)
         ERRFLG = YES
      ELSE <
         FOR (I = 0; I < 6; I = I + 1)
            IF (AMEM(OUTPTR+I) != ONAME(I+1) &
                AMEM(OUTPTR+I) != BONAME(I+1))
                 BREAK
         IF (I != 6)
            ERRFLG = YES
         !
      !
 
   IF (ERRFLG == NO) <
      IF (DUP(STDOUT) == ERR)
         CALL QQERR1("CANNOT DUP STANDARD ERROR FILE.")
      !
   ELSE IF (ERRPTR == 0) <
      IF (CREATE("OUTPUT",WRITE) == ERR)
         CALL QQERR1("CANNOT CREATE STANDARD ERROR FILE.")
      !
   ELSE IF (CREATE(AMEM(ERRPTR),WRITE) == ERR)
         CALL QQERR1("CANNOT CREATE ERROR FILE.")
 
   RETURN
   END
#-H- QQMKLF.RAT 537 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# QQMKLFN(JUNK) - BUILD A UNIQUE LFN
INTEGER FUNCTION QQMKLFN(JUNK)
INTEGER JUNK
INTEGER TMP, LFN
 
INCLUDE CMAP
 
DATA LFN/00000014061601010100B/
 
TMP = LFN & 77B
IF (TMP == OUTMAP(DIG9+1)) <
   TMP = SHIFT(LFN,-6) & 77B
   IF (TMP == OUTMAP(DIG9+1)) <
      TMP = SHIFT(LFN,-12) & 77B
      IF (TMP == OUTMAP(DIG9+1))
         LFN = (LFN + 262144) & (!777777B)
      ELSE
         LFN = (LFN + 4096) & (!7777B)
      !
   ELSE
      LFN = (LFN + 64) & (!77B)
   !
LFN = LFN + 1
 
RETURN (SHIFT(LFN,18))
END
#-H- QQPSTR.RAT 674 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# QQPSTR(NAME,I,PACK) -- BUILD DISPLAY CODE PACKED STRING FROM NAME
#   RETURNS THE NEXT CHARACTER IN NAME.
INTEGER FUNCTION QQPSTR(NAME,I,PACK,JUSTIFY)
INTEGER NAME(ARB), PACK(ARB), I, JUSTIFY
INTEGER CH, WORD, C, QQGNXTC
 
INCLUDE CMAP
 
WORD = 0
CH = 0
 
C = QQGNXTC(JUNK,NAME,I)
WHILE (C != BLANK & C != SLASH & C != EOS) <
   IF (CH == 0) <
      WORD = WORD + 1
      PACK(WORD) = 0
      !
  IF (JUSTIFY == QRIGHT)
     PACK(WORD) = SHIFT(PACK(WORD),6) \ OUTMAP(C+1)
  ELSE
     PACK(WORD) = PACK(WORD) \ SHIFT(OUTMAP(C+1),60-6*(CH+1))
   IF (CH == 9)
      CH = 0
   ELSE
      CH = CH + 1
   C = QQGNXTC(JUNK,NAME,I)
   !
RETURN (C)
END
#-H- REMARK.RAT 292 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
# REMARK(S:STRING) - PRINT PACKED MESSAGE TO ERROR FILE.
#
SUBROUTINE REMARK(S)
INTEGER S(ARB),BUF(MAXLINE),LLC
 
   FOR (I = 0; LLC(BUF(I+1),S,I) != 0; I = I + 1)
       ;
   BUF(I+1) = NEWLINE
   BUF(I+2) = EOS
   CALL WRITEF(BUF,I+1,ERROUT)
   RETURN
 
   END
#-H- REMOVE.RAT 440 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
## REMOVE - REMOVE FILE
#
SUBROUTINE REMOVE(FNAME)
   CHARACTER FNAME(ARB)
   INTEGER QQFPARS, FTYPE, TMPFCB(16), I
 
   INCLUDE CPFNS
   EQUIVALENCE (PFN(1),TMPFCB(1))
 
   FTYPE = QQFPARS(FNAME)%# GET FILE NAME AND TYPE
   IF (FTYPE == ERR)%%# IGNORE PROBLEMS
      RETURN
 
   IF (FTYPE == PERMFILE)
      CALL QQPURG(TMPFCB(5))
   ELSE
      CALL REMOVQQ(TLFN)%# FORGET ABOUT LOCAL FILE NAME
   RETURN
END
#-H- RUNTIM.RAT 239 1979 1221 842
INCLUDE RATDEF
INCLUDE IODEFS
 
 
## RUNTIM():INTEGER -- RETURN JOB RUNTIME IN MILLISECONDS.
#       VERY MACHINE DEPENDANT!
#
INTEGER FUNCTION RUNTIM(TMP)
   INTEGER TMP
 
   RETURN 1000*GETCLCK(TMP,3) #LAST DIGIT UNTRUSTWORTHY ON CYBER
END
#-H- ABORT.COM 1213 1979 1221 842
*DECK ABORT
          IDENT ABORT
***       ABORT - ABORT JOB.
*
*         CALL ABORT(OPTION)
*
*         ENTRY  (OPTION) = 0 TO DO A STANDARD ABORT.
*                         = 2HND TO ABORT WITH NO *DMPX*.
*                         = 1HS TO ABORT TO AN *EXIT(S)* STATEMENT.
*                         = 4HND,S TO ABORT TO AN *EXIT(S)* WITH NO
*                           *DMPX*.
*
*         EXIT   DOES NOT EXIT
 
        ENTRY   ABORT
 
        USE DATA.
TMPSAV  BSS     1
 
 ABORT    BSSZ  1
          SB1    1
        BX7     X1              # SAVE TYPE OF ABORT
        SA7     TMPSAV
        RJ      =XQQEXIT         # CLOSE ALL FILES
        SA1     TMPSAV          # RESTORE TYPE OF ABORT
          SA2    X1          (X2) = OPTION
          ZR,X2  ABORT1      IF *ABORT* IS DESIRED
          SA3    =0HND
          BX4    X2-X3
          ZR,X4  ABORT2      IF *ABORT ,ND* NEEDED
          SA3    =0HS
          BX4    X2-X3
          ZR,X4  ABORT3      IF *ABORT ,,S* NEEDED
          SA3    =H/ND,S/
          BX4    X2-X3
          ZR,X4  ABORT4      IF *ABORT ,ND,S* NEEDED
          SA1    =0LABORT
 
 ABORT1   ABORT
 
 ABORT2   ABORT  ,ND
 
 ABORT3   ABORT  ,,S
 
 ABORT4   ABORT  ,ND,S
          END
#-H- ARG.COM 640 1979 1221 842
*DECK ARG
          IDENT ARG
** ARG(AP) -- RETURN THE ADDRESS OF THE CALLING SUBPROGRAMS
*    AP-TH ARGUMENT
*
*       ENTRY:  A0 = ADDRESS OF ARGLIST FOR CALLING
*                    SUBPROGRAM (SET BY FORTRAN)
*
*       EXIT:   X6 = ADDRESS OF AP-TH ARGUMENT
*
*       USES:   A2, A5, B2, X3, X4, X6
*
        ENTRY ARG
 
ARG     BSSZ    1
        SA2     X1              # AP INTO X2
        SB1     1B
        SB2     A0-B1           .. AND ARGLIST ADDR -1 TO B2
        SA5     X2+B2           # ADDR OF ARG AP INTO X5
        SX6     X5              .. AND INTO RETURN REGISTER
        EQ      ARG             # GO HOME
          END
#-H- CFP.COM 3029 1979 1221 842
*DECK CFP
          IDENT CPU.CFP
        ENTRY CFP>
 
***       CFP - CONVERT FLOATING POINT.
*
*         FROM *LUNAR* EXCURSION MODULE SIMULATOR.
*
*         CFP CONVERTS A FLOATING POINT NUMBER INTO F10.N FORMAT.
***              CFP CONVERTS A BINARY FLOATING POINT NUMBER TO ITS
*         DISPLAY CODE REPRESENTATION (NO SCIENTIFIC NOTATION).  UP
*         TO EIGHT DIGITS WILL BE CONVERTED, AS SELECTED BY THE CALLER.
*
*         DO NOT TRY TO CONVERT A NUMBER WHICH WILL USE THE MOST
*         SIGNIFICANT OUTPUT POSITION.  IT WONT WORK.  DO NOT USE
*         NUMBERS TOO BIG, AS THE OUTPUT WILL NOT BE CORRECT EVEN
*         THOUGH IT MAY LOOK REASONABLE.  UNDERFLOW WILL PRINT ZERO.
*
*         ENTRY  (X1) = NUMBER TO CONVERT, REAL FORMAT, CAN BE NEGATIVE.
*                (B1) = 1.
*                (B2) = NUMBER OF FRACTIONAL PLACES (0 TO 6).
*
*         EXIT   (X6) = CONVERSION.
*
*         USES   X - 0, 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4, 5, 6.
*                A - 2, 3, 4.
*
*         CALLS  CDD.
 
 
 CFP>     BSSZ   1               ENTRY/EXIT
          SB1    1
          SA2    CFPA+B2     READ ROUNDING FRACTION
          BX4    X1
          SB3    B2+B2       COUNT*2
          SA3    CFPB+B2     READ MAGNITUDE
          AX1    59
          SX0    1R-&1R
          BX4    X4-X1       (X4) = ABS(X1)
          SB4    B3+B3       COUNT*4
          RX4    X4+X2       ROUND NUMBER
          BX0    X1*X0       SET SIGN
          RX6    X3*X4       ADJUST MAGNITUDE
          SB6    B3+B4       COUNT*6
          UX2,B5 X6
          LX1    X2,B5
          RJ     =XCDD=      CONVERT DECIMAL DIGITS
          MX1    6           CLEAR TOP CHARACTER
          BX6    -X1*X6
          GT     B2,B6,CFP1  IF AT LEAST (COUNT+1) DIGITS
          SA4    CFPC
          SB3    B6-B2       SET(B6-B2)/6+1 LEADING ZEROS
          SB2    B6+B4
          AX2    X1,B3
          LX3    X2,B2
          BX4    X3*X4
          BX6    X6-X4
 CFP1     SB5    B6+B4       INSERT DECIMAL POINT
          SX2    1R.
          AX1    X1,B5
          LX0    X0,B2
          LX1    X1,B6
          LX2    X2,B6
          BX4    -X1*X6      INTEGER PART
          BX6    X1*X6       FRACTIONAL PART
          LX4    6
          BX6    X6+X2
          BX6    X6+X4
          LX0    6
          BX6    X6-X0       SET SIGN
          SB3    10          ASSURE BLANK FILL
          SX2    1R
          MX0    -6
 CFP2     SB3    B3-B1
          MI     B3,CFP>     RETURN
          BX1    -X0*X6
          NZ     X1,CFP3
          BX6    X0*X6
          BX6    X6+X2
 CFP3     LX6    6
          EQ     CFP2
 
 CFPA     DATA   0.5
          DATA   0.5E-1
          DATA   0.5E-2
          DATA   0.5E-3
          DATA   0.5E-4
          DATA   0.5E-5
          DATA   0.5E-6
          DATA   0.5E-7
 CFPB     DATA   1.
          DATA   1.E1
          DATA   1.E2
          DATA   1.E3
          DATA   1.E4
          DATA   1.E5
          DATA   1.E6
          DATA   1.E7
 CFPC     DATA   66666666666666666666B
 
          END
#-H- CLRB.COM 1198 1979 1221 842
*DECK CLRB
          IDENT CLRB
** CLRB(A:ADDR,I:INTEGER) -- CLEAR THE I-TH BIT (ZERO-BASED) OFFSET
*   FROM A, RETURNING BIT'S PREVIOUS VALUE AS VALUE OF FUNCTION
*
        ENTRY CLRB
 
CLRB    BSS     0
        BSSZ    1
 
        SB1     1B
        SA5     A1+1B           # X5 IS BIT POSITION TO TEST
        SX0     74B             # BITS/WORD
        PX7     B0,X0           # NOW COMPUTE WORD HOLDING BIT
        SA3     X5
        NX5     B0,X7
        PX7     B0,X3
        FX2     X7/X5           # X2 IS I/60 (INTEGER WORD OFFSET)
        UX7     B2,X2
        LX5     B2,X7
        DX7     X5*X0
        IX2     X1+X5
        SA4     X2              # GET THAT WORD FROM MEMORY
        IX0     X3-X7           # X0 IS MOD(I,60) NOW
        SB2     X0+B1           # FIND BIT IN WORD
        SX3     B1              # ONE BIT MASK
        LX5     B2,X4            . AND ROTATE SO IT IS RIGHT MOST
        BX6     X5*X3           # MASK OFF BIT AND RETURN IT'S VALUE
        BX5     -X3*X5          # CLEAR THE BIT
        SB2     X0-73B           . AND ROTATE WORD BACK
        AX7     B2,X5
        SA7     A4               . AND STORE BACK INTO MEMORY
        EQ      CLRB
          END
#-H- FILEQQ.COM 4995 1979 1221 842
*DECK,FILEQQ=
          IDENT  FILEQQ=
          TITLE  FILEQQ=     UTILITY FUNCTIONS FOR CREATE FUNCTION.
 URLF     =      23B         UFP CODE TO READ SYSTEM SECTOR
 TXOT     =      3           TERMINAL ORIGIN JOB
 NO       =      0
 YES      =      1
 
%IF%DEF,NOS%%# OK, HERE'S ALL THE NOS STUFF
**CALL,COMSPFM
**CALL,COMCMAC
          SYSCOM B1
 
          ENTRY  FILMODE     RETURN EXTERNAL MODE OF FILE
 FILMODE  PS     ,           ENTRY/EXIT
          SB1    1           CONSTANT
          SA1    X1          GET FILE NAME
          SX6    B1          FORM FET HEADER
          BX6    X6+X1
          SA6    FET         PLUG INTO SCRATCH FET
          SX7    B0          CLEAR UCW IN FET
          SA7    FET+CFUC
          FMODE  FET         READ SYSTEM SECTOR
          SA2    FET+CFUC    GET UCW
          MX0    58          CHARACTER SET IS 2 BITS
          AX2    18
          BX6    -X0*X2      EXTRACT CHARACTER SET
          EQ     FILMODE     RETURN
 
          ENTRY  JOBORGN     RETURN JOB ORIGIN TYPE CODE
 JOBORGN  PS     ,           ENTRY/EXIT
          SB1    1           CONSTANT
          GETJO  JOTX        GET JOB ORIGIN
          SA1    JOTX        RETURN IT
          BX6    X1
          EQ     JOBORGN     RETURN
 JOTX     CON    *-*         TEMP STORAGE
 
          ENTRY  IFTRMNL     RETURN 'YES' IF FILE IS TERMINAL,
*                               'NO' OTHERWISE.
 IFTRMNL  PS     ,           ENTRY/EXIT
          SB1    1           CONSTANT
          SA1    X1          GET FILE NAME
          SX6    B1          FORM FET HEADER
          BX6    X6+X1
          SA6    FET
          SX2    A6          FET POINTER
          RJ     STF         CHECK FOR TERMINAL FILE
          ZR     X6,IFTRMY   IF TERMINAL FILE
          SX6    NO          NOT TERMINAL FILE
          EQ     IFTRMNL     RETURN
 
 IFTRMY   SX6    YES         TERMINAL FILE
          EQ     IFTRMNL     RETURN
 
**CALL,COMCSTF
 
          ENTRY  TRMMODE     GET CURRENT TERMINAL MODE
 TRMMODE  PS     ,           ENTRY/EXIT
          RJ     JOBORGN     CHECK FOR INTERACTIVE JOB
          SX6    X6-TXOT
          NZ     X6,TMODB    IF NOT INTERACTIVE JOB
          TSTATUS TMODX      READ TERMINAL STATUS
          SA1    TMODX+1     PICK UP TERMINAL STATUS BITS
          SX2    4           ASCII/NORMAL BIT MASK
          BX6    X2*X1       0 IF NORMAL, 4 IF ASCII
          AX6    2           0 IF NORMAL, 1 IF ASCII
          SX6    X6+B1       1 IF NORMAL, 2 IF ASCII
          EQ     TRMMODE     RETURN
 
 TMODB    SX6    B0          0 FOR NON-INTERACTIVE JOB
          EQ     TRMMODE     RETURN
 
 TMODX    BSS    2           SCRATCH FOR TERMINAL STATUS
 
 FET      FILEB  BFR,101B,FET=13 SCRATCH FET
 BFR      BSS    101B        DUMMY BUFFER FOR SCRATCH FET
 
%ELSE%%%# AND THEN THE NOS/BE VERSIONS.
%  ENTRY FILMODE
FILMODE PS%,
%  SX6%1%%# ASSUME IT'S A DISPLAY CODE FILE
%  EQ%FILMODE
 
%  ENTRY JOBORGN
 JOBORGN  PS%,
%  SX6%0%%# ASSUME IT'S NOT INTERACTIVE
%  EQ%JOBORGN
 
%  ENTRY IFTRMNL
 IFTRMNL  PS%,
%  SX6%NO%%# ASSUME IT'S NOT A TERMINAL
%  EQ%IFTRMNL
 
%  ENTRY TRMMODE
 TRMMODE   PS%,
%  SX6%1%%# ASSUME IT'S DISPLAY CODE
%  EQ%TRMMODE
 
%ENDIF
 
 
*  VALFNQQ -- DETERMINE IF FILE NAME IS VALID CYBER FILE NAME
*
          ENTRY  VALFNQQ
 VALFNQQ  EQ     *+400000B
          SA1    X1          GET WORD
          MX2    7*6         SEVEN CHARACTER MASK
          BX3    -X2*X1      CHECK REST OF WORD
          NZ     X3,VAL2     IF > 7 CHARACTERS
          MX2    -6          CHARACTER MASK
          IF%DEF,NOS%%.NOS ALLOWS LEADING DIGITS
          SX4    1R9+1       FIRST NON-ALPHANUMERIC
          ELSE%%%.NOS/BE DOESN'T
          SX4% 1RZ+1
          ENDIF
 
 VAL1     LX1    6           POSITION CHARACTER
          BX3    -X2*X1      EXTRACT CHARACTER
          BX1    X2*X1       REMAINING CHARACTERS
          IX6    X3-X4       CHECK FOR LETTER OR DIGIT
          ZR     X3,VAL2     IF COLON (ZERO), INVALID
          PL     X6,VAL2     IF PUNCTUATION, INVALID
          SX4     1R9+1%%.ENSURE ACCEPT NON-LEADING DIGITS
          NZ     X1,VAL1     IF NOT DONE YET
          SX6    1           SET FLAG FOR VALID
          EQ     VALFNQQ     RETURN
 
 VAL2     SX6    0           SET FLAG FOR INVALID
          EQ     VALFNQQ     RETURN
 
 
* ISFILQQ -- RETURNS 0 IF FILE NOT PRESENT TO JOB, 1 IF IT IS
*
        ENTRY   ISFILQQ
 
TMPFIT  BSSZ    5
TLEN    EQU     40000B
 
ISFILQQ BSS     0
        BSSZ    1
 
        SB1     1B
        SA1     X1              PUT LFN INTO TMPFIT
        SX2     TLEN            ..FOLLOWED BY LEN OF FIT
        BX6     X1+X2           .. OR THE 2 TOGETHER
        SA6     TMPFIT
        IF%DEF,NOS%%.HANDLE NOS TEST
%  SYSTEM LFM,R,TMPFIT,12B*100B
%  SA2 TMPFIT
%  SX6 7776B
%  BX6 X6*X2
%  ZR X6,ISFILQQ
%ELSE%%%.HANDLE NOS/BE TEST
%  FILINFO TMPFIT          # GET FILE STATUS
%  SA2     B1+TMPFIT
%  SX6     B0
%  ZR      X2,ISFILQQ      # FILE NOT PRESENT TO JOB
%ENDIF
        SX6     B1
        EQ      ISFILQQ
 
          END
#-H- GETCH.COM 1556 1979 1221 842
*DECK GETCH
          IDENT GETCH
*  GETCH(C,FD) -- RETURN NEXT CHAR C FROM FILE FD
*
        ENTRY   GETCH
 
*CALL IODEFS
 
        USE /CIOSYS/
FDTAB   BSS     MAXFILE              #MAXFILE FILES OPEN AT ONCE
FBKTAB  BSS     FILBLK            #MAXFILE*80 (SIZE OF ONE FILE BLOCK)
 
        USE DATA.
ARGLIST BSS     2               #FAKE ARGLIST FOR READF=
 
        USE CODE.
 
GETCH   BSSZ    1               # READ ONE CHAR FROM FILE
 
        BX7     X1              # ADDRESS OF C
        SB1     1B
        SA7     ARGLIST         # STORED INTO FAKE ARGLIST
        SX6     B1              # NUMBER OF CHARS TO READ
        SA6     A7+B1           .. STORED INTO FAKE ARGLIST
        SA3     A1+B1           # ADDRESS OF FD INTO X3
        SA4     X3              .. FD INTO X4
        SA5     X4+FDTAB        # AND OFFSET INTO FILE BLOCK
        SX0     X5-1B           .. SAVED IN X0
        SB6     B1              # NUMBER OF CHARS TO READ
        SA1     ARGLIST         # POINT TO NEW ARGLIST
        RJ      =XREADF=        # CALL READF= TO DO WORK
        SB5     X6              .. CHECK RESULT
        NE      B1,B5,GETEOF    .. FOR EOF ON READ
        SA2     X1-1B           # GET BYTE READ
        BX6     X2              .. INTO RETURN REGISTER
        EQ      GETCH           # AND GO HOME
 
GETEOF  BSS     0               # DID NOT READ BYTE, RETURN CODE
        SX6     EOF             # INSURE EOF IS RETURNED
        SA6     X1              .. AS C (ARG1) AND VALUE OF GETCH
        EQ      GETCH           # AND GO HOME
          END
#-H- GETCLK.COM 2275 1979 1221 842
*DECK,GETCLCK
          IDENT  GETCLCK
          TITLE  GETCLCK     GET CLOCK READING.
          ENTRY  GETCLCK
          SPACE  4,10
***       GETCLCK -- GET CLOCK READING
*
*         GETCLCK(N,K) IS EQUIVALENT TO ONE OF THESE ROUTINES:
*
*         GETCLCK(N,0) == CLOCK(N)
*         GETCLCK(N,1) == DATE(N)
*         GETCLCK(N,2) == JDATE(N)
*         GETCLCK(N,3) == SECOND(N)
*
*         ANY OTHER VALUE OF K IS TAKEN MODULO 4.
          SPACE  4,10
 
 GCL1     SA1    X6          GET RETURN VALUE
          BX6    X1          INTO RESULT REGISTER
 
 GETCLCK  EQ     *+400000B   ENTRY/EXIT
          SA2    A1+1        GET SECOND ARGUMENT ADDRESS
          SA2    X2          GET SECOND ARGUMENT VALUE
          MX6    -2          MASK FOR 0-3
          BX2    -X6*X2
          SA2    GCL2+X2     GET TRANSFER VECTOR ENTRY
          SB2    X2
          JP     B2          GO TRANSFER TO REQUIRED ROUTINE
 
 GCL2     BSS    0           TRANSFER VECTOR
          LOC    0
          CON    CLOCK       0 = CLOCK
          CON    DATE        1 = DATE
          CON    JDATE       2 = JDATE
          CON    SECOND      3 = SECOND
          LOC    *O
 
 CLOCK    BSS    0
          CLOCK  X1
          EQ     GCL1        GO RETURN VALUE
 
 DATE     BSS    0
          DATE   X1
          EQ     GCL1        GO RETURN VALUE
 
 JDATE    BSS    0
          JDATE  X1
          EQ     GCL1        GO RETURN VALUE
 
 SECOND   BSS    0
          SYSTEM TIM,R,X1    READ CPU SECONDS WITH RECALL
          SA3    X6          RESULT LOCATION
          MX0    -12         MASK FOR MILLISECOND PART
          BX2    -X0*X3      EXTRACT MILLISECONDS
          PX4    B0,X2       CONVERT TO FLOATING POINT
          SA5    =1000.0     CONSTANT
          NX1    B0,X4       NORMALIZE MILLISECONDS
          FX7    X1/X5       MILLISECONDS / 1000.0
          MX0    -24         MASK FOR SECONDS PART
          AX3    12          SHIFT SECONDS
          BX2    -X0*X3      EXTRACT SECONDS
          PX4    B0,X2       CONVERT TO FLOATING POINT
          NX1    B0,X4       NORMALIZE SECONDS
          FX0    X7+X1       SECONDS + MILLISECONDS / 1000.0
          NX6    B0,X0       NORMALIZE RESULT
          SA6    A3          STORE RESULT
          EQ     GETCLCK     RETURN
 
          END
#-H- LLC.COM 1980 1979 1221 842
*DECK LLC
          IDENT  LLC
** LLC(C CHAR,A ADDR,I INTEGER) -- RETURN THE I-TH DISPLAY CODE
*   CHARACTER (ZERO-BASED) OFFSET FROM A AS ASCII VALUE
*
          ENTRY  LLC
 
          USE    /CMAP/
 INMAP    BSS    100B
 OUTMAP   BSS    200B
 
          USE    CODE.
 LLC      BSS    0
          BSSZ   1
 
          SB1    1B             SET B1 TO ALWAYS BE '1'
          SA5    A1+2B       CHAR OFFSET ADDR TO X5
          SX0    12B         CHARS/WORD (10)
          SA4    A1+B1       START ADDR TO X4
          PX7    B0,X0       NOW COMPUTE WORD TO ACCESS
          SA3    X5
          NX5    B0,X7
          SX6    6B          BITS/CHARACTER
          MX7    54
          PX2    B0,X3
          FX5    X2/X5
          UX2    B2,X5
          LX5    B2,X2
          DX2    X5*X0
          IX0    X4+X5
          SA5    X0
          IX0    X3-X2
          DX4    X0*X6
          SB2    X4-66B
          LX3    B2,X5       GET THE CHAR. FROM THAT WORD
          BX2    -X7*X3      EXTRACT 6-BIT CHARACTER
          ZR     X2,LLC2     IF POSSIBLY END-OF-LINE
 
 LLC1     SA4    X2+INMAP    MAP IT INTO INTERNAL CODE
          BX6    X4          AND STORE IT IN C AND
          SA6    X1          AND RETURN IT AS VALUE
          EQ     LLC
 
 LLC2     ZR     B2,LLC5     IF 9TH CHAR, TEST NEXT WORD
          NZ     X3,LLC3     IF NOT ALL ZEROS IN THIS WORD
          PL     X3,LLC4     IF NOT ALL SEMICOLONS
 
 LLC3     SB2    B2+66B      FOR END-OF-WORD MASK
          MX7    6
          AX7    B2,X7
          BX7    -X7*X5      CHECK REST OF WORD FOR ZEROS
          NZ     X7,LLC1     IF NOT END-OF-LINE
 
 LLC4     SX6    B0          RETURN END-OF-LINE FLAG AS RESULT
          SA6    X1          STORE IT IN  C
          EQ     LLC         AND RETURN
 
 LLC5     SA4    A5+1        CHECK NEXT WORD
          NZ     X4,LLC1     IF NOT END-OF-LINE
          PL     X4,LLC4     IF +0, NOW AT END-OF-LINE
          EQ     LLC1        10 SEMICOLONS, NOT EOL
 
          END
#-H- MESSAG.COM 972 1979 1221 842
*DECK MESSAGE
          IDENT  MESSAGE
          B1=1
          LIST   F
          TITLE  MESSAGE - SEND MESSAGE.
          COMMENT   SEND MESSAGE.
 MESSAGE  SPACE  4,10
***       MESSAGE - SEND MESSAGE.
*
*         CALL MESSAGE (TEXT,OPTION)
*
*         ENTRY  (TEXT) = MESSAGE ARRAY, TERMINATED BY ZERO BYTE
*                (OPTION) = 0, SEND MESSAGE TO SYSTEM DAYFILE,
*                              LOCAL JOB DAYFILE, AND A AND B DISPLAYS
*                         = 5HLOCAL, SEND MESSAGE TO LOCAL JOB DAYFILE
*                         = OTHER, SEND MESSAGE TO B-DISPLAY ONLY
 
 
%  ENTRY%MESSAGE
 MESSAGE  BSSZ%1
          SB1    1
          SA2    A1+1        ADDRESS OF OPTION
          SA2    X2          OPTION
          ZR,X2  MES1
          SA3    =0HLOCAL
          BX4    X2-X3
          ZR,X4  MES2        IF LOCAL
          MESSAGE X1,1,RCL
%  EQ%MESSAGE
 
 MES1     MESSAGE X1,,RCL
%  EQ%MESSAGE
 
 MES2     MESSAGE X1,3,RCL
%  EQ%MESSAGE
 
          END
#-H- PFNQQ.COM 521 1979 1221 842
*DECK PFNQQ
%  IDENT PFNQQ
* PFNQQ - ALL LEGAL OPERATIONS ON A PFN.
 
%ENTRY QQALTER
%ENTRY QQATTCH
%ENTRY QQCATLG
%ENTRY QQXTND
%ENTRY QQPERM
%ENTRY QQPURG
%ENTRY QQRENAM
 
QQALTER BSSZ%1
%SB1%1B
%ALTER%X1,RC
%EQ%QQALTER
 
QQATTCH%BSSZ%1
%SB1%1B
%ATTACH  X1,RC
%EQ%QQATTCH
 
QQCATLG%BSSZ%1
%SB1%1B
%CATALOG%X1,RC
%EQ%QQCATLG
 
QQXTND  BSSZ%1
%SB1%1B
%EXTEND  X1,RC
%EQ%QQXTND
 
QQPERM%BSSZ%1
%SB1%1B
%PERM%X1,RC
%EQ%QQPERM
 
QQPURG%BSSZ%1
%SB1%1B
%PURGE%X1,RC
%EQ%QQPURG
 
QQRENAM%BSSZ%1
%SB1%1B
%RENAME%X1,RC
%EQ%QQRENAM
 
%END
#-H- PUTCH.COM 1343 1979 1221 842
*DECK PUTCH
          IDENT PUTCH
* PUTCH(C,FD) -- WRITE CHAR C TO FILE FD
*
        ENTRY   PUTCH
 
*CALL IODEFS
 
        USE /CIOSYS/
FDTAB   BSS     MAXFILE                 # MAXFILE FILE OPEN AT ONCE
FBKTAB  BSS     FILBLK          # MAXFILE*80 (SIZE OF ONE FILE BLOCK)
 
        USE DATA.
ARGLIST BSS     2                       # FAKE ARGLIST FOR WRITEF=
 
        USE CODE.
 
PUTCH   BSSZ    1                       # WRITE C TO FD
 
        BX7     X1                      # ADDRESS OF C
        SB1     1B
        SA7     ARGLIST                 .. INTO FAKE ARGLIST
        SX6     B1                      # NUM. OF BYTES TO WRITE
        SA6     A7+B1                   .. INTO FAKE ARGLIST
        SA3     A1+B1                   # ADDR. OF FD INTO X3
        SA4     X3                      .. AND FD INTO X4
        SA5     X4+FDTAB                # POINTER TO FILE BLOCK
        SX0     X5-1B                   .. STORED IN X0 AS OFFSET
        SB6     B1                      # NUM. OF BYTES TO WRITE
        SA1     ARGLIST                 # POINT TO FAKE ARGLIST
        RJ      =XWRITEF=               # CALL WRITEF= TO DO WORK
        SA2     X1-1B                   # LOAD CHAR WRITTEN TO X2
        BX6     X2                      .. AND RETURN IT AS VALUE
        EQ      PUTCH                   # THEN GO HOME
          END
#-H- QQCLOS.COM 154 1979 1221 842
*DECK QQCLOSE
%  IDENT QQCLOSE
* QQCLOSE - CLOSE A FILE (DETTACHES PFNS)
 
%ENTRY QQCLOSE
 
QQCLOSE%BSSZ%1
%SB1%1B
%CLOSE%X1,RETURN,RECALL
%EQ%QQCLOSE
%END
#-H- QQLEN.COM 744 1979 1221 842
*DECK QQLEN
          IDENT QQLEN
*# QQLEN(S:STRING):INTEGER -- RETURN QQLEN OF S IN CHARACTERS
*
        ENTRY QQLEN
 
EOS     EQU     10002
 
QQLEN BSSZ    1               # ENTRY/EXIT
        SB1     1B
        SX5     EOS             .. EOS FLAG INTO X5
        SA2     X1              # FIRST CHAR. OF STRING INTO X2
        SX6     B0              # NUM. OF CHARS. IN STRING TO DATE.
LENLOOP BSS     0               # LOOP UNTIL HIT AN EOS
        BX3     X5-X2           .. CHECK FOR EOS USING XOR
        ZR      X3,QQLEN      .. AND RETURN IF DONE
        SX6     X6+B1           # ELSE HAVE ANOTHER CHAR.
        SA2     A2+B1           .. GET NEXT CHAR. OF STRING
        EQ      LENLOOP         # SEE IF STILL IN STRING
          END
#-H- QQRQPF.COM 293 1979 1221 842
*DECK QQRQPF
%  IDENT QQRQPF
* QQRQPF - REQUEST A LFN TO BE ON A PERMANENT FILE DEVICE
%ENTRY QQRQPF
 
%USE DATA.
LFN%BSSZ%1
%VFD%28/0,1/1,31/0
 
%USE CODE.
QQRQPF%BSSZ%1
%SB1%1B
%SA2%X1%# MOVE LFN NAME INTO DATA BLOCK
%BX6%X2
%SA6%LFN
%REQUEST%LFN%. PROCESS THE REQUEST FOR *PF
%EQ%QQRQPF
%END
#-H- QQSCPY.COM 1306 1979 1221 842
*DECK QQSCPY
          IDENT QQSCPY
** QQSCPY(ADDR1,OFFSET1,ADDR2,OFFSET2) -- COPY STRING STARTING AT
*       OFFSET1 OF ADDR1 (1-BASED) TO START OFFSET2 OF ADDR2
*
        ENTRY   QQSCPY
 
EOS     EQU     10002
 
QQSCPY    BSSZ    1
        SB1     1B
        SX5     EOS             # EOS FLAG INTO X5
        SB2     X1-1B           # BASE ADDR1 INTO B2
        SA2     A1+B1           .. AND OFFSET1
        SA4     X2              .. INTO X4, THEN
        SB2     X4+B2           .. STARTING ADDRESS INTO B2
        SA3     A2+B1           # BASE ADDR2 INTO X3
        SB7     X3-1B           .. MOVE INTO B7
        SA4     A3+B1           .. AND OFFSET2
        SA4     X4              .. INTO X4, THEN
        SB7     X4+B7           .. NEW ADDRESS INTO B7
 
SCPLOOP BSS     0               # LOOP UNTIL HIT AN EOS
        SA2     B2              .. GET CHAR. FROM FIRST STRING
        SB2     B2+B1           .. AND POINT TO NEXT CHAR.
        BX7     X2              # MOVE INTO OUTPUT REGISTER
        SA7     B7              .. AND STORE INTO SECOND STRING
        SB7     B7+B1           .. AND POINT TO NEXT CHAR. IN IT.
        BX4     X7-X5           # CHECK FOR EOS
        NZ      X4,SCPLOOP      .. AND LOOP IF NOT FOUND
        EQ      QQSCPY            # HAVE EOS, GO HOME.
          END
#-H- READF.COM 1076 1979 1221 842
*DECK READF
          IDENT READF
*  READF(BUF,N,FD) -- READ N BYTES FROM FILE FD INTO BUF
*       RETURNS NUMBER OF BYTES READ, OR EOF OR ERR AS
*       VALUE OF FUNCTION, AND EOF AS VALUE OF FIRST SLOT IN
*       USER BUFFER IF NO CHARACTERS READ.
 
        ENTRY READF
 
*CALL IODEFS                   # GET THE DEFINES AND MACRO DEFS
 
        USE /CIOSYS/            # FILE TABLE AND FILE BLOCKS
FDTAB   BSS     MAXFILE          .. UPTO MAXFILE FILES OPEN AT ONCE
FBKTAB  BSS     FILBLK        .. MAXFILE * 80 (SIZE OF ONE FILE BLOCK)
 
        USE CODE.
READF   BSSZ    1               # READ N BYTES INTO BUF FROM FD
        SB1     1B
        GETARGS
        EQ      B0,B6,READF      .. GO HOME IF REQUEST IS EMPTY
        RJ      =XREADF=         .. AND CALL READF= TO DO WORK
        SB7     X6              # SEE IF 0 BYTES READ
        NE      B0,B7,READF      .. AND IF NOT, GO HOME
        SX6     EOF             # ELSE ASSUME EOF
        SA6     X1               .. RETURN IN FIRST BUFFER SLOT.
        EQ      READF           # GO HOME WITH RESULTS
          END
#-H- READX.COM 13914 1979 1221 842
*DECK READFX
          IDENT  READF=
          ENTRY  READF=
***READF= -- READ N BYTES FROM FILE FD INTO BUF
*       RETURNS NUMBER OF BYTES READ, OR EOF OR ERR AS
*       VALUE OF FUNCTION, RESETS N IF <N BYTES READ
*       ASSUMES BUF,N,FD ARE IN PROPER REGISTER BEFORE CALLING
*       AND A1 IS POINTER TO ADDRESSES OF SAME
*
*         ENTRY  (X1) = ADDRESS OF SOURCE BUFFER
*                (B6) = NUMBER OF BUTES TO MOVE
*                (X6) = (B6)
*                (X0) = BASE POINTER FOR FILE BLOCK
*
*         ENTRY  (X6) = NUMBER OF BYTES READ, IF OK
*                     = EOF ON END-OF-FILE
*                     = ERR ON ERROR
 
 
*CALL IODEFS
 
*  LOADBUF -- LOAD INPUT BUFFER USING PREVIOUSLY DEFINED MACROS
 
 LOADBUF  MACRO
          EOFCHK             SEE IF EOF ON LAST READ
          CLRBUF             CLEAR THE BUFFER POINTERS
          SAVLIST            SAVE ARG LIST POINTERS
          RDPRU              ISSUE READ AND WAIT UNTIL DONE
          GETLIST            RESTORE ARG LIST POINTERS
          READCHK            AND CHECK READ FOR PROBLEMS
          ENDM               END OF MACRO LOADBUF
 
          USE    /CMAP/      MAP COMMON
 INMAP    BSS    64           . DISPLAY CODE TO ASCII
 OUTMAP   BSS    128         . ASCII TO DISPLAY CODE
 
          USE    /CMAPX/     MAP COMMON FOR EXTENDED CHARACTER SET
 INMAPX   BSS    0           . EXTENDED DISPLAY CODE TO ASCII
          CON    0#3A
          CON    0#41        UPPER CASE A
          CON    0#42        UPPER CASE B
          CON    0#43        UPPER CASE C
          CON    0#44        UPPER CASE D
          CON    0#45        UPPER CASE E
          CON    0#46        UPPER CASE F
          CON    0#47        UPPER CASE G
          CON    0#48        UPPER CASE H
          CON    0#49        UPPER CASE I
          CON    0#4A        UPPER CASE J
          CON    0#4B        UPPER CASE K
          CON    0#4C        UPPER CASE L
          CON    0#4D        UPPER CASE M
          CON    0#4E        UPPER CASE N
          CON    0#4F        UPPER CASE O
          CON    0#50        UPPER CASE P
          CON    0#51        UPPER CASE Q
          CON    0#52        UPPER CASE R
          CON    0#53        UPPER CASE S
          CON    0#54        UPPER CASE T
          CON    0#55        UPPER CASE U
          CON    0#56        UPPER CASE V
          CON    0#57        UPPER CASE W
          CON    0#58        UPPER CASE X
          CON    0#59        UPPER CASE Y
          CON    0#5A        UPPER CASE Z
          CON    0#30        0
          CON    0#31        1
          CON    0#32        2
          CON    0#33        3
          CON    0#34        4
          CON    0#35        5
          CON    0#36        6
          CON    0#37        7
          CON    0#38        8
          CON    0#39        9
          CON    0#2B        +
          CON    0#2D        -
          CON    0#2A        *
          CON    0#2F        /
          CON    0#28        (
          CON    0#29        )
          CON    0#24        $
          CON    0#3D        =
          CON    0#20        SPACE
          CON    0#2C        ,
          CON    0#2E        .
          CON    0#23        #
          CON    0#5B        [
          CON    0#5D        ]
          CON    0#25        :
          CON    0#22        "
          CON    0#5F        _
          CON    0#21        !
          CON    0#26        &
          CON    0#27        '
          CON    0#3F        ?
          CON    0#3C        <
          CON    0#3E        >
          CON    1L5+INMX74-INMAPX  ESCAPE CODE 74B
          CON    0#5C        \
          CON    1L5+INMX76-INMAPX  ESCAPE CODE 76B
          CON    0#3B        ;
 
 INMX76   BSS    0           76B-EXCAPE CHARACTERS
          CON    0#60        GRAVE ACCENT
          CON    0#61        LOWER CASE A
          CON    0#62        LOWER CASE B
          CON    0#63        LOWER CASE C
          CON    0#64        LOWER CASE D
          CON    0#65        LOWER CASE E
          CON    0#66        LOWER CASE F
          CON    0#67        LOWER CASE G
          CON    0#68        LOWER CASE H
          CON    0#69        LOWER CASE I
          CON    0#6A        LOWER CASE J
          CON    0#6B        LOWER CASE K
          CON    0#6C        LOWER CASE L
          CON    0#6D        LOWER CASE M
          CON    0#6E        LOWER CASE N
          CON    0#6F        LOWER CASE O
          CON    0#70        LOWER CASE P
          CON    0#71        LOWER CASE Q
          CON    0#72        LOWER CASE R
          CON    0#73        LOWER CASE S
          CON    0#74        LOWER CASE T
          CON    0#75        LOWER CASE U
          CON    0#76        LOWER CASE V
          CON    0#77        LOWER CASE W
          CON    0#78        LOWER CASE X
          CON    0#79        LOWER CASE Y
          CON    0#7A        LOWER CASE Z
          CON    0#7B        OPENING BRACE
          CON    0#7C        VERTICAL LINE
          CON    0#7D        CLOSING BRACE
          CON    0#7E        TILDE
          CON    0#7F        CONTROL DEL
          CON    0#00        CONTROL NUL
          CON    0#01        CONTROL SOH
          CON    0#02        CONTROL STX
          CON    0#03        CONTROL ETX
          CON    0#04        CONTROL EOT
          CON    0#05        CONTROL ENQ
          CON    0#06        CONTROL ACK
          CON    0#07        CONTROL BEL
          CON    0#08        CONTROL BS
          CON    0#09        CONTROL HT
          CON    0#0A        CONTROL LF
          CON    0#0B        CONTROL VT
          CON    0#0C        CONTROL FF
          CON    0#0D        CONTROL CR
          CON    0#0E        CONTROL SO
          CON    0#0F        CONTROL SI
          CON    0#10        CONTROL DLE
          CON    0#11        CONTROL DC1
          CON    0#12        CONTROL DC2
          CON    0#13        CONTROL DC3
          CON    0#14        CONTROL DC4
          CON    0#15        CONTROL NAK
          CON    0#16        CONTROL SYN
          CON    0#17        CONTROL ETB
          CON    0#18        CONTROL CAN
          CON    0#19        CONTROL EM
          CON    0#1A        CONTROL SUB
          CON    0#1B        CONTROL ESC
          CON    0#1C        CONTROL FS
          CON    0#1D        CONTROL GS
          CON    0#1E        CONTROL RS
          CON    0#1F        CONTROL US
 INMX74   BSS    0           74B-ESCAPE CHARACTERS
          CON    0#20        NULL
          CON    0#40        @
          CON    0#5E        ^
          CON    0#20        NULL
          CON    0#3A
          CON    0#20        NULL
          CON    0#20        NULL
          CON    0#60        GRAVE ACCENT (REVERSE QUOTE)
          DUP    64D-8
          CON    0#20        NULL
          ENDD
 
 OUTMAPX  BSS    128         . ASCII TO EXTENDED DISPLAY CODE
 
          USE    /CIOSYS/    FILE TABLE AND FILE BLOCKS
 FDTAB    BSS    MAXFILE          . UPTO 16 FILES OPEN AT ONCE
 FBKTAB   BSS    FILBLK        . 16 * (SIZE OF ONE FILE BLOCK)
 
          USE    DATA.
 
 RDDSPSW  CON    *-*         MAPPING SWITCH
 RDDSPFL  CON    *-*         PREVIOUS CHARACTER FLAG
 
          USE    CODE.
 READF=   BSSZ   1           READ N BYTES
 
          GETPARS            GET FILE DEPENDENT INFO.
          SA5    X0+MAPFLAG  CHECK MAPPING REQUIREMENTS
          ZR     X5,RDLOOP   IF NO MAPPING
          PL     X5,RDDSP1   IF DISPLAY CODE
 
 RDLOOP   BSS    0           LOOP UNTIL REQUEST SATISFIED
          GE     B0,B6,RDDONE (BREAK ON 0 BYTES LEFT IN REQUEST)
          GE     B3,B2,READBUF (BRANCH TO FILL BUFFER IF NEEDED)
 
          SB7    B3+BUFSTRT  GET CURRENT WORD OF I/O BUFFER
          SA2    X0+B7       . INTO X2
          NE     B1,B5,RDBYTE SKIP IF NOT WORD I/O
          READWRD            .. ELSE READ WHOLE WORD
          EQ     RDLOOP      .AND SEE IF MORE TO DO.
 
 RDBYTE   BSS    0           READ ONE BYTE
          SA5    X0+BTSPBYT  GET BITS PER BYTE
          SB7    X5-1        BITS PER BYTE - 1
          SX4    B4          MOVE BYTE POINTER INTO X4
          IX3    X4*X5       COMPUTE ROTATE TO LEFT-JUSTIFY BYTE
          MX4    1           BUILD SINGLE BYTE MASK
          AX4    B7          . THE HARD WAY [CURSE CDC]
 
          SB7    X3          MOVE ROTATE COUNT TO B7
          LX7    B7,X2       LEFT-JUSTIFY BYTE
          BX7    X4*X7       . AND MASK IT OUT OF WORD
          SB7    X5          . AND ROTATE
          LX7    B7          . SO IT IS RIGHT-JUSTIFIED
          SA5    X0+MAPFLAG  CHECK MAPPING REQUIREMENTS
          ZR     X5,NOMAP    SKIP IF NO NEED TO MAP
          ZR     X7,NLCHK    SKIP IF MIGHT BE NEW LINE (0 BYTE)
          EQ     NOMAP       THEN BRANCH TO STORE BYTE
 NXTBYTE  BSS    0           IGNORE THE CURRENT BYTE
          SB4    B4+B1       .
          LT     B4,B5,RDLOOP STILL IN SAME WORD
          SB4    B0          MUST GET NEXT WORD
          SB3    B3+B1
          EQ     RDLOOP
 NLCHK    BSS    0           POSSIBLE ASCII NEWLINE
          SB7    B5-B1       . BUT ONLY IF AT LAST BYTE
          NE     B4,B7,NXTBYTE IF NOT, BRANCH TO IGNORE NULL CHAR.
          SX7    NEWLINE     . IF SO, RETURN NEWLINE
          SB4    B5          . POINT OFF END OF WORD
 NOMAP    BSS    0           STORE THE BYTE
          SA7    X1          . INTO USER BUFFER
          SX1    X1+B1       . UPDATE USER BUFFER POINTER
          SB4    B4+B1       . INCREMENT CURRENT BYTE POINTER
          LT     B4,B5,SAMWRD SKIP IF STILL IN CURRENT WORD
          SB4    B0          . RESET BYTE POINTER
          SB3    B3+B1       . INCREMENT CURRENT WORD POINTER
 SAMWRD   SB6    B6-B1       DECREMENT BYTES LEFT IN REQUEST
          EQ     RDLOOP      AND SEE IF MORE TO DO.
 
 READBUF  BSS    0           FILL I/O BUFFER FROM FILE
          LOADBUF            LOAD INPUT BUFFER
          EQ     RDLOOP      IF NONE, GO BACK TO START OF LOOP
 
 RDDONE   BSS    0           RETURN FROM READ
          SAVPARS            .. BY SAVING WHAT MIGHT HAVE CHANGED
          EQ     READF=      . AND GOING HOME
 
**        MOVE DISPLAY CODE CHARACTERS FROM BUFFER
 
 RDDSP1   SX7    X5-1        SET STANDARD/EXTENDED MODE SWITCH
          SA7    RDDSPSW     SAVE SWITCH
          SX5    X7          INITIAL VALUE
          SX7    B0
          SA7    RDDSPFL     CLEAR PREVIOUS CHAR EXTENDED FLAG
 
 RDDSP2   GE     B0,B6,RDDONE IF REQUEST SATISFIED WITH ENOUGH CHAR
          LT     B3,B2,RDDSP3 IF WORD IS IN BUFFER
          LOADBUF            LOAD INPUT BUFFER
          SA5    RDDSPSW     RELOAD STANDARD/EXTENDED SWITCH
 
 RDDSP3   SB7    B3+BUFSTRT  GET WORD FROM BUFFER
          SA2    X0+B7
          NZ     X2,RDDSP5   IF NOT EOL
          NG     X2,RDDSP5   IF TEN SEMICOLONS
 
 RDDSP4   SX7    NEWLINE     ON EOL, RETURN VALUE
          SB4    B5          INDICATE DONE WITH WORD
          EQ     RDDSP7      GO STORE EOL CHARACTER
 
 RDDSP5   SX3    B4+B4       PREPARE SHIFT #BYTE*2
          IX4    X3+X3              *4
          IX3    X3+X4              *6
          SB7    X3+6        ROTATE COUNT
          MX7    -6          ONE CHARACTER MASK
          LX3    B7,X2       ROTATE CHARACTER
          BX7    -X7*X3      EXTRACT CHARACTER
          NZ     X7,RDDSP6   IF NOT ZERO (COLON OR EOL)
          EQ     B4,B0,RDDSP6 MUST BE COLON IN FIRST CHAR POSITION
          SX3    B4-9        CHECK FOR LAST CHARACTER OF WORD
          ZR     X3,RDDSP9   IF LAST CHARACTER OF WORD, PEEK AT NEXT
          MX3    1           FORM MASK TO CHECK REST OF WORD
          SB7    B7-B1
          AX3    B7,X3
          BX3    -X3*X2      CHECK REST OF WORD
          ZR     X3,RDDSP4   EOL FOUND
 
 RDDSP6   NZ     X5,RDDSP12  IF EXTENDED CHARACTER SET
          SA3    X7+INMAP    GET CHARACTER TRANSLATION
          BX7    X3
 
 RDDSP7   SA7    X1          STORE CHARACTER IN BUFFER
          SX1    X1+B1       INCREMENT BUFFER POINTER
          SB4    B4+B1       BYTE NUMBER
          SB6    B6-B1       REMAINING CHARACTER COUNT
          LT     B4,B5,RDDSP8 IF STILL IN SAME WORD
          SB4    B0          SET FOR NEXT WORD
          SB3    B3+B1
          EQ     RDDSP2      GO PROCESS NEW WORD
 
 RDDSP8   GE     B0,B6,RDDONE IN WORD, IF DONE, GO EXIT
          EQ     RDDSP5      ELSE GO GET NEXT CHAR FROM WORD
 
 RDDSP9   SB7    B3+B1       PEEK AT NEXT WORD
          LT     B7,B2,RDDSP10 IF WORD IS IN BUFFER
          LOADBUF            MUST RELOAD INPUT BUFFER
          SA5    RDDSPSW     RELOAD STANDARD/EXTENDED SWITCH
          SX7    B0          RELOAD ZERO CHARACTER
          SB7    B3+BUFSTRT  GET WORD FROM BUFFER
          SA3    X0+B7
          SB3    B3-B1       BACK UP POINTERS
          SB4    B5
          EQ     RDDSP11     GO PEEK AT WORD
 
 RDDSP10  SA3    A2+B1       GET NEXT WORD
 
 RDDSP11  NZ     X3,RDDSP6   NEXT WORD NOT EOL, INSERT COLON
          NG     X3,RDDSP6   IF ALL SEMICOLONS
          SB4    B0          SET TO IGNORE NULL, NEXT WORD IS EOL
          SB3    B3+B1
          EQ     RDDSP2      GO GET EOL WORD
 
 RDDSP12  SA3    RDDSPFL     CHECK FOR PREVIOUS FLAG
          NZ     X3,RDDSP14  IF 74B OR 76B WAS JUST READ
          SA3    X7+INMAPX   GET EXTENDED MAPPING
          NG     X3,RDDSP13  IF 74B OR 76B
          BX7    X3          OTHERWISE TREAT AS STANDARD CHARACTER
          EQ     RDDSP7      GO STORE IT
 
 RDDSP13  SX7    X3          STORE FLAG (WHICH IS TABLE OFFSET)
          SA7    RDDSPFL
          SB4    B4+B1       UPDATE BYTE NUMBER
          LT     B4,B5,RDDSP5  IF STILL IN SAME WORD
          SB4    B0          SET FOR NEXT WORD
          SB3    B3+B1
          EQ     RDDSP2      GO BACK FOR NEXT CHARACTER
 
 RDDSP14  IX3    X3+X7       ADD FLAG OFFSET TO CHAR
          MX7    0           CLEAR FLAG
          SA7    RDDSPFL
          SA3    X3+INMAPX   GET EXTENDED MAPPING
          BX7    X3
          EQ     RDDSP7      GO STORE IT
 
          END
#-H- RECALL.COM 214 1979 1221 842
*DECK RECALL
          IDENT RECALL
* RECALL -- WAITS FOR I/O TO COMPLETE
*
          ENTRY RECALL
RECALL    BSS   0
          BSSZ  1
          BX2   X1
          RJ    =XWNB=
          EQ    RECALL
          END
#-H- REMOVQ.COM 450 1979 1221 842
*DECK,REMOVQQ
          IDENT  REMOVQQ
          TITLE  REMOVQQ     RETURN FILE FOR REMOVE SUBR.
 
          ENTRY  REMOVQQ
 
** CALL REMOVQQ(LFN)
 REMOVQQ  PS     ,           ENTRY/EXIT
          SA1    X1          FORM FET HEADER
          SX6    1
          BX6    X6+X1
          SA6    FET         STORE IN DUMMY FET
%  RETURN FET,R
          EQ     REMOVQQ     EXIT
 
 FET      FILEB  CBUF,65         DUMMY FET
 CBUF%  BSSZ% 65
 
          END
#-H- REWIND.COM 364 1979 1221 842
*DECK REWIND
          IDENT  REWIND
          B1=1
          TITLE  REWIND - REWIND FILE.
          COMMENT   REWIND FILE.
 REWIND   SPACE  4,10
***       REWIND - REWIND FILE.
*
*         CALL REWIND (FILE)
*
*         ENTRY  (FILE) = FIRST WORD OF THE FET
 
 
%  ENTRY REWIND
 REWIND   BSSZ%1
          SB1    1
          REWIND X1
%  EQ%REWIND
 
          END
#-H- RTC.COM 2463 1979 1221 842
*DECK RTC
          IDENT CPU.RTC
        ENTRY   RTC>
 
***       RTC - REPLACE TRAILING CHARACTERS.
*
*         R. O. ANDERSON,
*         M. D. OLSON.       75/12/09.
*
*         RTC REPLACES ALL OCCURRENCES OF ONE CHARACTER AT THE END
*         OF A STRING WITH ANOTHER CHARACTER.
***       ENTRY  (A1) = FWA OF STRING.
*                (B1) = 1.
*                (B2) = LENGTH OF STRING, IN WORDS.
*                (X2) = TEN OCCURRENCES OF SEARCH CHARACTER.
*                (X3) = TEN OCCURRENCES OF REPLACEMENT CHARACTER.
*
*         EXIT   STRING MODIFIED IN PLACE.
*                (X6) = ADDRESS OF LAST WORD MODIFIED.
*                (X7) = NUMBER OF CHARACTERS CHANGED IN THAT WORD.
*
*         USES   X - 1, 4, 6, 7.
*                B - NONE.
*                A - 1, 4, 6.
 
 
 RTC1     SA1    A1-B1       GET THE NEXT WORD; 47 55 77 55 55
          BX4    X1-X2       ASSUME X2 = SPACES; 12 00 22 00 00
          MX6    -1          77 77 77 77 76
          IX6    X4+X6       12 00 21 77 77
          BX6    X6+X4       12 00 23 77 77
          BX6    X6-X4       00 00 01 77 77
          SA4    RTCA        40 40 40 40 40
          BX6    X6*X4       00 00 00 40 40
          CX7    X6          FIND OUT HOW MANY CHARS WE ZAPPED
          ZR     X6,RTC2     IF NO MORE TRAILING CHARACTERS
          LX6    -5          00 00 00 01 01
          BX4    X6          00 00 00 01 01
          LX4    6           00 00 01 01 00
          IX4    X6-X4       77 77 77 00 00
          BX6    X4*X1       X6 = C(X1) WITH TRAILING C(X2) GONE
          BX4    -X4*X3      X4 = C(X3) WITH ONLY TRAILING CHARS
          BX6    X6+X4       X6 = C(X1) WITH TRAILING C(X2)
          SA6    A1          REPLACED BY C(X3)
          SB2    B2-B1       DECREMENT COUNTER
          SX6    X7-10       SEE IF TEN CHARACTERS ZAPPED
          NZ     X6,RTC2     IF NOT, WE ARE DONE
          GT     B2,RTC1     LOOP TILL DONE
 RTC2     SX6    A1          X6 = ADDRESS OF LAST WORD LOOKED AT
          SA1    RTCB        RESTORE
          SB2    X1          WORD LENGTH
 RTC>     BSSZ   1               ENTRY/EXIT
          SB1    1
          SX6    B2          SAVE THE FWA
          SA6    RTCB        OF THE OUTPUT AREA
          SA1    A1+B2       POINT TO END OF STRING + 1 WORD
          EQ     RTC1        TO START CRUNCHING
 
 RTCA     DATA   40404040404040404040B   CONSTANT FOR MASK GENERATION
 
 RTCB     DATA   0           TO SAVE OUTPUT AREA FWA
 
          END
#-H- SETB.COM 1192 1979 1221 842
*DECK SETB
          IDENT SETB
** SETB(A:ADDR,I:INTEGER) -- SET THE I-TH BIT (ZERO-BASED) OFFSET
*   FROM A, RETURN BIT'S PREVIOUS VALUE AS VALUE OF FUNCTION.
*
        ENTRY SETB
 
SETB    BSS     0
        BSSZ    1
 
        SB1     1B
        SA5     A1+1B           # X5 IS BIT POSITION TO TEST
        SX0     74B             # BITS/WORD
        PX7     B0,X0           # NOW COMPUTE WORD HOLDING BIT
        SA3     X5
        NX5     B0,X7
        PX7     B0,X3
        FX2     X7/X5           # X2 IS I/60 (INTEGER WORD OFFSET)
        UX7     B2,X2
        LX5     B2,X7
        DX7     X5*X0
        IX2     X1+X5
        SA4     X2              # GET THAT WORD FROM MEMORY
        IX0     X3-X7           # X0 IS MOD(I,60) NOW
        SB2     X0+B1           # FIND BIT IN WORD
        SX3     B1              # ONE BIT MASK
        LX5     B2,X4            . AND ROTATE SO IT IS RIGHT MOST
        BX6     X5*X3           # MASK OFF BIT AND RETURN IT'S VALUE
        BX5     X5+X3           # SET THE BIT
        SB2     X0-73B           . AND ROTATE WORD BACK
        AX7     B2,X5
        SA7     A4               . AND STORE BACK INTO MEMORY
        EQ      SETB
          END
#-H- SYSLIB.COM 442 1979 1221 842
*DECK SYSLIB
          IDENT SYSLIB
        SYSCOM
        ENTRY CDD=
        ENTRY WOD=
        ENTRY WTW=
        ENTRY DCB=
        ENTRY WTX=
        ENTRY WTC=
        ENTRY CIO=
        ENTRY SYS=
        ENTRY RCL=
        ENTRY MSG=
        ENTRY WNB=
        PURGMAC CODE
CODE    OPSYN   NIL
*CALL COMCCDD
*CALL COMCWOD
*CALL COMCWTW
*CALL COMCWTC
*CALL COMCCIO
*CALL COMCSYS
 
CDD     EQU     CDD=
WOD     EQU     WOD=
          END
#-H- TSTB.COM 841 1979 1221 842
*DECK TSTB
          IDENT TSTB
** TSTB(A:ADDR,I:INTEGER) -- RETURN THE I-TH BIT (ZERO-BASED) OFFSET
*   FROM A AS THE VALUE OF THE FUCTIONN
*
        ENTRY TSTB
 
TSTB    BSS     0
        BSSZ    1
 
        SB1     1B
        SA5     A1+1B           # X5 IS BIT POSITION TO TEST
        SX0     74B             # BITS/WORD
        PX7     B0,X0           # NOW COMPUTE WORD HOLDING BIT
        SX6     B1
        SA3     X5
        NX5     B0,X7
        PX7     B0,X3
        FX2     X7/X5
        UX7     B2,X2
        LX5     B2,X7
        DX7     X5*X0
        IX2     X1+X5
        SA4     X2
        IX0     X3-X7
        SB2     X0-73B          # FIND BIT IN WORD
        LX5     B2,X4            . AND ROTATE SO IT IS RIGHT MOST
        BX6     X5*X6           # MASK OFF BIT AND RETURN IT'S VALUE
        EQ      TSTB
          END
#-H- WRITEF.COM 2254 1979 1221 843
*DECK WRITEF
          IDENT WRITEF
* WRITEF(BUF,N,FD) -- WRITE N BYTES FROM BUF TO FILE FD
*       RETURNS NUMBER OF BYTES WRITTEN
 
        ENTRY   WRITEF
 
*CALL IODEFS                   # GET THE DEFINES AND MACRO DEFS
 
        USE /CMAP/
INMAP   BSS     64
OUTMAP  BSS     128
 
        USE /CIOSYS/
FDTAB   BSS     MAXFILE              # UP TO MAXFILE FILES OPEN AT ONCE
FBKTAB  BSS     FILBLK       # MAXFILE * 80(SIZE OF ONE FILE BLOCK)
 
        USE DATA.
BUFFER  BSS     256             # BUFFER IF NEED TO UNPACK INBUF
 
        USE CODE.
WRITEF  BSSZ    1               # WRITE N BYTES FROM BUF TO FILE FD
        SB1     1B
        GETARGS
        GETBPB
        SB2     55              # IF BITS/BYTE > 54, THEN MUST
        GE      B7,B2,UNPACKD   .. ASSUME UNPACKED USER BUFFER
        MX4     6               # BUILD DISPLAY CODE MASK IN X4
        SA3     X1              # GET FIRST WORD OF USER BUFFER
        BX7     X3*X4           .. AND MASK OFF LEFT 6 BITS
        ZR      X7,UNPACKD      .. AND ASSUME UNPACKED IF ALL 0
        SB3     10              # 10 BYTES/DISPLAY CODE WORD
        LX4     6               # RIGHT JUSTIFY BYTE MASK
        SB4     B0              # INITIAL LOOP CONTROL
        SB5     B0              .. REGISTERS
        SB2     BUFFER          .. AND POINTER TO START OF TMP BUF.
 
UNPKLP  BSS     0               # LOOP UNTIL DONE
        GE      B5,B6,UNPDONE   .. BREAKING WHEN HAVE N BYTES
        LT      B4,B3,NXTBYTE   # SKIP IF STILL IN SAME WORD
        SB4     B0
        SA3     A3+B1           .. ELSE GET NEXT WORD
NXTBYTE LX3     6               # ROTATE WORD 1 BYTE
        BX2     X3*X4           .. AND MASK OFF BYTE ON RIGHT
        SA2     X2+INMAP        # MASK TO INTERNAL ASCII
        BX7     X2              .. MOVE TO OUTPUT REGISTER
        SA7     B2+B5           .. AND STORE INTO TMP BUFFER
        SB5     B5+B1
        SB4     B4+B1           # INCREMENT COUNTERS
        EQ      UNPKLP          .. AND SEE IF MORE TO DO
 
UNPDONE BSS     0               # POINT TO NEW BUFFER LOCATION
        SX1     BUFFER          .. SO WRITEF= IS FOOLED INTO WORKING
 
UNPACKD BSS     0
        RJ      =XWRITEF=       # AND CALL WRITEF= TO DO THE WORK
        EQ      WRITEF
          END
#-H- WRITER.COM 590 1979 1221 843
*DECK WRITER
          IDENT  WRITER
%  ENTRY  WRITER
          B1=1
          TITLE  WRITER - WRITE END OF RECORD.
          COMMENT   WRITE END OF RECORD.
 WRITER   SPACE  4,10
***       WRITER - WRITE END OF RECORD.
*
*         CALL WRITER (FILE,LEVEL)
*
*         ENTRY  (FILE) = FIRST WORD OF THE FET
*                (LEVEL) = RECORD LEVEL
 
 
 WRITER   BSSZ%1
          SB1    1
          SA3    A1+B1       ADDRESS OF LEVEL
          SA3    X3          LEVEL
%  SX3% X3-17B%%CHECK FOR EOF
%  ZR% X3,WEOR1
%  WRITER X1
%  EQ%WRITER
 
 WEOR1%  BSS% 0
%  WRITEF X1
%  EQ%WRITER
 
%  END
#-H- WRITEX.COM 12811 1979 1221 843
*DECK WRITEFX
          IDENT  WRITEF=
          ENTRY  WRITEF=
*** WRITEF=(BUF,N,FD) -- WRITE N BYTES FROM BUF TO FILE FD
*       RETURNS NUMBER OF BYTES WRITTEN
*
*         ENTRY  (X1) = START OF DATA BUFFER
*                (B6) = NUMBER OF BYTES TO WRITE
*                (X6) = (B6)
*                (X0) = BASE POINTER FOR FILE BLOCK
*
*         EXIT   (X6) = NUMBER OF BYTES WRITTEN
 
 
*CALL IODEFS
 
*  EXTCH -- DEFINE ONE EXTENDED CHARACTER SET CHARACTER
 
 EXTCH    MACRO  C1,C2
          IFC    EQ,/C1//
          CON    C2
          ELSE
          VFD    1/1,23/0,18/C1,18/C2
          ENDIF
          ENDM               END OF MACRO EXTCH
 
          USE    /CMAP/      MAP COMMON
 INMAP    BSS    64          . DISPLAY CODE TO ASCII
 OUTMAP   BSS    128           . ASCII TO DISPLAY CODE
 
          USE    /CMAPX/     MAP COMMON FOR EXTENDED CHARACTER SET
 INMAPX   BSS    3*64        . EXTENDED DISPLAY CODE TO ASCII
 OUTMAPX  BSS    0           . ASCII TO EXTENDED DISPLAY CODE
          DUP    32
          EXTCH  76B,40B+*-OUTMAPX
          ENDD
 
          CON    1R
          CON    1R!
          CON    1R"
          CON    1R#
          CON    1R$
          CON    1R:
          CON    1R&
          CON    1R'
          CON    1R(
          CON    1R)
          CON    1R*
          CON    1R+
          CON    1R,
          CON    1R-
          CON    1R.
          CON    1R/
 
          CON    1R0
          CON    1R1
          CON    1R2
          CON    1R3
          CON    1R4
          CON    1R5
          CON    1R6
          CON    1R7
          CON    1R8
          CON    1R9
          EXTCH  74B,04B
          CON    1R;
          CON    1R<
          CON    1R=
          CON    1R>
          CON    1R?
 
          EXTCH  74B,01B     @
          CON    1RA
          CON    1RB
          CON    1RC
          CON    1RD
          CON    1RE
          CON    1RF
          CON    1RG
          CON    1RH
          CON    1RI
          CON    1RJ
          CON    1RK
          CON    1RL
          CON    1RM
          CON    1RN
          CON    1RO
 
          CON    1RP
          CON    1RQ
          CON    1RR
          CON    1RS
          CON    1RT
          CON    1RU
          CON    1RV
          CON    1RW
          CON    1RX
          CON    1RY
          CON    1RZ
          CON    1R[
          CON    1R\
          CON    1R]
          EXTCH  74B,02B     ^
          CON    65B         UNDERSCORE (COMPASS PROBLEM)
 
          EXTCH  74B,07B     GRAVE ACCENT
          EXTCH  76B,1RA     LOWER CASE LETTERS
          EXTCH  76B,1RB
          EXTCH  76B,1RC
          EXTCH  76B,1RD
          EXTCH  76B,1RE
          EXTCH  76B,1RF
          EXTCH  76B,1RG
          EXTCH  76B,1RH
          EXTCH  76B,1RI
          EXTCH  76B,1RJ
          EXTCH  76B,1RK
          EXTCH  76B,1RL
          EXTCH  76B,1RM
          EXTCH  76B,1RN
          EXTCH  76B,1RO
 
          EXTCH  76B,1RP
          EXTCH  76B,1RQ
          EXTCH  76B,1RR
          EXTCH  76B,1RS
          EXTCH  76B,1RT
          EXTCH  76B,1RU
          EXTCH  76B,1RV
          EXTCH  76B,1RW
          EXTCH  76B,1RX
          EXTCH  76B,1RY
          EXTCH  76B,1RZ
          EXTCH  76B,33B     OPENING BRACE
          EXTCH  76B,34B     VERTICAL STROKE
          EXTCH  76B,35B     CLOSING BRACE
          EXTCH  76B,36B     TILDE
          EXTCH  76B,37B     CONTROL DEL
 
          USE    /CIOSYS/    FILE TABLE AND FILE BLOCKS
 FDTAB    BSS    MAXFILE          . UPTO 16 FILES OPEN AT ONCE
 FBKTAB   BSS    FILBLK        . 16 * (SIZE OF ONE FILE BLOCK)
 
          USE    DATA.       LOCAL DATA
 AEOLWRD  DATA   00400040004000400000B ASCII WORD FOR EOL
 WRTNRCH  CON    *-*         NUMBER OF CHARACTERS TRANSMITTED
 WRDSPSW  CON    *-*         DISPLAY CODE NORMAL/EXTENDED SWITCH
 
          USE    CODE.
 WRITEF=  BSSZ   1           WRITE N BYTES FROM BUF TO FD
 
          GETPARS            GET FILE DEPENDENT INFO
          SA6    WRTNRCH     STORE CHARACTER COUNT
          SA5    X0+MAPFLAG  CHECK MAPPING FLAG
          ZR     X5,WRTLOOP  IF NO MAPPING
          PL     X5,WRDSP1   IF DISPLAY CODE
 
 WRTLOOP  BSS    0           LOOP UNTIL REQUEST SATISFIED
          GE     B0,B6,WRTDONE (BREAK IF ZERO BYTES IN REQUEST
          GE     B3,B2,WRTBUF BRANCH TO EMPTY BUFFER, IF FULL
 
          SA2    X1          GET WORD FROM USER BUFFER
          SX1    X1+B1       . AND INCREMENT USER BUFFER PTR
          SB7    B3+BUFSTRT  GET CURRENT WORD OFFSET INTO BUFFER
 WRTWORD  NE     B1,B5,WRTBYTE SKIP IF NOT WORD I/O
          BX7    X2          MOVE WORD TO OUTPUT REGISTER
          SA7    X0+B7       . AND STORE INTO I/O BUFFER
          SB3    B3+B1       . INCREMENT CURRENT WORD PTR
          SB6    B6-B1       . DECREMENT BYTES LEFT IN REQUEST
          EQ     WRTLOOP     SEE IF ANY MORE TO DO
 
 WRTBYTE  BSS    0           WRITE BYTE INTO I/O BUFFER
          SA3    X0+B7       LOAD CURRENT WORD FROM I/O BUFFER
          SA5    X0+MAPFLAG  CHECK MAPPING FLAG
          ZR     X5,NOTCHAR  . AND SKIP IF NO NEED TO CHECK FOR NL
          SX4    NEWLINE     CHECK FOR NEWLINE (ASCII 10)
          IX4    X2-X4
          ZR     X4,HAVNL    . AND BRANCH IF WE HAVE A NEWLINE
 
 NOTCHAR  BSS    0           STORE BYTE INTO BUFFER
          SA5    X0+BTSPBYT  MOVE BITS/BYTE INTO X5
          SB7    X5-1B       . AND BITS/BYTE -1 INTO B7
          MX4    1B          BUILD ONE-BYTE MASK IN X4
          AX4    B7          . THE HARD WAY [CURSE CDC]
          SB7    X5          PUT BITS/BYTE INTO B7
          LX4    B7          . AND RIGHT-JUSTIFY BYTE MASK
          SX7    B4+B1       CURRENT BYTE PTR + 1 INTO X7
          IX7    X5*X7       ROTATE CNT TO RIGHT-JUSTIFY I/O WORD
          SB7    X7          . AND LOAD ROTATE COUNT INTO B7
          LX7    B7,X3       RIGHT-JUSTIFY BYTE POSITION
          BX7    -X4*X7      . CLEAN OUT BYTE POSITION
          BX7    X2+X7       . OR IN NEW BYTE
          SB7    B7-60       COMPUTE REVERSE SHIFT COUNT
          AX7    B7,X7       SHIFT WORD TO ORIGINAL POS. (B7 NEG.)
          SA7    A3          STORE WORD BACK INTO I/O BUFFER
          SB4    B4+B1       INCREMENT CURRENT BYTE PTR
          LT     B4,B5,SAMWRD . AND SKIP IF IN CURRENT WORD STILL
          SB4    B0          . ELSE RESET CURRENT BYTE
          SB3    B3+B1       .      RESET CURRENT WORD PTRS
 SAMWRD   SB6    B6-B1       DECREMENT BYTES LEFT IN REQUEST
          EQ     WRTLOOP     AND SEE IF MORE TO DO
 
 HAVNL    BSS    0           OK, NEED TO WRITE CYBER EOL
          SX5    12          12-BITS/ASCII CHAR (SHEESH)
          SX4    B4          NUM OF VALID BYTES IN WORD
          IX4    X4*X5       NUM OF VALID BITS
          SB7    X4          . STORED INTO B7
          SA5    AEOLWRD     GET ASCII EOL WORD
          NE     B0,B7,NOTASOW SPECIAL CASE START-OF-WORD
          BX7    X5
          EQ     ASTORE1     . BECAUSE OF LIMITED INST. SET.
 NOTASOW  MX4    1           BUILD MASK OF VALID BITS
          SB7    B7-B1       . THE HARD WAY
          AX4    B7          . (CURSE CDC)
          BX7    X3*X4       CLEAR OUT DIRTY BITS IN BUFFER WORD
          BX5    -X4*X5      . AND IN END-OF-LINE WORD
          BX7    X5+X7       OR THE TWO TOGETHER
 ASTORE1  SA7    A3          REWRITE BUFFER WORD TO MEMORY
          SB4    B0          . POINT TO FIRST BYTE
          SB3    B3+B1       . IN THE NEXT WORD
          SB6    B6-B1       DECREMENT NUM. OF BYTES LEFT
          EQ     WRTLOOP     . AND SEE IF MORE TO DO
 
 WRTBUF   BSS    0           WRITE BUFFER TO FILE
          WRITOUT            .. EMPTY BUFFER
          EQ     WRTLOOP     AND SEE IF MORE TO DO
 
 WRTDONE  BSS    0           CLEAN UP BEFORE GOING HOME
          SAVPARS            SAVE PARAMETERS WHICH MAY CHANGE
          SA4    WRTNRCH     RESTORE NUMBER OF CHARACTERS TRANSMITTED
          BX6    X4             AS RESULT OF FUNCTION
          EQ     WRITEF=     AND GO HOME
 
 
**        MOVE DISPLAY CODE TO BUFFER
 
 WRDSP1   SX7    X5-1        SET NORMAL/EXTENDED SWITCH
          SA7    WRDSPSW     SAVE IT
          SX5    X7          AND PLACE IT IN WORKING REGISTER
          MX6    1           SET SWITCH FOR NO 2ND HALF AT THE MOMENT
 
 WRDSP2   GE     B0,B6,WRTDONE IF REQUEST SATISFIED
          LT     B3,B2,WRDSP3 IF BUFFER NOT FULL
          WRITOUT            FLUSH BUFFER
          SA5    WRDSPSW     RELOAD NORMAL/EXTENDED SWITCH
 
 WRDSP3   SB7    B3+BUFSTRT  FIND OUTPUT BUFFER WORD
          SA3    X0+B7       GET WORD FROM OUTPUT BUFFER
          BX7    X3            IN CASE ADDING CHARACTER TO IT
          GT     B4,B0,WRDSP4 IF NOT AT START OF WORD
          BX7    X7-X7       CLEAR BUFFER WORD IF AT START
 
 WRDSP4   SA2    X1          GET NEXT CHARACTER FROM USER BUFFER
          SX1    X1+B1       INCREMENT POINTER
          SB6    B6-B1       DECREMENT CHAR REMAINING COUNTER
          SX3    B4+B4       COMPUTE CHARACTER SHIFT (CHAR#*2)
          IX4    X3+X3           *4
          IX4    X4+X3           *6
          SB7    X4-54       ADJUST FOR SHIFT FROM RIGHT
          SX4    X2-NEWLINE  CHECK FOR END OF LINE
          ZR     X4,WRDSP10  IF END-OF-LINE
          ZR     X5,WRDSP5   IF NORMAL DISPLAY CODE
          SA4    X2+OUTMAPX  TRANSLATE EXTENDED DISPLAY CODE
          PL     X4,WRDSP6   IF 6-BIT CHARACTER
          SX6    X4          SAVE 2ND 6 BITS OF 12-BIT CHARACTER
          AX4    18          GET 1ST 6 BITS
          SX4    X4          EXTRACT IT
          EQ     WRDSP6      GO MERGE IT
 
 WRDSP5   SA4    X2+OUTMAP   TRANSLATE WORD TO NORMAL DISPLAY CODE
 
 WRDSP6   AX4    B7,X4       POSITION CHARACTER
          BX7    X7+X4       INSERT CHARACTER
          SB4    B4+B1       BUMP CHARACTER NUMBER
          LT     B4,B5,WRDSP8 IF NOT AT END OF WORD
          SA7    A3          STORE COMPLETED WORD
          SB4    B0          RESET FOR NEXT WORD
          SB3    B3+B1
          NG     X6,WRDSP2   IF NO 2ND HALF OF CHAR
          LT     B3,B2,WRDSP7  IF BUFFER NOT FULL
          WRITOUT            WRITE OUT BUFFER
          SA5    WRDSPSW     RELOAD NORMAL/EXTENDED SWITCH
 
 WRDSP7   SX7    X6          START NEW WORD WITH 2ND HALF OF CHAR
          LX7    59-5        POSITION CHAR
          SB4    B1          CHARACTER COUNT IN WORD
          MX6    1           CLEAR LOWER 6-BIT FLAG
          SB7    B3+BUFSTRT
          SA7    X0+B7
          EQ     WRDSP2      CONTINUE
 
 WRDSP8   PL     X6,WRDSP9   IF 2ND HALF TO ADD
          GT     B6,B0,WRDSP4 IF NOT DONE WITH REQUEST
          SA7    A3          STORE PARTIAL WORD AT END OF REQUEST
          EQ     WRTDONE     GO EXIT FROM PROGRAM
 
 WRDSP9   SX4    X6          LOW 6 BITS OF 12-BIT CHARACTER
          SB7    B7+6        ADJUST SHIFT AMOUNT
          MX6    1           CLEAR LAST HALF
          EQ     WRDSP6      GO MERGE CHARACTER
 
 WRDSP10  EQ     B4,B0,WRDSP13 ON EOL, IF AT START OF WORD
          SX4    B4          CHECK FOR EVEN OR ODD POSITION IN WORD
          LX4    59-0
          PL     X4,WRDSP11  IF EVEN NUMBER OF CHARACTERS IN WORD
          SX3    1R          ADD A BLANK
          AX3    B7,X3       POSITION IT
          BX7    X7+X3       MERGE INTO RESULT WORD
          SB7    B7+6        ADJUST BIT SHIFT
          EQ     WRDSP12     NOW WE HAVE BLANK AS LAST CHAR
 
 WRDSP11  SX3    7700B       CHECK FOR COLON AS LAST CHARACTER
          AX3    B7,X3
          BX4    X3*X7
          NZ     X4,WRDSP12  IF NOT COLON (00B)
          SB7    B7+6        ADD 2 SPACES
          SX3    2R
          AX3    B7,X3
          BX7    X7+X3
 
 WRDSP12  SA7    A3          STORE WORD BACK INTO BUFFER
          SB4    B0          SET POINTERS FOR NEXT WORD
          SB3    B3+B1
          MX3    -12         CHECK FOR EOL IN FINAL WORD ALREADY
          BX3    -X3*X7
          ZR     X3,WRDSP15  IF EOL OUT THERE ALREADY
 
 WRDSP13  LT     B3,B2,WRDSP14 IF BUFFER NOT FULL
          WRITOUT            FLUSH BUFFER
          SA5    WRDSPSW     RELOAD NORMAL/EXTENDED SWITCH
 
 WRDSP14  SB7    B3+BUFSTRT  SET UP BUFFER POINTER
          SX7    2R          FORM WORD OF 2 SPACES IN LEFTMOST CHARS
          LX7    59-11
          SA7    X0+B7       STORE IN BUFFER
          SB3    B3+B1       INCREMENT BUFFER POINTER
 
 WRDSP15  SA2    X0+COL1BLK  CHECK IF BLANK CARRIAGE CONTROL NEEDED
          ZR     X2,WRDSP2   IF NOT NEEDED, CONTINUE
          LT     B3,B2,WRDSP16 IF SPACE IN BUFFER
          WRITOUT            FLUSH BUFFER
          SA5    WRDSPSW     RELOAD NORMAL/EXTENDED SWITCH
 
 WRDSP16  SX7    1R          SET UP BLANK CARRIAGE CONTROL
          LX7    59-5        POSITION IT
          SB7    B3+BUFSTRT  PLACE IT IN OUTPUT BUFFER
          SA7    X0+B7
          SB4    B1          SET CHARACTER COUNT
          EQ     WRDSP2      CONTINUE
 
          END
#-H- XAFX.COM 24368 1979 1221 843
*DECK XAFX
          IDENT  XAFX
          MACHINE 6,I
          SYSCOM B1
 XAFX     TITLE  XAFX - ABBREVIATED FTN EXECUTIVE.
          COMMENT ABBREVIATED FTN EXECUTIVE.
 XAFX     SPACE  4,10
*****     XAFX - ABBREVIATED FTN EXECUTIVE.
*
*         R. O. ANDERSON.  77-JAN-14.
*         B. L. TRUMBO.    78-MAY-13.
*
*         SMALL FTN RUNTIME SYSTEM TO AVOID THE CYBER RECORD MANAGER
*         AND THE FORTRAN FORMATTED I/O SYSTEM.
*
*         THIS MODULE IS BASED ON PIECES OF CODE FROM THE CONTROL DATA
*         ROUTINES *FORSYS=*, *OVERLAY*, AND OTHERS, AS WELL AS CODE
*         FROM *COMCFOR* BY R. A. HOLMES.  *XAFX* IS INTENDED FOR USE
*         IN SYSTEM APPLICATIONS WHERE SPACE CONSIDERATIONS MAKE
*         EXCLUSION OF THE CYBER RECORD MANAGER AND/OR THE FORTRAN RUN
*         TIME SYSTEM DESIRABLE.
 XAFX     SPACE  4,10
*CALL FCLMAC
 
**        KEYWD MACRO - DEFINE A TABLE ENTRY FOR XAFX.
*
*         KEYWD  STR,ADDR
*
*         ENTRY  STR       IS A 1 TO 7 CHARACTER STRING DENOTING THE
*                          OPTION.
*                ADDR      ADDRESS TO DISPATCH TO IF THE OPTION IS
*                          FOUND.
*
 KEYWD    MACRO  STR,ADDR
          VFD    42D/0H_STR,18D/ADDR
          ENDM
 XAFX     SPACE  4,10
**        GLOBAL DATA AREAS.
*
 XAFXA    DATA   0           CP STARTING TIME
 
 XAFXB    DATA   0           CP ENDING TIME
 
 FLLCM.   ENTRY. 0           ECS FL SAVED HERE
 FLSCM.   ENTRY. 0           CM FL SAVED HERE
 
          USE    /CMAP/      MAP COMMON
 INMAP    BSS    0           . DISPLAY CODE TO ASCII
          IF DEF,IO64
          CON    0#3A         . ASCII COLON
          ELSE
          CON    0#00         . ASCII NULL
          ENDIF
          CON    0#41        UPPER CASE A
          CON    0#42        UPPER CASE B
          CON    0#43        UPPER CASE C
          CON    0#44        UPPER CASE D
          CON    0#45        UPPER CASE E
          CON    0#46        UPPER CASE F
          CON    0#47        UPPER CASE G
          CON    0#48        UPPER CASE H
          CON    0#49        UPPER CASE I
          CON    0#4A        UPPER CASE J
          CON    0#4B        UPPER CASE K
          CON    0#4C        UPPER CASE L
          CON    0#4D        UPPER CASE M
          CON    0#4E        UPPER CASE N
          CON    0#4F        UPPER CASE O
          CON    0#50        UPPER CASE P
          CON    0#51        UPPER CASE Q
          CON    0#52        UPPER CASE R
          CON    0#53        UPPER CASE S
          CON    0#54        UPPER CASE T
          CON    0#55        UPPER CASE U
          CON    0#56        UPPER CASE V
          CON    0#57        UPPER CASE W
          CON    0#58        UPPER CASE X
          CON    0#59        UPPER CASE Y
          CON    0#5A        UPPER CASE Z
          CON    0#30        0
          CON    0#31        1
          CON    0#32        2
          CON    0#33        3
          CON    0#34        4
          CON    0#35        5
          CON    0#36        6
          CON    0#37        7
          CON    0#38        8
          CON    0#39        9
          CON    0#2B        +
          CON    0#2D        -
          CON    0#2A        *
          CON    0#2F        /
          CON    0#28        (
          CON    0#29        )
          CON    0#24        $
          CON    0#3D        =
          CON    0#20        SPACE
          CON    0#2C        ,
          CON    0#2E        .
          CON    0#23        #
          CON    0#7B        [ (TRANSLATE AS OPEN BRACE)
          CON    0#7D        ] (TRANSLATE AS CLOSE BRACE)
          IF DEF,IO64
          CON    0#25        . ASCII PERCENT
          ELSE
          CON    0#3A        . ASCII COLON
          ENDIF
          CON    0#22        "
          CON    0#5F        _
          CON    0#21        !
          CON    0#26        &
          CON    0#27        '
          CON    0#3F        ?
          CON    0#3C        <
          CON    0#3E        >
          CON    0#40        @
          CON    0#7C        \ (TRANSLATE AS VERTICAL BAR FOR OR)
          CON    0#7E        ^ (TRANSLATE AS TILDE FOR NOT)
          CON    0#3B        ;
 
 OUTMAP   BSS    0           . ASCII TO DISPLAY CODE
          DUP    10
          CON    1R          BLANK FOR CONTROL
          ENDD
          CON    0           NEW LINE
          DUP    21
          CON    1R          BLANK FOR CONTROL
          ENDD
 
          CON    1R
          CON    1R!
          CON    1R"
          CON    1R#
          CON    1R$
          CON    0#33       . COLON IN 63 CH. SET, PERCENT IN 64
          CON    1R&
          CON    1R'
          CON    1R(
          CON    1R)
          CON    1R*
          CON    1R+
          CON    1R,
          CON    1R-
          CON    1R.
          CON    1R/
 
          CON    1R0
          CON    1R1
          CON    1R2
          CON    1R3
          CON    1R4
          CON    1R5
          CON    1R6
          CON    1R7
          CON    1R8
          CON    1R9
          IF DEF,IO64
          CON    0#00        . COLON IN 64 CH. SET
          ELSE
          CON    0#33        . COLON IN 63 CH. SET
          ENDIF
          CON    1R;
          CON    1R<
          CON    1R=
          CON    1R>
          CON    1R?
 
          CON    1R@
          CON    1RA
          CON    1RB
          CON    1RC
          CON    1RD
          CON    1RE
          CON    1RF
          CON    1RG
          CON    1RH
          CON    1RI
          CON    1RJ
          CON    1RK
          CON    1RL
          CON    1RM
          CON    1RN
          CON    1RO
 
          CON    1RP
          CON    1RQ
          CON    1RR
          CON    1RS
          CON    1RT
          CON    1RU
          CON    1RV
          CON    1RW
          CON    1RX
          CON    1RY
          CON    1RZ
          CON    1R[
          CON    1R\
          CON    1R]
          CON    1R^
          CON    65B         UNDERSCORE (COMPASS PROBLEM)
 
          CON    1R@         FOLD IN COLUMNS 6 AND 7
          CON    1RA
          CON    1RB
          CON    1RC
          CON    1RD
          CON    1RE
          CON    1RF
          CON    1RG
          CON    1RH
          CON    1RI
          CON    1RJ
          CON    1RK
          CON    1RL
          CON    1RM
          CON    1RN
          CON    1RO
 
          CON    1RP
          CON    1RQ
          CON    1RR
          CON    1RS
          CON    1RT
          CON    1RU
          CON    1RV
          CON    1RW
          CON    1RX
          CON    1RY
          CON    1RZ
          CON    1R[
          CON    1R\
          CON    1R]
          CON    1R^
          CON    1R
 
          USE CODE.
 RANDOM.  ENTRY. 17171274321477413155B  SEED FOR RANF()
          ENTRY. 20000000000000553645B  MULTIPLIER FOR RANF()
 ABNORM.  SPACE  4,10
***       ABNORM. - ABORT AN FTN PROGRAM.
*
*         ENTRY  NONE.
*
*         EXIT   JOB WILL BE ABORTED TO AN *EXIT.* CARD.
*
*         CALLS  AFX.CET, MSG=, SYS=, QQEXIT.
 
 
 ABNORM.  ENTRY.             ENTRY/EXIT
          SB1    1           ALWAYS
          RJ    =XQQEXIT         CLOSE ALL FILES
          RJ     AFX.CET     COMPUTE AND PRINT ELAPSED TIME
          MESSAGE ABNORM.A,,RCL  PRINT ABORT MESSAGE
          ABORT  ,ND         KILL THE RUN WITH NO DMPX
 
 ABNORM.A DATA   C* JOB ABORTED.*
 XAFX     SPACE  4,10
***       XAFX - PROCESS USER REQUESTS.
*
*         CALL XAFX(OPT)
*
*         ENTRY  *OPT*  IS A LIST OF DISPLAY CODE OPTIONS IN *H*
*                       FORMAT, WITH A MAXIMUM OF 7 CHARACTERS PER
*                       OPTION.  THIS LIST MUST BE TERMINATED BY A
*                       FULL WORD OF BINARY ZEROS.
*
*         EXIT   RETURNS AFTER PROCESSING ALL OPTIONS, EXCEPT THE
*                ABORT OPTIONS.  THESE OPTIONS CAUSE IMMEDIATE JOB
*                TERMINATION IN THE SPECIFIED MANNER.
*
*         CALLS  SYSERR., SYS=.
 
 
 XAFX     TRACE  XAFX,XAFX   TRACEBACK LINK
 XAFX     ENTRY.             ENTRY/EXIT
          SB1    1           ALWAYS
          SA1    X1-1        INITIALIZE INDEX TO OPTION LIST
 XAFX1    SB2    XAFXE       B2 = FWA OF TABLE
          SB3    B2+XAFXF    B3 = LWA + 1 OF TABLE
          SA1    A1+B1       GET THE USER'S OPTION
          ZR     X1,XAFX    RETURN AT END OF LIST
 XAFX2    SA3    B2          GET THE FIRST TABLE ENTRY
          BX6    X3-X1       COMPARE WITH USER'S CHOICE
          MX0    42          EDIT MASK FOR 7 CHARACTER COMPARE
          BX6    X0*X6       ZAP EXTRA DATA
          CX6    X6          TEST FOR ZERO
          ZR     X6,XAFX3    IF A MATCH
          SB2    B2+B1       BUMP POINTER
          LT     B2,B3,XAFX2 IF MORE TO CHECK
          BX1    X0*X1       ISOLATE 7 CHARACTERS
          SA2    XAFXC+2     GET MESSAGE SLOT
          LX1    -18         POSITION BAD OPTION
          MX6    18
          BX6    X6*X2
          BX6    X6+X1       ADD IN BAD OPTION
          SA6    A2          PLACE IN MESSAGE
          SX1    52          ERROR NUMBER (USER DEFINED / FATAL)
          SX2    XAFXC       ERROR MESSAGE
          RJT    SYSERR.,,XAFX  PULL THE PLUG (WITH TRACEBACK)
          EQ     XAFX        IN THE (UNLIKELY) EVENT WE RETURN
 
 XAFX3    SB2    X3          GET THE TRANSFER ADDRESS
          JP     B2          ENTER PROCESSING ROUTINE
 
 XAFX4    ABORT              USER SAID *ABORT*
 
 XAFX5    ABORT  ,ND         USER SAID *ABORTN*
 
 XAFX6    ABORT  ,,S         USER SAID *ABORTS*
 
 XAFX7    ABORT  ,ND,S       USER SAID *ABORTNS*
 
 XAFX8    SX6    B0          CLEAR THE GAG BIT (*DAY* SPECIFIED)
          SA6    XAFXD
          EQ     XAFX1       GO GET NEXT OPTION
 
 XAFX9    SX6    B1          SET THE GAG BIT (*NODAY* SPECIFIED)
          SA6    XAFXD
          EQ     XAFX1       GO GET NEXT OPTION
 
 XAFXC    DATA   C* UNKNOWN XAFX OPTION = XXXXXXX*
 
 XAFXD    DATA   0           GAG / NOGAG FLAG WORD
 
 XAFXE    KEYWD  ABORT,XAFX4 ABORT WITH DUMP TO *EXIT.*
          KEYWD  ABORTN,XAFX5  ABORT WITH NO DUMP TO *EXIT.*
          KEYWD  ABORTS,XAFX6  ABORT WITH DUMP TO *EXIT(S)*
          KEYWD  ABORTNS,XAFX7  ABORT WITH NO DUMP TO *EXIT(S)*
          KEYWD  DAY,XAFX8   DAYFILE MESSAGES ALLOWED
          KEYWD  NODAY,XAFX9 NO DAYFILE MESSAGES ALLOWED
 XAFXF    EQU    *-XAFXE     LENGTH OF TABLE
 END.     SPACE  4,10
***       END. - PERFORM FTN NORMAL TERMINATION.
*
*         THIS MODULE PROVIDES TERMINATION PROCESSING FOR FORTRAN
*         PROGRAMS.  IF THE NODAY OPTION HAS NOT BEEN SELECTED, AN
*         APPROPRIATE DAYFILE MESSAGE IS ISSUED WITH THE EXECUTION
*         TIME.
*
*         ENTRY  (X1) = THE FTN TRACEBACK WORD FOR THE MODULE TO BE
*                TERMINATED.  IF THE WORD POINTED TO BY THE TRACEBACK
*                WORD IS A *JP*, THE MODULE DOING THE *END* IS AN
*                OVERLAY, AND CONTROL IS RETURNED TO THE ADDRESS GIVEN
*                BY THE *JP*.
*
*         EXIT   EITHER TERMINATES THE JOB, OR RETURNS TO THE CALLING
*                OVERLAY AS NEEDED.
*
*         CALLS  AFX.CET, MSG=, SYS=.
 
 
 END.     ENTER  *           FOR *END* STATEMENTS
          SB1    1           ALWAYS
 END.1    MX6    42          EXTRACT
          BX6    X6*X1       THE MODULE NAME
          SA6    END.B       PLACE IN MESSAGE
          SB2    END.A       PICK UP MESSAGE ADDRESS
 END.2    SA1    XAFXD       SEE IF WE SHOULD KEEP QUIET
          NZ     X1,END.3    IF SO
          MESSAGE B2,,RCL    TELL EVERYONE WE ARE DONE
          RJ     AFX.CET     COMPUTE AND PRINT ELAPSED TIME
 END.3    RJ     =XQQEXIT        CLOSE ALL OPEN FILES, THEN
          ENDRUN                LEAVE QUIETLY
 
 END.C    DATA   0              FAKE ADDRESS LIST FOR QQEXIT
 END.A    DATA   A*END -- *
 END.B    DATA   C*XXXXXXX*  MODULE NAME GOES HERE
 EXIT     SPACE  4,10
***       EXIT - EXIT A FORTRAN PROGRAM.
*
*         CALL EXIT
*
*         ENTRY  NONE.
*
*         EXIT   THE JOB STEP IS TERMINATED NORMALLY.
*
*         CALLS  NONE.
 
 
 EXIT     ENTRY.             FOR *CALL EXIT* STATEMENTS
          SB1    1           ALWAYS
          SB2    EXITA       PICK UP MESSAGE ADDRESS
          EQ     END.2       TO FINISH UP
 
 EXITA    DATA   C*   EXIT.*
 STOP.    SPACE  4,10
***       STOP. - STOP PROGRAM EXECUTION.
*
*         ENTRY  (X1) = THE ADDRESS OF THE *L* FORMAT *STOP* MESSAGE.
*                       THIS MESSAGE WILL BE TRUNCATED TO A MAXIMUM
*                       OF 70 CHARACTERS.
*
*         EXIT   THE MESSAGE IS PRINTED, UNLESS GAG IS SET, AND THE
*                JOB STEP IS TERMINATED NORMALLY.
*
*         CALLS  NONE.
 
 
 STOP.    ENTER  *           FOR *STOP* STATEMENTS
          SB1    1           ALWAYS
          SA1    A1-B1       BACK UP FOR A RUNNING START
          SB2    B1          INITIAL OFFSET INTO STOP MESSAGE
          SB3    7           LONGEST MESSAGE FOR FTN IS 7 WORDS
          MX2    -12         TO TEST FOR EOL
 STOP.1   SA1    A1+B1       GET A WORD
          BX6    X1          ADD IT
          SA6    STOP.A+B2   TO MESSAGE
          SB2    B2+B1       INCREMENT POINTER
          SB3    B3-B1       DECREMENT COUNT
          BX6    -X2*X6      SEE IF EOL
          ZR     X6,STOP.2   IF SO
          GT     B3,B0,STOP.1  LOOP IF COUNT NOT EXHAUSTED
 STOP.2   SB2    STOP.A      PICK UP MESSAGE POINTER
          EQ     END.2       TO FINISH UP
 
 STOP.A   DATA   A*STOP  *
          BSSZ   8           70 CHAR MESSAGE + EOL
 GOTOER.  SPACE  4,10
***       GOTOER. - HANDLE COMPUTED GO TO ERRORS.
*
*         ENTRY  NONE.
*
*         EXIT   JOB IS ABORTED TO AN *EXIT* CARD.
*
*         CALLS  SYSERR..
 
 
 GOTOER.  TRACE  GOTOER.,GOTOER.  TRACEBACK WORD
 GOTOER.  ENTRY.             ENTRY/EXIT
          SB1    1           ALWAYS
          SX1    B1          ERROR NUMBER NUMBER 1
          SX2    GOTOER.A    ERROR FOR INVALID GOTO INDEX
          RJT    SYSERR.,,GOTOER.  PULL THE PLUG (WITH TRACEBACK)
          EQ     GOTOER.     WE SHOULD NOT RETURN, BUT...
 
 GOTOER.A DATA   C* INVALID INDEX IN A COMPUTED GOTO.*
 FECOPE.  SPACE  4,10
***       FECOPE. - INTERCEPT FTN I/O FROM SORT/MERGE.
*
*         ENTRY  NONE.
*
*         EXIT   JOB IS ABORTED.
*
*         CALLS  SYSERR..
 
 
 FECOPE.  TRACE  FECOPE.,FECOPE.  TRACEBACK WORD
 FECOPE.  ENTRY.             ENTRY/EXIT
          SX1    52          ERROR NUMBER (USER DEFINED / FATAL)
          SX2    FECOPE.A     ERROR MESSAGE
          RJT    SYSERR.,,FECOPE.  PULL THE PLUG (WITH TRACEBACK)
          EQ     FECOPE.     WE SHOULD NOT COME BACK, BUT...
 
 FECOPE.A DATA   40H FORMATTED I/O NOT SUPPORTED BY XAFX.
          DATA   C* RELOAD USING CDC ROUTINES.*
 Q8NTRY.  SPACE  4,10
***       Q8NTRY. - INITIALIZE FTN RUN-TIME CELLS.
*         Q1NTRY. - INITIALIZE FTN RUN-TIME CELLS.
*         Q2NTRY. - INITIALIZE FTN RUN-TIME CELLS.
*         Q8NTR= - INITIALIZE MNF RUN-TIME CELLS.
*
*         ENTRY  (X0) = THE *ECS* FL.
*                (A0) = THE *CM* FL.
*
*         EXIT   CELLS *FLLCM.* AND *FLSCM.* ARE INITIALIZED.
*
*         CALLS  SYS=.
 
 
 Q1NTRY.  ENTER  *           FTN ENTRY FOR CRM 1.5
 Q2NTRY.  ENTER  *           FTN ENTRY FOR CRM 1.5
 Q8NTR=   ENTER  *           MNF ENTRY
 Q8NTRY.  ENTRY.             ENTRY/EXIT
          SB1    1           ALWAYS
          BX6    X0          SAVE LCM
          SA6    FLLCM.      FIELD LENGTH
          SX6    A0          SAVE SCM
          SA6    FLSCM.      FIELD LENGTH
          TIME   XAFXA       GET CP STARTING TIME
          RJ     =XQQINIT       OPEN STANDARD INPUT AND OUTPUT
          EQ     Q8NTRY.     RETURN
 SYSERR.  SPACE  4,10
***       SYSERR. - PRINT ERROR NUMBER AND ABORT THE JOB.
*
*         ENTRY  (X1) = THE ADDRESS OF AN ERROR MESSAGE.
*                (X2) = THE ASSOCIATED ERROR NUMBER.
*
*         EXIT   MESSAGE IS PRINTED AND JOB IS ABORTED.
*
*         CALLS  CDD=, MSG=, TRACER., ABNORM..
 
 
 SYSERR.  ENTRY.             ENTRY/EXIT
          SB1    1           ALWAYS
          BX5    X2          PRESERVE MESSAGE ADDR. ACROSS CDD
          RJ     =XCDD=      CONVERT ERROR NUMBER TO DISPLAY CODE
          LX6    -18         ISOLATE THREE DIGITS
          MX7    18
          BX7    X7*X6
          SA7    SYSERR.B    PLACE RESULT IN ERROR NUMBER SLOT
          MESSAGE SYSERR.A,LOCAL,RCL  PRINT ERROR NUMBER
          MESSAGE X5,LOCAL,RCL  AND NASTY MESSAGE
          SX1    SYSERR.     (X1) = ENTRY POINT ADDRESS
          SX2    B0          TELL *TRACER.* TO USE DAYFILE
          MX3    0           GIVE INFINTE TRACEBACK
          SX4    B1          USE *DETECTED BY*
          RJ     TRACER.     GET TRACEBACK
          RJ     ABNORM.     TO BLOW OFF THE RUN
          EQ     SYSERR.     WE SHOULD NOT COME BACK, BUT...
 
 SYSERR.A DATA   20H FTN - FATAL ERROR
 SYSERR.B DATA   C*999*      ERROR NUMBER GOES HERE
 TRACER.  SPACE  4,10
***       TRACER. - PROVIDE TRACEBACK PROCESSING FOR FTN.
*
*         ENTRY  (X1) = THE ADDRESS OF THE ENTRY POINT OF THE MODULE
*                       ONE LEVEL BELOW WHERE TRACEBACK SHOULD START.
*                (X2) = 0 IF TRACE MESSAGES SHOULD GO TO DAYFILE.
*                (X2) = A FET ADDRESS IF MESSAGES SHOULD GO TO A FILE.
*                (X3) = 0 FOR INFINITE TRACEBACK.
*                (X3) = N FOR *N* LEVELS OF TRACEBACK.
*                (X4) = 1 TO GET THE FIRST MESSAGE TO START *DETECTED
*                       BY*.
*                (X4) = 0 TO GET THE FIRST MESSAGE TO START *CALLED
*                       FROM*.
*
*         EXIT   RETURNS AFTER TRACING BACK TO A MAIN PROGRAM.
*
*         CALLS  WOD=, MSG=, CDD=, WTC=.
 
 
 TRACER.1 SX1    A1          GET ADDRESS OF BAD LINK WORD
          RJ     =XWOD=      CONVERT TO OCTAL DISPLAY CODE
          MX6    -36         EXTRACT THE RIGHT MOST 6 DIGITS
          BX7    -X6*X7
          LX7    12
          MX6    12          MASK TO CLEAN OLD MESSAGE
          SA1    TRACER.B+3  GET MESSAGE WORD
          BX6    X6*X1       CLEAR OLD INFO
          BX6    X6+X7       ADD IN NEW
          SA6    A1          PLACE IN MESSAGE
          MESSAGE TRACER.B,LOCAL,RCL  TELL THE WORLD ABOUT IT
 TRACER.  ENTRY.             ENTRY/EXIT
          SX6    X3          SAVE THE TRACEBACK LIMIT
          SA6    TRACER.G
          SB7    X2          GET THE FET ADDRESS (OR 0)
          SB1    1           ALWAYS
          SA2    TRACER.D    GET TEST WORD FOR *RJ* CREATED *EQ*
 TRACER.2 LX4    1           CONVERT CALL TYPE TO OFFSET
          SA4    TRACER.F+X4 GET MESSAGE WITH CALL TYPE
          BX6    X4          MOVE TO TRACE BUFFER
          SA6    TRACER.C
          SA4    A4+B1       GET NEXT WORD
          BX6    X4          MOVE INTO BUFFER
          SA6    A6+B1
          SA1    X1          GET THE *EQ* WORD
          BX2    X1-X2       TEST FOR AN *RJ* CREATED *EQ*
          LX2    12          AFTER DELETING THE ADDRESS FIELD
          MX6    18
          BX6    -X6*X2
          NZ     X6,TRACER.  RETURN IF A MAIN PROGRAM
          AX1    30          MOVE ADDRESS INTO LOW BITS
          SA1    X1-1        GET WORD WITH *RJ* / TRACEBACK LINK
          MX6    12          ISOLATE OPCODE
          BX6    X6*X1
          SA2    TRACER.H    TEST WORD FOR *RJ* INSTRUCTION
          BX6    X2-X6       SEE IF AN *RJ*
          NZ     X6,TRACER.1 IF NOT, SOMEBODY BLEW IT
          MX6    -30         EDIT MASK TO ISOLATE LINE NUMBER AND LINK
          BX6    -X6*X1
          SA2    TRACER.I    GET TEST WORD NUMBER 2
          BX2    X6-X2       SEE IF NO-OPS IN LOW ORDER BITS
          SX5    X6          SAVE POINTER TO TRACEBACK WORD
          ZR     X2,TRACER.1 IF WE FOUND NO-OPS, USER BLEW IT
          AX6    18          MOVE LINE NUMBER DOWN
          SX1    X6          (X1) = LINE NUMBER (CONVENIENCE)
          ZR     X1,TRACER.3 IF A COMPASS CALL
          RJ     =XCDD=      CONVERT LINE NUMBER TO DISPLAY CODE
          MX7    -24         ISOLATE 4 DIGITS
          BX7    -X7*X6
          LX7    -24         MOVE TO TOP OF WORD, THUS MAKING EOL
          SA7    TRACER.C+3  PLACE IN BUFFER
          SA4    TRACER.E    GET * AT LINE  *
          BX6    X4          PLACE IN BUFFER
          SA6    A7-B1
          EQ     TRACER.4    JOIN COMMON PROCESSING
 
 TRACER.3 SX1    A1          PICK UP ADDRESS WHERE *RJ* IS
          IX1    X1-X5       SUBTRACT ADDRESS OF TRACEBACK WORD
          MX6    0           ASSUME DIFFERENCE WILL BE NEG.
          SB5    X5          SAVE POINTER TO TRACEBACK WORD
          SA6    TRACER.C+2  PLACE EOL MARKER
          MI     X1,TRACER.4 IF ADDRESS TO BE SUPPRESSED
          RJ     =XWOD=      CONVERT RELATIVE ADDRESS TO OCTAL DISPLAY
          MX6    -36
          BX7    -X6*X7      ISOLATE 6 DIGITS
          SA1    TRACER.A+1  GET *S 777777*
          LX7    12          POSITION DIGITS
          MX6    12          MASK TO PRESERVE PART OF MESSAGE
          BX6    X6*X1       DELETE OLD ADDRESS
          BX6    X6+X7       ADD IN NEW ADDRESS
          SA6    TRACER.C+3
          SA1    A1-B1       GET * AT ADDRES*
          BX6    X1          PLACE IN BUFFER
          SA6    A6-B1
          SX5    B5          RESTORE TRACEBACK WORD POINTER
 TRACER.4 SA5    X5          GET THE TRACEBACK WORD IN X5
          MX6    42          EDIT MASK FOR GETTING NAME
          BX7    X6*X5       GET THE NAME
          LX7    -18         RIGHT JUSTIFY IT
          MX6    18          TO PRESERVE UPPER PART OF MESSAGE
          SA1    TRACER.C+1  GET THE WORD TO PUT NAME IN
          BX6    X6*X1       CLEAR OLD NAME
          BX6    X6+X7       ADD IN NEW NAME
          SA6    A1          PLACE IN MESSAGE
          LE     B7,B0,TRACER.5  IF MESSAGES GO TO DAYFILE
          WRITEC B7,A1-B1    OUTPUT THE LINE
          EQ     TRACER.6    TO REJOIN COMMON CODE
 
 TRACER.5 MESSAGE A1-B1,LOCAL,RCL  DISPLAY THE LINE
 TRACER.6 SA1    TRACER.G    GET MAX TRACEBACK LIMIT
          SX6    B1          DECREMENT BY 1
          IX6    X1-X6
          ZR     X6,TRACER.  IF LIMIT REACHED
          SA6    A1          UPDATE REMAINDER
          SX1    X5          X1 IS ENTRY POINT ADDRESS
          SA2    TRACER.D    GET ENTRY POINT TEST WORD
          MX4    0           INSURE WE GET * CALLED FROM*
          EQ     TRACER.2    LOOP TILL DONE
 
 TRACER.A DATA   C* AT ADDRESS 777777*
 
 TRACER.B DATA   C* BAD TRACEBACK LINK AT ABS ADDR 777777*
 
 TRACER.C BSSZ   4           MESSAGE BUFFER FOR TRACEBACK
 
 TRACER.D EQ     **          TEST WORD
 -        VFD    30/0        FOR AN *EQ* CREATED BY AN *RJ*
 
 TRACER.E DATA   C* AT LINE  9999*
 
 TRACER.F DATA   20H CALLED FROM XXXXXXX
          DATA   20H DETECTED BY XXXXXXX
 
 TRACER.G DATA   0           MAXIMUM TRACEBACK LIMIT STORED HERE
 
 TRACER.H RJ     **          TEST FOR AN *RJ* IN TOP 30 BITS
 -        VFD    30/0        OF A WORD
 
 TRACER.I VFD    30/0        TEST FOR STANDARD
 -        SB0    B0+46000B   NO-OP IN LOW ORDER BITS
 AFX.CET  SPACE  4,10
**        AFX.CET - COMPUTE ELAPSED CP TIME AND DAYFILE IT.
*
*         ENTRY  NONE.
*
*         EXIT   RETURNS AFTER ISSUING DAYFILE MESSAGE.
*
*         CALLS  SYS=, CFP>, MSG=.
 
 
 AFX.CET  SUBR               ENTRY/EXIT
          TIME   XAFXB       STOP THE CLOCK
          SA1    XAFXA       GET START TIME
          MX0    -24
          LX0    12          MASK FOR MSEC (MIDDLE 24 BITS)
          MX4    -12         MASK FOR MSEC (LOWER 12 BITS)
          BX2    -X4*X1      (X2) = MSEC
          BX1    -X0*X1
          LX1    -12         (X1) = SEC
          SX3    1000D       TO CONVERT SEC TO MSEC
          IX6    X1*X3       CONVERT SEC TO MSEC
          IX6    X6+X2       (X6) = START TIME IN MSEC
          SA1    XAFXB       GET STOP TIME
          BX2    -X4*X1      (X2) = MSEC
          BX1    -X0*X1
          LX1    -12         (X1) = SEC
          IX7    X1*X3       CONVERT SEC TO MSEC
          IX7    X7+X2       (X7) = STOP TIME IN MSEC
          SB2    3           SAY 3 AS IN F10.3
          IX1    X7-X6       TOTAL ELAPSED CP TIME IN MSEC
          PX3                GET FLOATING POINT 1000D
          PX1                CONVERT CP TIME TO FLOATING POINT
          NX3
          NX1
          RX1    X1/X3
          RJ     =XCFP>      CONVERT F.P. SECONDS TO DISPLAY
          SA6    AFX.CETA    PLACE IN MESSAGE
          MESSAGE A6,LOCAL,RCL  ISSUE IT
          EQ     AFX.CET     RETURN
 
 AFX.CETA DATA   10H 99999.999
          DATA   C* CP SECONDS EXECUTION TIME.*
 
          END
#-H- CARGS 608 1979 1221 844
DEFINE (AMEMSIZE,100)%# MAX. SIZE OF ARGLIST MEMORY (BYTES)
COMMON /CARGS/ TTYFLG, RUNPTR, INPTR, OUTPTR, ERRPTR, NARGS,
   MEMOFF, AMEM(AMEMSIZE), PEEK
   INTEGER TTYFLG%# NO IF NO COMMAND LINE WAS TYPED
   INTEGER RUNPTR%# POINTER TO NAME OF NEXT PROGRAM OR 0
   INTEGER INPTR%# POINTER TO STANDARD INPUT NAME OR 0
   INTEGER OUTPTR%# POINTER TO STANDARD OUTPUT NAME OR 0
   INTEGER ERRPTR%# POINTER TO STANDARD ERROR NAME OR 0
   INTEGER NARGS%# NUMBER OF ARGUMENTS
   INTEGER MEMOFF%# OFFSET FOR ADDRESSING MEMORY
   INTEGER AMEM%%# USE TO ADDRESS MEMORY
   CHARACTER PEEK%# LOOKAHEAD CHARACTER FOR ATOK
#-H- CMAP 138 1979 1221 844
 
COMMON /CMAP/ INMAP(64), OUTMAP(128)
   CHARACTER INMAP    # DISPLAY CODE TO ASCII MAP
   CHARACTER OUTMAP   # ASCII TO DISPLAY CODE MAP
#-H- CPFNS 360 1979 1221 844
# CPFNS -- PERMANENT FILE INFORMATION
COMMON /CPFNS/ SWITCH, PFN(4),TLFN,ID,CY,RP,KEYTAB(8)
   INTEGER SWITCH%# FILE BYTE SIZE SWITCH
   INTEGER PFN%%# PERMANENT FILE NAME
   INTEGER TLFN%%# LOGICAL FILE NAME
   INTEGER ID%%# PERMANENT FILE ID
   INTEGER CY%%# CYCLE NUMBER
   INTEGER RP%%# RETENTION PERIOD
   INTEGER KEYTAB%# OTHER PERMANENT FILE ATTRIBUTES
#-H- CIOSYS 229 1979 1221 844
COMMON /CIOSYS/ FDTAB(MAXFILES),FBKTAB(FBLEN,MAXFILES)
   INTEGER FDTAB%# POINTERS TO FILE BLOCKS
   INTEGER FBKTAB%# FILE BLOCKS
   INTEGER FILTAB(1)%# FOR SINGLE-DIMENSION ACCESS TO FBKTAB
   EQUIVALENCE (FBKTAB(1), FILTAB(1))
#-H- IODEFS 2281 1979 1221 845
# WARNING: IF YOU CHANGE THESE, YOU MUST CHANGE CORRESPONDING
#   MNEMONICS IN COMPASS ROUTINES OR YOU
#   WILL CAUSE THE APOCALYPSE!
 
DEFINE(MAXFILES,16)%# NUMBER OF OPENED FILES PERMITTED
DEFINE (FETLEN,5)%# LENGTH OF CYBER FET
DEFINE (MAXBUFSIZE,65)%# LENGTH OF CIRCULAR BUFFER
DEFINE (BINARYFILE,2B)%# BIT 1 IN FET, SET TO INDICATE BINARY FILE
DEFINE (FILENOTBUSY,1B) # BIT 0 IN FET, MUST BE SET WHEN OPEN
 
# FILE BLOCK FORMAT
DEFINE (BKSTART,1)%# START OF A FILE BLOCK
DEFINE (USECNT,1)%# USE COUNT
DEFINE (MODE,2)%%# OPEN MODE
DEFINE (MAPFLAG,3)%# -1 IF ASCII, 1 IF DISPLAY, 0 OTHERWISE
DEFINE (BUFSIZE,4)%# VALID SIZE OF I/O BUFFER
DEFINE (BYTESPERWORD,5) # NO. OF BYTES / WORD
DEFINE (CURRENTWORD,6)%# POINTER TO CURRENT WORD IN I/O BUFFER
DEFINE (CURRENTBYTE,7)%# POINTER TO CURRENT BYTE IN CURRENT WORD
DEFINE (BITSPERBYTE,8)%# NO. OF BITS / BYTE
DEFINE (EOFFLAG,9)%# NON-ZERO IF EOF ON LAST READ
DEFINE (COL1BLANK,10)%# NON-ZERO IF NEED CARRIAGE CONTROL
DEFINE (FETSTART,11)%# FIRST WORD OF FET (5 WORDS LONG)
DEFINE (BUFSTART,16)%# FIRST WORD OF I/O BUFFER (65 WORDS LONG)
DEFINE (FDBLOC,82)%# POINTER TO FDB IF PERMANENT FILE
DEFINE (FBLEN,100)%# LENGTH OF ONE FILE BLOCK
 
DEFINE (FDBLEN,17)%# LENGTH OF ONE FILE CONTROL BLOCK
DEFINE (FILBLK,1600)%# MAXFILES * FBLEN
 
DEFINE (IDKEY,14B)%# FDB CODE FOR ID
DEFINE (XRKEY,13B)%# FDB CODE FOR EXTEND PASSWORD
DEFINE (TKKEY,4B)%# FDB CODE FOR TURNKEY PASSWORD
DEFINE (PW1KEY,20B)%# FDB CODE FOR PASSWORD
DEFINE (PW2KEY,21B)%# FDB CODE FOR PASSWORD
DEFINE (RPKEY,2B)%# FDB CODE FOR RETENTION PERIOD
DEFINE (CYKEY,3B)%# FDB CODE FOR CYCLE NUMBER
DEFINE (MRKEY,11B)%# FDB CODE FOR MULTI-READ ACCESS
DEFINE (RDKEY,10B)%# FDB CODE FOR READ PASSWORD
 
DEFINE (ATTACH,1)%# PFN CMD IS AN ATTACH
DEFINE (CATALOG,2)%# PFN CMD IS A CATALOG
DEFINE (PURGE,3)%# PFN CMD IS PURGE
DEFINE (ALTER,4)%# PFN CMD IS ALTER
DEFINE (EXTEND,5)%# PFN CMD IS EXTEND
DEFINE (RENAME,6)%# PFN CMD IS RENAME
 
DEFINE(LFNMASK,77777777777777000000B)
DEFINE(KEYMASK,77777777777777777700B)
DEFINE(QRIGHT,1)%# IF WANT PACK AND RIGHT-JUSTIFIED
DEFINE(QLEFT,2)%%# IF WANT PACK AND LEFT-JUSTIFIED
 
DEFINE (MAXARG, 60)
DEFINE (COMADDR, 70B)           # ADDRESS OF COMMAND LINE STORAGE
 
DEFINE (LOCALFILE,1)%%# FILENAME IS LFN
DEFINE (PERMFILE,2)%%# FILENAME IS PFN
#-H- IODEFS.C 7700 1979 1221 845
*COMDECK IODEFS
* THE FOLLOWING DEFINED CONSTANTS ARE USED BY THE COMPASS PROGRAMS
*       IN THE RATFOR IO SYSTEM
 
MAXFILE EQU     16              . NUMBER OF FILES OPEN AT ONCE
FILBLK  EQU     1600            . SIZE OF FILE BLOCK TABLE
 
EOF     EQU     10003           .EOF FLAG USED IN RATFOR
ERR     EQU     10001           .ERR FLAG USED IN RATFOR
 
EOFVAL  EQU     20B             .MASK FOR EOF STATUS IN FET
 
BLANK   EQU     55B             .DISPLAY CODE BLANK
NEWLINE EQU     10              .ASCII NEW LINE
 
* THE FOLLOWING DEFINED CONSTANTS ARE THE OFFSETS INTO THE
*       FILE BLOCK.  THESE MUST MATCH EQUIVALENT ONES IN
*       IODEFS.
 
MAPFLAG EQU     3       .- IF ASCII,+ IF DISPLAY, 0 OTHERWISE
BUFSIZE EQU     4               .SIZE OF I/O BUFFER (WORDS)
BYTPWRD EQU     5               .# OF BYTES/WORD
CURWORD EQU     6               .WORD POINTER INTO IO BUFFER
CURBYTE EQU     7               .BYTE POINTER INTO CURWORD
BTSPBYT EQU     8               .# OF BITS/BYTE
EOFFLG  EQU     9               .NON-ZERO IF EOF ENCOUNTERED
COL1BLK EQU     10              .NON-ZERO IF CARRIAGE CONTROL NEEDED
FETSTRT EQU     11              .START OF FET (5 WORDS LONG)
BUFFRST EQU     12              .ADDR. OF FIRST WORD IN I/O BUFFER
BUFIN   EQU     13              .ADDR. OF FIRST FREE WORD IN I/O BUFFER
BUFOUT  EQU     14              .ADDR. OF LAST WORD USED IN I/O BUFFER
BUFLMIT EQU     15              .ADDR. OF LAST WORD IN I/O BUFFER
BUFSTRT EQU     16              .STARTOF I/O BUFFER (65 WORDS LONG)
FDBLOC  EQU     82%%.POINTER TO FDB BLOCK, IF PFN
FBEND   EQU     100              .LAST WORD IN FILE BLOCK
 
*  GETARGS -- MOVE ARGUMENTS OF READF/WRITEF INTO REGISTERS
 
GETARGS MACRO
        SA2     A1+B1           .MOVE ADDRESS OF N INTO X2
        SA3     A2+B1           .MOVE ADDRESS OF FD INTO X3
        SA2     X2              .MOVE N INTO X2
        SB6     X2              .. AND THEN TO B6
        BX6     X2              .. AND COPY INTO X6 (RETURNED VALUE)
        SA4     X3              .MOVE FD INTO X4
        SA5     X4+FDTAB        .LOAD ADDR OF FILE BLOCK INTO X5
        SX0     X5-1B           ..AND STORE BASE POINTER INTO X0
        ENDM                 # END OF MACRO GETARGS
 
*  GETPARS -- MOVE FILE DEPENDANT INFO. INTO B REGISTERS
 
GETPARS MACRO
        SA2     X0+BUFSIZE      .MOVE SIZE OF IO BUFFER INTO X2
        SB2     X2              .. AND STORE IN B2
        SA3     A2+B1           .MOVE BYTES/WORD INTO X3
        SB5     X3              .. AND STORE IN B5
        SA4     A3+B1           .MOVE CURRENT WORD PTR INTO X4
        SB3     X4              .. AND STORE IN B3
        SA5     A4+B1           .MOVE CURRENT BYTE PRT INTO X5
        SB4     X5              .. AND STORE IN B4
        ENDM                 # END OF MACRO GETPARS
 
*  SAVPARS -- SAVE BUFFER PARAMETERS WHICH MIGHT HAVE CHANGED
 
SAVPARS MACRO
        SX7     B3              .MOVE CURRENT WORD PTR INTO X7
        SA7     X0+CURWORD      .. AND SAVE IN FILE BLOCK
        SX7     B4              .MOVE CURRENT BYTE PTR INTO X7
        SA7     A7+B1           .. AND SAVE IN FILE BLOCK
        ENDM                 # END OF MACRO SAVPARS
 
*  GETBPB -- LOAD BITS/BYTE INTO X5 AND BITS/BYTE-1 INTO B7
 
GETBPB  MACRO
        SA5     X0+BTSPBYT      .MOVE BITS/BYTE INTO X5
        SB7     X5-1B           .. AND BITS/BYTE -1 INTO B7
        ENDM                 # END OF MACRO GETBPB
 
*  GETMAP -- LOAD MAPFLAG INTO X5
 
GETMAP  MACRO
        SA5     X0+MAPFLAG      .MOVE MAP FLAG INTO X5
        ENDM                 # END OF MACRO GETMAP
 
*  SAVBUF -- SAVE CURRENT BUFFER SIZE INTO FILE BLOCK
 
SAVBUF  MACRO
        SX7     B2              .MOVE BUFSIZE INTO X7
        SA7     X0+BUFSIZE      .. AND STORE INTO FILE BLOCK
        ENDM                 # END OF MACRO SAVBUF
 
*  SAVLIST -- SAVE A1 AND X1 IN A4 AND X4 (FOR PP CALL)
 
SAVLIST MACRO
        SA4     A1              .MOVE A1 TO A4
        BX4     X1              .MOVE X1 TO X4 (NOT = TO M[A4])
        BX5     X6               .MOVE N TO X6
        ENDM                 # END OF MACRO SAVLIST
 
*  GETLIST -- RESTOR A1 AND X1 FROM A4 AND X4 (AFTER PP CALL)
 
GETLIST MACRO
        SA1     A4              .MOVE A4 TO A1
        BX1     X4              .MOVE X4 TO X1 (NOT = TO M[A1])
        BX6     X5               .MOVE N BACK TO X6 (RETURN REG.)
        ENDM                 # END OF MACRO GETLIST
 
* RDPRU -- ISSUE PP CALL TO READ PRU INTO I/O BUFFER
 
RDPRU   MACRO
        SB7     X0+FETSTRT              #ADDRSS OF FET TO B7
        READ    B7,RECALL               #CALL PP WITH RECALL
        ENDM                         # END OF MACRO RDPRU
 
*  WRTPRU -- ISSUE PP CALL TO WRITE I/O BUFFER TO FILE
 
WRTPRU  MACRO
        SB7     X0+FETSTRT              #ADDRESS OF FET INTO B7
        WRITE   B7,RECALL               #CALL PP WITH RECALL
        ENDM                         # END OF MACRO WRTPRU
 
*  EOFCHK  -- CHECK FOR EOF, IF SO, RESET # OF BYTES READ, RETURN
 
EOFCHK  MACRO
        LOCAL   NOEOF
        SA5     X0+EOFFLG       .GET EOFFLG INTO X5
        ZR      X5,NOEOF        .SKIP IF NO EOF ON LAST READ
        SX3     B6               .LOAD # OF BYTES LEFT TO READ INTO X3
        IX6     X6-X3            .LOAD BYTES READ INTO X6
        SAVPARS                 .SAVE THE WORLD
        EQ      READF=          .. AND GO HOME
NOEOF   BSS     0               .ELSE JUST CONTINUE
        ENDM                 # END OF MACRO EOFCHK
 
*  READCHK -- CHECK READ FOR EOF OR ERROR
 
READCHK MACRO
        LOCAL   READEOF,NOEOI
        SA2     X0+FETSTRT      .GET FET STATUS WORD
        SX3     EOFVAL          .GET VALUE OF EOF STATUS
        BX7     X2*X3           .SEE IF EOF FLAG IS SET
        ZR      X7,NOEOI        ..AND SKIP IF NOT SET
 
READEOF BSS     0               .OK, DEFINITELY HAVE EOF
        SX7     EOF             .PLACE FLAG INTO
        SA7     X0+EOFFLG       .. FILE BLOCK
        SA3     X0+BUFIN        .LOAD BUFFERIN ADDR. INTO X3
        SA4     A3+B1           .LOAD BUFFEROUT ADDR. INTO X4
        IX7     X3-X4           .COMPUTE NEW BUFFER LENGTH
        SB2     X7              .RESET BUFSIZE REGISTER
        SA7     X0+BUFSIZE      .SAVE NEW BUFFER LENGTH
 
NOEOI   BSS     0               .FINISHED WITH READCHK
        ENDM                 # END OF MACRO READCHK
 
*  CLRBUF -- CLEAR I/O BUFFER BEFORE READ OR AFTER WRITE
 
CLRBUF  MACRO
        SA4     X0+BUFFRST      .GET START ADDRESS OF BUFFER
        BX7     X4              .. MOVE TO X7
        SA7     A4+B1           .RESET IN FIELD OF FET
        SA7     A7+B1           .RESET OUT FIELD OF FET
        SB4     B0              .RESET CURRENT BYTE
        SB3     B0              .RESET CURRENT WORD
        ENDM                 # END OF MACRO CLRBUF
 
*  WRITOUT -- EMPTY I/O BUFFER INTO FILE
 
WRITOUT MACRO
        SA4     X0+BUFLMIT      .GET LIMIT ADDR OF BUFFER INTO X4
        SX7     X4-1B           .. AND LIMIT INTO X7
        SA7     X0+BUFIN        .MARK BUFFER AS FULL
        SAVLIST                 .SAVE ARG LIST ADDR BEFORE WRITE
        WRTPRU                  .ISSUE WRITE AND WAIT FOR COMPLETION
        GETLIST                 .RESTORE ARG LIST ADDR
        CLRBUF                  .RESET BUFFER PTRS
        ENDM                 # END OF MACRO WRITOUT
 
*  READWRD -- MOVE FULL WORD FROM I/O BUFFER INTO USER BUFFER
 
READWRD MACRO
        BX7     X2              .MOVE WORD TO BE RETURNED
        SA7     X1              .STORE INTO USER BUFFER
        SX1     X1+B1           .UPDATE USER BUFFER POINTER
        SB3     B3+B1           .INCREMENT CURRENT WORD PTR
        SB6     B6-B1           .DECREMENT BYTES LEFT TO READ
        ENDM                 # END OF MACRO READWRD
#-H- RATDEF 3143 1979 1221 845
 
#========== STANDARD RATFOR DEFINITIONS ==========
 
DEFINE(ALPHA,10100)
DEFINE(AND,38)
DEFINE(ANDIF,IF)
DEFINE(ARB,100)
DEFINE(ATSIGN,64)
DEFINE(BACKSLASH,92)
DEFINE(BACKSPACE,8)
DEFINE(BANG,33)
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(BLANK,32)
DEFINE(CARET,94)
DEFINE(COLON,58)
DEFINE(COMMA,44)
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(DIGIT,2)
DEFINE(DOLLAR,36)
DEFINE(DQUOTE,34)
DEFINE(EOF,10003)
DEFINE(EOS,10002)
DEFINE(EQUALS,61)
DEFINE(ERR,10001)
DEFINE(ERROUT,2)
DEFINE(GREATER,62)
DEFINE(HUGE,30000)
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(LETTER,1)
DEFINE(LETU,117)
DEFINE(LETV,118)
DEFINE(LETW,119)
DEFINE(LETX,120)
DEFINE(LETY,121)
DEFINE(LETZ,122)
DEFINE(LPAREN,40)
DEFINE(MAXCHARS,10)
DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH
DEFINE(MAXNAME,30)   %# TYPICAL FILE NAME SIZE
DEFINE(MINUS,45)
DEFINE(NEWLINE,10)
DEFINE(NO,0)
DEFINE(NOERR,0)
DEFINE(NOT,126)   # SAME AS TILDE
DEFINE(OK,-2)
DEFINE(OR,BAR)   # SAME AS BAR
DEFINE(PERCENT,37)
DEFINE(PERIOD,46)
DEFINE(PLUS,43)
DEFINE(QMARK,63)
DEFINE(RBRACE,125)
DEFINE(RBRACK,93)
DEFINE(READ,0)
DEFINE(READWRITE,2)
DEFINE(RPAREN,41)
DEFINE(SEMICOL,59)
DEFINE(SHARP,35)
DEFINE(SLASH,47)
DEFINE(SQUOTE,39)
DEFINE(STAR,42)
DEFINE(STDIN,0)
DEFINE(STDOUT,1)
DEFINE(STDERR,ERROUT)
DEFINE(TAB,9)
DEFINE(TILDE,126)
DEFINE(UNDERLINE,95)
DEFINE(WRITE,1)
DEFINE(YES,1)
DEFINE(CHARACTER,INTEGER)
DEFINE(ABS,IABS)
DEFINE(MIN,MIN0)
DEFINE(MAX,MAX0)
 
# HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE
DEFINE(BPI,36)%%# BITS PER INTEGER
DEFINE(BPC,7)%%# BITS PER CHARACTER
DEFINE(CPI,5)%%# CHARACTERS PER INTEGER
DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER
DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN)
DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN)
DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL
# THE FOLLOWING ARE CYBER-DEPENDANT DEFINITIONS
 
DEFINE(BPI,60)%%# BITS PER INTEGER
DEFINE(BPC,12)%%# BITS PER CHARACTER
DEFINE(CPI,5)%%# CHARACTERS PER INTEGER
DEFINE(LIMIT,140737488355327)%# LARGEST POSITIVE INTEGER
DEFINE(LIM1,322)%%# MAXIMUM EXPONENT (POWER OF TEN)
DEFINE(LIM2,-293)%%# MINIMUM EXPONENT (POWER OF TEN)
DEFINE(PRECISION,14)%%# DIGITS ACCURATE IN REAL
DEFINE(MAXLINE,200)%%# LINE LENGTH ON CYBER OUTPUT (TYPICAL)
DEFINE(MAXCHARS,30)%%# HANDY-DANDY BUFFER SIZE FOR INTEGERS
#========== LIBRARY OF USEFUL RATFOR ROUTINES ==========
#-H- ADDSET.RAT 289 1980 103 2153
INCLUDE MDEF
 
# ADDSET - PUT  C  IN  SET(J)  IF IT FITS,  INCREMENT  J
   INTEGER FUNCTION ADDSET(C, SET, J, MAXSIZ)
   INTEGER J, MAXSIZ
   CHARACTER C, SET(ARB)
 
   IF (J > MAXSIZ)
      ADDSET = NO
   ELSE <
      SET(J) = C
      J = J + 1
      ADDSET = YES
      !
   RETURN
   END
#-H- ADDSTR.RAT 352 1980 103 2153
INCLUDE MDEF
 
# ADDSTR - ADD S TO STR(J) IF IT FITS, INCREMENT J
   INTEGER FUNCTION ADDSTR(S, STR, J, MAXSIZ)
   CHARACTER S(ARB), STR(ARB)
   INTEGER J, 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
#-H- ALLDIG.RAT 318 1980 103 2153
INCLUDE RATDEF
 
# ALLDIG - RETURN YES IF STR IS ALL DIGITS
   INTEGER FUNCTION ALLDIG(STR)
   CHARACTER TYPE
   CHARACTER STR(ARB)
   INTEGER I
 
   ALLDIG = NO
   IF (STR(1) == EOS)
      RETURN
   FOR (I = 1; STR(I) ^= EOS; I = I + 1)
      IF (TYPE(STR(I)) ^= DIGIT)
         RETURN
   ALLDIG = YES
   RETURN
   END
#-H- AMATCH.RAT 1455 1980 103 2153
INCLUDE MDEF
 
# AMATCH  (NON-RECURSIVE) - LOOK FOR MATCH STARTING AT LIN(FROM)
   INTEGER FUNCTION AMATCH(LIN, FROM, PAT)
   CHARACTER LIN(MAXLINE), PAT(MAXPAT)
   INTEGER OMATCH, PATSIZ
   INTEGER FROM, I, J, K, OFFSET, STACK
   INCLUDE CSUBS
 
   STACK = 0
   OFFSET = FROM      # NEXT UNEXAMINED INPUT CHARACTER
   FOR (J = 1; J <= MAXSUBS; J = J + 1) <%# CLEAR PARTIAL MATCH RESULTS
      BPOS(J) = OFFSET
      EPOS(J) = OFFSET
      !
   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 (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
   EPOS(1) = OFFSET
   AMATCH = OFFSET
   RETURN      # SUCCESS
   END
#-H- CANT.RAT 187 1980 103 2153
INCLUDE RATDEF
 
# CANT - PRINT CANT OPEN FILE MESSAGE AND DIE
   SUBROUTINE CANT(BUF)
   INTEGER BUF(MAXLINE)
 
   CALL PUTLIN(BUF, ERROUT)
   CALL REMARK(": CAN'T OPEN.")
   STOP
   END
#-H- CATSUB.RAT 674 1980 103 2153
INCLUDE MDEF
 
# CATSUB - ADD REPLACEMENT TEXT TO END OF  NEW
   SUBROUTINE CATSUB(LIN, FROM, TO, SUB, NEW, K, MAXNEW)
   INTEGER ADDSET
   INTEGER FROM, I, J, JUNK, K, MAXNEW, TO
   CHARACTER LIN(MAXLINE), NEW(MAXNEW), SUB(MAXPAT)
   INCLUDE CSUBS
 
   FOR (I = 1; SUB(I) ^= EOS; I = I + 1)
      IF (SUB(I) == DITTO)
         FOR (J = FROM; J < TO; J = J + 1)
            JUNK = ADDSET(LIN(J), NEW, K, MAXNEW)
      ELSE IF (SUB(I) == DITTO1) <
         L = SUB(I+1)
         FOR (J = BPOS(L); J < EPOS(L); J = J + 1)
            JUNK = ADDSET(LIN(J), NEW, K, MAXNEW)
         I = I + 1
         !
      ELSE
         JUNK = ADDSET(SUB(I), NEW, K, MAXNEW)
   RETURN
   END
#-H- COMPAR.RAT 130 1980 103 2153
# COMPAR - RETURN <0 IF X < Y, 0 IF X == Y, >0 IF X > Y
   INTEGER FUNCTION COMPAR(X, Y)
   INTEGER X, Y
 
   RETURN(X - Y)
   END
#-H- CSUBS 144 1980 103 2153
COMMON /CSUBS/ BPOS(MAXSUBS), EPOS(MAXSUBS)
   INTEGER BPOS%%# BEGINNING OF PARTIAL MATCH
   INTEGER EPOS%%# END OF CORRESPONDING PARTIAL MATCH
#-H- CTOF.RAT 1290 1980 103 2153
INCLUDE RATDEF
 
# CTOF - CONVERT STRING AT IN(I) TO REAL, INCREMENT I
   REAL FUNCTION CTOF(IN, I)
   CHARACTER IN(ARB)
   INTEGER CTOI
   INTEGER I, A, E, S
   REAL TEN, FLOAT
 
   WHILE (IN(I) == BLANK \ IN(I) == TAB)
      I = I + 1
   IF (IN(I) == MINUS \ IN(I) == PLUS) <
      S = IN(I)
      I = I + 1
      !
   ELSE
      S = NO
   E = 0
   FOR (A = 0; IN(I) ^= EOS; I = I + 1) <  # COLLECT INTEGER PORTION
      IF (IN(I) < DIG0 \ IN(I) > DIG9)      # NON-DIGIT
         BREAK
      IF (A < LIMIT)
         A = 10*A + IN(I) - DIG0
      ELSE
         E = E + 1  # JUST BUMP EXPONENT
      !
   IF (IN(I) == PERIOD)
      FOR (I = I + 1; IN(I) ^= EOS; I = I + 1) <  # COLLECT FRACTION
         IF (IN(I) < DIG0 \ IN(I) > DIG9)      # NON-DIGIT
            BREAK
         IF (A < LIMIT) <
            A = 10*A + IN(I) - DIG0
            E = E - 1
            !
         !
   IF (IN(I) == LETE \ IN(I) == BIGE) <
      I = I + 1         # COLLECT EXPONENT
      E = E + CTOI(IN, I)
      !
   IF (E < LIM2)
      CTOF = 0.0
   ELSE IF (E > LIM1)
      CTOF = TEN(LIM1)
   ELSE <
      IF (S == MINUS)
          A = -A
      IF (E < 0)
         CTOF = FLOAT(A)/TEN(-E)
      ELSE IF (E > 0)
         CTOF = FLOAT(A)*TEN(E)
      ELSE
         CTOF = FLOAT(A)
      !
   RETURN
   END
#-H- CTOI.RAT 520 1980 103 2153
INCLUDE RATDEF
 
# CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I
   INTEGER FUNCTION CTOI(IN, I)
   CHARACTER IN(ARB)
   INTEGER I, S
 
   WHILE (IN(I) == BLANK \ IN(I) == TAB)
      I = I + 1
   IF (IN(I) == MINUS \ IN(I) == PLUS) <
      S = IN(I)
      I = I + 1
      !
   ELSE
      S = NO
   FOR (CTOI = 0; IN(I) ^= EOS; I = I + 1) <
      IF (IN(I) < DIG0 \ IN(I) > DIG9)      # NON-DIGIT
         BREAK
      CTOI = 10 * CTOI + IN(I) - DIG0
      !
   IF (S == MINUS)
      CTOI = -CTOI
   RETURN
   END
#-H- CTOO.RAT 391 1980 103 2153
INCLUDE RATDEF
 
# CTOO - CONVERT STRING AT IN(I) TO OCTAL INTEGER, INCREMENT I
   INTEGER FUNCTION CTOO(IN, I)
   CHARACTER IN(ARB)
   INTEGER I, S
 
   WHILE (IN(I) == BLANK \ IN(I) == TAB)
      I = I + 1
   FOR (CTOO = 0; IN(I) ^= EOS; I = I + 1) <
      IF (IN(I) < DIG0 \ IN(I) > DIG7)      # NON OCTAL DIGIT
         BREAK
      CTOO = 8 * CTOO + IN(I) - DIG0
      !
   RETURN
   END
#-H- DATE.RAT 179 1980 103 2153
INCLUDE RATDEF
 
# DATE - RETURN DATE IN  N  AND AS FUNCTION VALUE
   INTEGER FUNCTION DATE(N)
   INTEGER N
   INTEGER JUNK
 
   CALL DATE4(N, JUNK, JUNK, JUNK)
   RETURN(N)
   END
#-H- DODASH.RAT 371 1980 103 2153
INCLUDE MDEF
 
# DODASH - EXPAND ARRAY(I-1)-ARRAY(I+1) INTO SET(J)...
   SUBROUTINE DODASH(ARRAY, I, SET, J, MAXSET)
   CHARACTER ESC
   INTEGER ADDSET
   INTEGER I, J, JUNK, K, LIM, MAXSET
   CHARACTER ARRAY(ARB), SET(ARB)
 
   I = I + 1
   J = J - 1
   LIM = ESC(ARRAY, I)
   FOR (K = SET(J); K <= LIM; K = K + 1)
      JUNK = ADDSET(K, SET, J, MAXSET)
   RETURN
   END
#-H- DTOC.RAT 689 1980 103 2153
INCLUDE RATDEF
 
# DTOC - CONVERT DATE, YEAR TO CHARACTER STRING A(1)...A(SIZE)
   INTEGER FUNCTION DTOC(DATE, YEAR, A, SIZE)
   INTEGER DATE, YEAR, SIZE
   CHARACTER A(ARB)
   INTEGER I, LENGTH, ITOC
   STRING MONTHS "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
 
   A(1) = EOS
   IF (SIZE >= 4) <%# INSERT MONTH
      I = 3*(DATE/100 - 1)
      A(1) = MONTHS(I+1)
      A(2) = MONTHS(I+2)
      A(3) = MONTHS(I+3)
      A(4) = EOS
      !
   IF (SIZE >= 7) <%# INSERT DAY
      A(4) = BLANK
      I = ITOC(MOD(DATE, 100), A(5), 3) + 5
      !
   IF (SIZE >= 13) <%# INSERT YEAR
      A(I) = COMMA
      A(I+1) = BLANK
      I = ITOC(YEAR, A(I+2), 5)
      !
   DTOC = LENGTH(A)
   RETURN
   END
#-H- EQUAL.RAT 319 1980 103 2153
INCLUDE RATDEF
 
# 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) <
         EQUAL = YES
         RETURN
         !
   EQUAL = NO
   RETURN
   END
#-H- ESC.RAT 794 1980 103 2153
INCLUDE MDEF
 
# 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 IF (ARRAY(I) == LETB \ ARRAY(I) == BIGB)
         ESC = BACKSPACE
      ELSE IF (ARRAY(I) >= DIG0 & ARRAY(I) <= DIG7) <
         FOR (ESC = 0; ARRAY(I) >= DIG0 & ARRAY(I) <= DIG7; I = I + 1)
            ESC = 8*ESC + ARRAY(I) - DIG0
         I = I - 1%# SO LIKE OTHER CASES
         !
      ELSE
         ESC = ARRAY(I)
      !
   RETURN
   END
#-H- FCOPY.RAT 199 1980 103 2154
INCLUDE RATDEF
 
# FCOPY - COPY FILE  IN  TO FILE  OUT
   SUBROUTINE FCOPY(IN, OUT)
   CHARACTER C, GETCH
   INTEGER IN, OUT
 
   WHILE (GETCH(C, IN) ^= EOF)
      CALL PUTCH(C, OUT)
   RETURN
   END
#-H- FILSET.RAT 644 1980 103 2154
INCLUDE MDEF
 
# FILSET - EXPAND SET AT  ARRAY(I)  INTO  SET(J),  STOP AT  DELIM
   SUBROUTINE FILSET(DELIM, ARRAY, I, SET, J, MAXSET)
   CHARACTER ESC
   INTEGER ADDSET
   INTEGER I, J, JUNK, MAXSET
   CHARACTER ARRAY(ARB), DELIM, SET(ARB)
 
   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
         CALL DODASH(ARRAY, I, SET, J, MAXSET)
   RETURN
   END
#-H- FOLD.RAT 470 1980 103 2154
INCLUDE RATDEF
 
# FOLD - CONVERT ALPHABETIC TOKEN TO SINGLE CASE
   SUBROUTINE FOLD(TOKEN)
   CHARACTER TOKEN(ARB)
   INTEGER I
 
   # WARNING - THIS ROUTINE DEPENDS HEAVILY ON THE
   # FACT THAT LETTERS HAVE BEEN MAPPED INTO INTERNAL
   # RIGHT-ADJUSTED ASCII. GOD HELP YOU IF YOU
   # HAVE SUBVERTED THIS MECHANISM.
 
   FOR (I = 1; TOKEN(I) ^= EOS; I = I + 1)
      IF (TOKEN(I) >= BIGA & TOKEN(I) <= BIGZ)
         TOKEN(I) = TOKEN(I) - BIGA + LETA
   RETURN
   END
#-H- FSIZEC.RAT 357 1980 103 2154
INCLUDE RATDEF
 
# FSIZEC - SIZE OF FILE IN CHARACTERS
   INTEGER FUNCTION FSIZEC(NAME)
   CHARACTER GETCH
   CHARACTER C, NAME(ARB)
   INTEGER OPEN
   INTEGER FD
 
   FD = OPEN(NAME, READ)
   IF (FD == ERR)
      FSIZEC = -1
   ELSE <
      FOR (FSIZEC = 0; GETCH(C, FD) ^= EOF; FSIZEC = FSIZEC + 1)
         ;
      CALL CLOSE(FD)
      !
   RETURN
   END
#-H- FTOC.RAT 1485 1980 103 2154
INCLUDE RATDEF
 
# FTOC - CONVERT REAL  X  TO STRING IN  STR  USING PRECISION  P
   INTEGER FUNCTION FTOC(X, STR, P, SIZE)
   CHARACTER STR(ARB)
   REAL X
   INTEGER P, SIZE
   INTEGER I, J, N, ITOC, NDIGS, IFIX, IABS, MOD, EFLAG, E, LEN
   REAL XVAL, TEN, FLOAT, ALOG10
 
   XVAL = X
   IF (XVAL < 0.0)
      XVAL = -XVAL
   LEN = SIZE
   IF (XVAL > 1.0E5 \ XVAL > 0.0 & XVAL < 1.0E-4 \ P < 0) <
      E = IFIX(ALOG10(XVAL))%%# FORCE E FORMAT
      IF (E > 0)
         XVAL = XVAL/TEN(E)
      ELSE
         XVAL = XVAL*TEN(-E)
      FOR ( ; XVAL < 1.0; E = E - 1)
         XVAL = 10.0*XVAL
      FOR ( ; XVAL > 10.0; E = E + 1)
         XVAL = 0.1*XVAL
      EFLAG = YES
      LEN = LEN - 4   # GUARANTEE ENOUGH SPACE
      !
   ELSE
      EFLAG = NO
   NDIGS = IABS(P)
   IF (NDIGS > PRECISION)
      NDIGS = PRECISION
   ELSE IF (NDIGS < 1)
      NDIGS = 1
   XVAL = XVAL + 0.5/TEN(NDIGS)%# ROUND
   IF (X < 0.0) <
      STR(1) = MINUS
      I = 2
      !
   ELSE
      I = 1
   I = I + ITOC(IFIX(XVAL), STR(I), LEN)
   IF (P ^= 0) <
      STR(I) = PERIOD
      I = I + 1
      N = IFIX(TEN(NDIGS)*(XVAL-FLOAT(IFIX(XVAL))))
      FOR (J = I + NDIGS - 1; J >= I; J = J - 1) <  # CONVERT FRACTION
         IF (J < LEN)
            STR(J) = MOD(N, 10) + DIG0
         N = N/10
         !
      I = I + NDIGS
      !
   IF (EFLAG == YES) <  # NEED TO ADD EXPONENT
      STR(I) = LETE
      I = I + 1 + ITOC(E, STR(I+1), LEN-I-1)
      !
   STR(I) = EOS
   FTOC = I - 1
   RETURN
   END
#-H- GETC.RAT 169 1980 103 2154
INCLUDE RATDEF
 
# GETC - GET NEXT CHARACTER FROM STANDARD INPUT
   CHARACTER FUNCTION GETC(C)
   CHARACTER C, GETCH
 
   C = GETCH(C, STDIN)
   GETC = C
   RETURN
   END
#-H- GETCCL.RAT 631 1980 103 2154
INCLUDE MDEF
 
# GETCCL - EXPAND CHAR CLASS AT ARG(I) INTO PAT(J)
   INTEGER FUNCTION GETCCL(ARG, I, PAT, J)
   CHARACTER ARG(MAXARG), PAT(MAXPAT)
   INTEGER ADDSET
   INTEGER I, J, JSTART, JUNK
 
   I = I + 1      # SKIP OVER [
   IF (ARG(I) == TILDE \ ARG(I) == CARET) <
      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
#-H- GETLIN.RAT 463 1980 103 2154
INCLUDE RATDEF
 
# GETLIN - GET NEXT LINE FROM  F  INTO  LINE
   INTEGER FUNCTION GETLIN(LINE, F)
   CHARACTER LINE(MAXLINE), C, GETCH
   INTEGER F
 
   FOR (GETLIN = 0; GETCH(C, F) ^= EOF; ) <
      IF (C == 0)
         BREAK
      IF (GETLIN < MAXLINE - 1) <
         GETLIN = GETLIN + 1
         LINE(GETLIN) = C
         !
      IF (C == NEWLINE)
         BREAK
      !
   LINE(GETLIN+1) = EOS
   IF (GETLIN == 0 & C == EOF)
      GETLIN = EOF
   RETURN
   END
#-H- GETPAT.RAT 202 1980 103 2154
INCLUDE MDEF
 
# GETPAT - CONVERT ARGUMENT INTO PATTERN
   INTEGER FUNCTION GETPAT(ARG, PAT)
   INTEGER ARG(MAXARG), PAT(MAXPAT)
   INTEGER MAKPAT
 
   GETPAT = MAKPAT(ARG, 1, EOS, PAT)
   RETURN
   END
#-H- GETSUB.RAT 208 1980 103 2154
INCLUDE MDEF
 
# GETSUB - GET SUBSTITUTION PATTERN INTO SUB
   INTEGER FUNCTION GETSUB(ARG, SUB)
   CHARACTER ARG(MAXARG), SUB(MAXPAT)
   INTEGER MAKSUB
 
   GETSUB = MAKSUB(ARG, 1, EOS, SUB)
   RETURN
   END
#-H- GETWRD.RAT 413 1980 103 2154
INCLUDE RATDEF
 
# GETWRD - GET NON-BLANK WORD FROM IN(I) INTO  OUT, INCREMENT I
   INTEGER FUNCTION GETWRD(IN, I, OUT)
   INTEGER IN(ARB), OUT(ARB)
   INTEGER I, 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
#-H- INDEX.RAT 251 1980 103 2154
INCLUDE RATDEF
 
# INDEX - FIND CHARACTER  C  IN STRING  STR
   INTEGER FUNCTION INDEX(STR, C)
   CHARACTER C, STR(ARB)
 
   FOR (INDEX = 1; STR(INDEX) ^= EOS; INDEX = INDEX + 1)
      IF (STR(INDEX) == C)
         RETURN
   INDEX = 0
   RETURN
   END
#-H- INDEXS.RAT 393 1980 103 2154
INCLUDE RATDEF
 
# INDEXS - FIND FIRST OCCURRENCE OF STR IN LIN
   INTEGER FUNCTION INDEXS(LIN, STR)
   CHARACTER LIN(ARB), STR(ARB)
   INTEGER J
 
   FOR (INDEXS = 1; LIN(INDEXS) ^= EOS; INDEXS = INDEXS + 1) <
      FOR (J = 1; STR(J) == LIN(J+INDEXS-1); J = J + 1)
         IF (STR(J) == EOS)
            RETURN
      IF (STR(J) == EOS)
         RETURN
      !
   INDEXS = 0
   RETURN
   END
#-H- ITOC.RAT 675 1980 103 2154
INCLUDE RATDEF
 
 
DEFINE(ABS,IABS)
# ITOC - CONVERT INTEGER  INT  TO CHAR STRING IN  STR
   INTEGER FUNCTION ITOC(INT, STR, SIZE)
   INTEGER ABS, MOD
   INTEGER I, INT, INTVAL, J, K, SIZE
   CHARACTER STR(ARB)
 
   INTVAL = ABS(INT)
   STR(1) = EOS
   I = 1
   REPEAT <            # GENERATE DIGITS
      I = I + 1
      STR(I) = DIG0 + MOD(INTVAL,10)
      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
#-H- LENGTH.RAT 194 1980 103 2154
INCLUDE RATDEF
 
# LENGTH - COMPUTE LENGTH OF STRING
   INTEGER FUNCTION LENGTH(STR)
   INTEGER STR(ARB)
 
   FOR (LENGTH = 0; STR(LENGTH+1) ^= EOS; LENGTH = LENGTH + 1)
      ;
   RETURN
   END
#-H- LOCATE.RAT 378 1980 103 2154
INCLUDE MDEF
 
# LOCATE - LOOK FOR C IN CHAR CLASS AT PAT(OFFSET)
   INTEGER FUNCTION LOCATE(C, PAT, OFFSET)
   CHARACTER C, PAT(MAXPAT)
   INTEGER I, OFFSET
   # SIZE OF CLASS IS AT PAT(OFFSET), CHARACTERS FOLLOW
 
   FOR (I = OFFSET + PAT(OFFSET); I > OFFSET; I = I - 1)
      IF (C == PAT(I)) <
         LOCATE = YES
         RETURN
         !
   LOCATE = NO
   RETURN
   END
#-H- MAKPAT.RAT 2009 1980 103 2154
INCLUDE MDEF
 
# MAKPAT - MAKE PATTERN FROM ARG(FROM), TERMINATE AT DELIM
   INTEGER FUNCTION MAKPAT(ARG, FROM, DELIM, PAT)
   CHARACTER ESC
   CHARACTER ARG(MAXARG), DELIM, PAT(MAXPAT)
   INTEGER ADDSET, GETCCL, STCLOS
   INTEGER FROM, I, J, JUNK, LASTCL, LASTJ, LJ, NSUBS, SP, SUBSTK(MAXSUBS)
 
   J = 1      # PAT INDEX
   LASTJ = 1
   LASTCL = 0
   NSUBS = 0%# COUNTS NUMBER OF @(@) PAIRS
   SP = 0%# STACK POINTER FOR SUBSTK
   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)
            BREAK
         !
      ELSE IF (ARG(I) == CLOSURE & I > FROM) <
         LJ = LASTJ
         IF (PAT(LJ)==BOL \ PAT(LJ)==EOL \ PAT(LJ)==CLOSURE \
             PAT(LJ-1) == BOSS \ PAT(LJ-1) == EOSS)
                BREAK
         LASTCL = STCLOS(PAT, J, LASTJ, LASTCL)
         !
      ELSE IF (ARG(I) == ESCAPE & ARG(I+1) == LPAREN) <
         NSUBS = NSUBS + 1
         IF (NSUBS >= MAXSUBS)
            BREAK
         JUNK = ADDSET(BOSS, PAT, J, MAXPAT)
         JUNK = ADDSET(NSUBS, PAT, J, MAXPAT)
         SP = SP + 1
         SUBSTK(SP) = NSUBS
         I = I + 1
         !
      ELSE IF (ARG(I) == ESCAPE & ARG(I+1) == RPAREN) <
         IF (SP <= 0)
            BREAK
         JUNK = ADDSET(EOSS, PAT, J, MAXPAT)
         JUNK = ADDSET(SUBSTK(SP), PAT, J, MAXPAT)
         SP = SP - 1
         I = I + 1
         !
      ELSE <
         JUNK = ADDSET(CHAR, PAT, J, MAXPAT)
         JUNK = ADDSET(ESC(ARG, I), PAT, J, MAXPAT)
         !
      LASTJ = LJ
      !
   IF (ARG(I) ^= DELIM \ SP ^= 0)   # TERMINATED EARLY
      MAKPAT = ERR
   ELSE IF (ADDSET(EOS, PAT, J, MAXPAT) == NO)   # NO ROOM
      MAKPAT = ERR
   ELSE
      MAKPAT = I
   RETURN
   END
#-H- MAKSUB.RAT 834 1980 103 2154
INCLUDE MDEF
 
# MAKSUB - MAKE SUBSTITUTION STRING IN SUB
   INTEGER FUNCTION MAKSUB(ARG, FROM, DELIM, SUB)
   CHARACTER ESC
   CHARACTER ARG(MAXARG), DELIM, SUB(MAXPAT)
   INTEGER ADDSET
   INTEGER FROM, I, J, JUNK
 
   J = 1
   FOR (I = FROM; ARG(I) ^= DELIM & ARG(I) ^= EOS; I = I + 1)
      IF (ARG(I) == AND)
         JUNK = ADDSET(DITTO, SUB, J, MAXPAT)
      ELSE IF (ARG(I) == ESCAPE & (ARG(I+1) >= DIG0 & ARG(I+1) <= DIG9)) <
         K = ARG(I+1) - DIG0
         JUNK = ADDSET(DITTO1, SUB, J, MAXPAT)
         JUNK = ADDSET(K + 1, SUB, J, MAXPAT)
         I = I + 1
         !
      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
#-H- MATCH.RAT 489 1980 103 2154
INCLUDE MDEF
 
# MATCH - FIND MATCH ANYWHERE ON LINE
   INTEGER FUNCTION MATCH(LIN, PAT)
   CHARACTER LIN(MAXLINE), PAT(MAXPAT)
   INTEGER AMATCH
   INTEGER I
 
   IF (PAT(1) == BOL) <%%# ANCHORED MATCH
      IF (AMATCH(LIN, 1, PAT) > 0) <
         MATCH = YES
         RETURN
         !
      !
   ELSE%%# UNANCHORED
      FOR (I = 1; LIN(I) ^= EOS; I = I + 1)
         IF (AMATCH(LIN, I, PAT) > 0) <
            MATCH = YES
            RETURN
            !
   MATCH = NO
   RETURN
   END
#-H- MDEF 427 1980 103 2154
INCLUDE RATDEF
DEFINE(MAXPAT,128)
DEFINE(MAXARG,128)
DEFINE(MAXSUBS,10)
 
DEFINE(COUNT,1)
DEFINE(PREVCL,2)
DEFINE(START,3)
DEFINE(CLOSIZE,4)
 
DEFINE(BOL,PERCENT)
DEFINE(ANY,QMARK)
DEFINE(EOL,DOLLAR)
DEFINE(CLOSURE,STAR)
DEFINE(CCL,LBRACK)
DEFINE(CCLEND,RBRACK)
DEFINE(NCCL,LETN)
DEFINE(CHAR,LETA)
DEFINE(ESCAPE,ATSIGN)
DEFINE(DASH,MINUS)
DEFINE(BOSS,LBRACE)%# <
DEFINE(EOSS,RBRACE)%# !
 
DEFINE(DITTO,(-3))
DEFINE(DITTO1,(-4))
#-H- OMATCH.RAT 1149 1980 103 2154
INCLUDE MDEF
 
# OMATCH - TRY TO MATCH A SINGLE PATTERN AT PAT(J)
   INTEGER FUNCTION OMATCH(LIN, I, PAT, J)
   CHARACTER LIN(MAXLINE), PAT(MAXPAT)
   INTEGER LOCATE
   INTEGER BUMP, I, J
   INCLUDE CSUBS
 
   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 \ LIN(I) == EOS)
         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 IF (PAT(J) == BOSS) <
      K = PAT(J+1)
      BPOS(K+1) = I
      BUMP = 0
      !
   ELSE IF (PAT(J) == EOSS) <
      K = PAT(J+1)
      EPOS(K+1) = I
      BUMP = 0
      !
   ELSE
      CALL ERROR("IN OMATCH: CAN'T HAPPEN.")
   IF (BUMP >= 0) <
      I = I + BUMP
      OMATCH = YES
      !
   RETURN
   END
#-H- PATSIZ.RAT 504 1980 103 2154
INCLUDE MDEF
 
# 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) == BOSS \ PAT(N) == EOSS)
      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
#-H- PUTC.RAT 145 1980 103 2154
INCLUDE RATDEF
 
# PUTC - PUT CHARACTER  C  TO STANDARD OUTPUT FILE
   SUBROUTINE PUTC(C)
   INTEGER C
 
   CALL PUTCH(C, STDOUT)
   RETURN
   END
#-H- PUTDEC.RAT 172 1980 103 2154
INCLUDE RATDEF
 
# PUTDEC - PUT DECIMAL INTEGER  N  IN FIELD WIDTH >= W  TO STDOUT
   SUBROUTINE PUTDEC(N, W)
   INTEGER N, W
 
   CALL PUTINT(N, W, STDOUT)
   RETURN
   END
#-H- PUTINT.RAT 272 1980 103 2154
INCLUDE RATDEF
 
# PUTINT - WRITE DECIMAL INTEGER  N  IN FIELD WIDTH >= W  TO  F
   SUBROUTINE PUTINT(N, W, F)
   INTEGER N, W, F
   CHARACTER CHARS(MAXCHARS)
   INTEGER ITOC
   INTEGER JUNK
 
   JUNK = ITOC(N, CHARS, MAXCHARS)
   CALL PUTSTR(CHARS, W, F)
   RETURN
   END
#-H- PUTLIN.RAT 220 1980 103 2154
INCLUDE RATDEF
 
# PUTLIN - WRITE STRING  LINE  TO FILE  F
   SUBROUTINE PUTLIN(LINE, F)
   CHARACTER LINE(MAXLINE)
   INTEGER F, I
 
   FOR (I = 1; LINE(I) ^= EOS; I = I + 1)
      CALL PUTCH(LINE(I), F)
   RETURN
   END
#-H- PUTSTR.RAT 446 1980 103 2154
INCLUDE RATDEF
 
# PUTSTR - WRITE STRING  STR  TO FILE  F  IN FIELD WIDTH >= W
   SUBROUTINE PUTSTR(STR, W, F)
   CHARACTER STR(MAXLINE)
   INTEGER W, F, LEN, I, LENGTH
 
   LEN = LENGTH(STR)
   FOR (I = LEN; I < W; I = I + 1)%# OUTPUT LEFT PADDING
      CALL PUTCH(BLANK, F)
   FOR (I = 1; STR(I) ^= EOS; I = I + 1)
      CALL PUTCH(STR(I), F)
   FOR (I = LEN; I < -W; I = I + 1)%# OUTPUT RIGHT PADDING
      CALL PUTCH(BLANK, F)
   RETURN
   END
#-H- QSORT.RAT 1421 1980 103 2154
INCLUDE RATDEF
 
# QSORT - SORTS A INTO ASCENDING ORDER; COMPARISONS ARE DONE BY COMPAR
# COMPAR(X,Y) MUST RETURN <0 IF X < Y, 0 IF X == Y, AND >0 IF X > Y.
   SUBROUTINE QSORT(N, A, COMPAR)
   INTEGER N, A(ARB)
   EXTERNAL COMPAR
   INTEGER COMPAR
   INTEGER I, J, LV(20), P, PIVOT, UV(20), T
 
   LV(1) = 1
   UV(1) = N
   P = 1
   WHILE (P > 0)
      IF (LV(P) >= UV(P))      # ONLY ONE ELEMENT IN THIS SUBSET
         P = P - 1      # POP STACK
      ELSE <
         I = LV(P) - 1
         J = UV(P)
         PIVOT = A(J)    # PIVOT ELEMENT
         WHILE (I < J) <
            FOR (I=I+1; COMPAR(A(I), PIVOT) < 0; I=I+1)
               ;
            FOR (J = J - 1; J > I; J = J - 1)
               IF (COMPAR(A(J), PIVOT) <= 0)
                  BREAK
            IF (I < J) <     # OUT OF ORDER PAIR
               T = A(I)%%# EXCHANGE A(I) AND A(J)
               A(I) = A(J)
               A(J) = T
               !
            !
         J = UV(P)         # MOVE PIVOT TO POSITION I
         T = A(I)%# EXCHANGE A(I) AND A(J)
         A(I) = A(J)
         A(J) = T
         IF (I-LV(P) < UV(P)-I) <   # STACK SO SHORTER DONE FIRST
            LV(P+1) = LV(P)
            UV(P+1) = I - 1
            LV(P) = I + 1
            !
         ELSE <
            LV(P+1) = I + 1
            UV(P+1) = UV(P)
            UV(P) = I - 1
            !
         P = P + 1         # PUSH ONTO STACK
         !
   RETURN
   END
#-H- RATDEF 2690 1980 103 2154
#========== STANDARD RATFOR DEFINITIONS ==========
 
DEFINE(ACCENT,96)
DEFINE(ALPHA,10100)
DEFINE(AND,38)
DEFINE(ANDIF,IF)
DEFINE(ARB,100)
DEFINE(ATSIGN,64)
DEFINE(BACKSLASH,92)
DEFINE(BACKSPACE,8)
DEFINE(BANG,33)
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(BLANK,32)
DEFINE(CARET,94)
DEFINE(COLON,58)
DEFINE(COMMA,44)
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(DIGIT,2)
DEFINE(DOLLAR,36)
DEFINE(DQUOTE,34)
DEFINE(EOF,10003)
DEFINE(EOS,10002)
DEFINE(EQUALS,61)
DEFINE(ERR,10001)
DEFINE(ERROUT,2)
DEFINE(GREATER,62)
DEFINE(HUGE,30000)
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(LETTER,1)
DEFINE(LETU,117)
DEFINE(LETV,118)
DEFINE(LETW,119)
DEFINE(LETX,120)
DEFINE(LETY,121)
DEFINE(LETZ,122)
DEFINE(LPAREN,40)
DEFINE(MAXCHARS,20)
DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH
DEFINE(MAXNAME,30)   %# TYPICAL FILE NAME SIZE
DEFINE(MINUS,45)
DEFINE(NEWLINE,10)
DEFINE(NO,0)
DEFINE(NOERR,0)
DEFINE(NOT,126)   # SAME AS TILDE
DEFINE(OK,-2)
DEFINE(OR,BAR)   # SAME AS BAR
DEFINE(PERCENT,37)
DEFINE(PERIOD,46)
DEFINE(PLUS,43)
DEFINE(QMARK,63)
DEFINE(RBRACE,125)
DEFINE(RBRACK,93)
DEFINE(READ,0)
DEFINE(READWRITE,2)
DEFINE(RPAREN,41)
DEFINE(SEMICOL,59)
DEFINE(SHARP,35)
DEFINE(SLASH,47)
DEFINE(SQUOTE,39)
DEFINE(STAR,42)
DEFINE(STDIN,0)
DEFINE(STDOUT,1)
DEFINE(STDERR,ERROUT)
DEFINE(TAB,9)
DEFINE(TILDE,126)
DEFINE(UNDERLINE,95)
DEFINE(WRITE,1)
DEFINE(YES,1)
DEFINE(ESCAPE,ATSIGN)
DEFINE(CHARACTER,INTEGER)
DEFINE(ABS,IABS)
DEFINE(MIN,MIN0)
DEFINE(MAX,MAX0)
 
# HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE
DEFINE(BPI,36)%%# BITS PER INTEGER
DEFINE(BPC,7)%%# BITS PER CHARACTER
DEFINE(CPI,5)%%# CHARACTERS PER INTEGER
DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER
DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN)
DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN)
DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL
#-H- SCOPY.RAT 293 1980 103 2154
INCLUDE RATDEF
 
# SCOPY - COPY STRING AT FROM(I) TO TO(J)
   SUBROUTINE SCOPY(FROM, I, TO, J)
   CHARACTER FROM(ARB), TO(ARB)
   INTEGER I, J, K1, K2
 
   K2 = J
   FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) <
      TO(K2) = FROM(K1)
      K2 = K2 + 1
      !
   TO(K2) = EOS
   RETURN
   END
#-H- SECS.RAT 182 1980 103 2154
INCLUDE RATDEF
 
# SECS - RETURN SECONDS IN  N  AND AS FUNCTION VALUE
   INTEGER FUNCTION SECS(N)
   INTEGER N
   INTEGER JUNK
 
   CALL DATE4(JUNK, JUNK, JUNK, N)
   RETURN(N)
   END
#-H- SKIPBL.RAT 219 1980 103 2154
INCLUDE RATDEF
 
# SKIPBL - SKIP BLANKS AND TABS AT LIN(I)... AND INCREMENT  I
   SUBROUTINE SKIPBL(LIN, I)
   CHARACTER LIN(ARB)
   INTEGER I
 
   WHILE (LIN(I) == BLANK \ LIN(I) == TAB)
      I = I + 1
   RETURN
   END
#-H- STCLOS.RAT 619 1980 103 2154
INCLUDE MDEF
 
# STCLOS - INSERT CLOSURE ENTRY AT PAT(J)
   INTEGER FUNCTION STCLOS(PAT, J, LASTJ, LASTCL)
   CHARACTER PAT(MAXPAT)
   INTEGER ADDSET
   INTEGER J, JP, JT, JUNK, LASTCL, LASTJ
 
   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
#-H- STRCAT.RAT 362 1980 103 2154
INCLUDE RATDEF
 
# STRCAT - APPEND COPY OF STR1 ONTO THE END OF STR2
   SUBROUTINE STRCAT(STR1, STR2)
   CHARACTER STR1(ARB), STR2(ARB)
   INTEGER I, J
 
   FOR (J = 1; STR2(J) ^= EOS; J = J + 1)%%# FIND END OF STR2
      ;
   FOR (I = 1; STR1(I) ^= EOS; I = I + 1) <%# APPEND STR1
      STR2(J) = STR1(I)
      J = J + 1
      !
   STR2(J) = EOS
   RETURN
   END
#-H- STRCMP.RAT 498 1980 103 2154
INCLUDE RATDEF
 
# STRCMP - RETURN <0 IF STR1 < STR2, 0 IF STR1 == STR2, >0 IF STR1 > STR2
   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) <
         STRCMP = 0
         RETURN
         !
   IF (STR1(I) == EOS)%%# STR1 IS SHORTEST
      STRCMP = -1
   ELSE IF (STR2(I) == EOS)%# STR2 IS SHORTEST
      STRCMP = +1
   ELSE%%%%# NOT EQUAL
      STRCMP = STR1(I) - STR2(I)
   RETURN
   END
#-H- STRCPY.RAT 226 1980 103 2154
INCLUDE RATDEF
 
# STRCPY - COPY STR1 TO STR2
   SUBROUTINE STRCPY(STR1, STR2)
   CHARACTER STR1(ARB), STR2(ARB)
   INTEGER I
 
   FOR (I = 1; STR1(I) ^= EOS; I = I + 1)
      STR2(I) = STR1(I)
   STR2(I) = EOS
   RETURN
   END
#-H- TEN.RAT 376 1980 103 2154
INCLUDE RATDEF
 
# TEN - RETURN 10^N FOR 0 <= N <= LIM1
   REAL FUNCTION TEN(N)
   INTEGER N, M, I, MOD
   REAL TENS(9)
   DATA TENS /1.0E1, 1.0E2, 1.0E4, 1.0E8, 1.0E16,
%      1.0E32, 1.0E64, 1.0E128, 1.0E256/
 
   M = N
   I = 0
   TEN = 1.0
   REPEAT <
      IF (MOD(M, 2) == 1)
         TEN = TEN*TENS(I+1)
      M = M/2
      I = I + 1
   ! UNTIL (M == 0)
   RETURN
   END
#-H- TIME.RAT 179 1980 103 2154
INCLUDE RATDEF
 
# TIME - RETURN TIME IN  N  AND AS FUNCTION VALUE
   INTEGER FUNCTION TIME(N)
   INTEGER N
   INTEGER JUNK
 
   CALL DATE4(JUNK, JUNK, N, JUNK)
   RETURN(N)
   END
#-H- TTOC.RAT 721 1980 103 2154
INCLUDE RATDEF
 
# TTOC - CONVERT TIME TO CHARACTER STRING A(1)...A(SIZE)
   INTEGER FUNCTION TTOC(TIME, A, SIZE)
   INTEGER TIME, SIZE
   CHARACTER A(ARB)
   INTEGER I, J, ITOC
 
   A(1) = EOS
   IF (SIZE < 9) <%# TOO SHORT
      TTOC = 0
      RETURN
      !
   J = TIME/100 # GET THE HOUR
   IF (J == 12 \ J == 0)
      I = ITOC(12, A, 3) + 1
   ELSE IF (J > 12)
      I = ITOC(J - 12, A, 3) + 1
   ELSE
      I = ITOC(J, A, 3) + 1
   A(I) = COLON
   I = I + 1
   IF (MOD(TIME, 100) < 10)  <
      A(I) = DIG0
      I = I + 1
      !
   I = I + ITOC(MOD(TIME, 100), A(I), 3)
   A(I) = BLANK
   IF (J < 12)
      A(I+1) = LETA
   ELSE
      A(I+1) = LETP
   A(I+2) = LETM
   A(I+3) = EOS
   TTOC = I + 2
   RETURN
   END
#-H- TYPE.RAT 295 1980 103 2154
INCLUDE RATDEF
 
# TYPE - RETURN TYPE OF CHARACTER C
   INTEGER FUNCTION TYPE(C)
   CHARACTER C
 
   IF (C >= BIGA & C <= BIGZ)
      TYPE = LETTER
   ELSE IF (C >= LETA & C <= LETZ)
      TYPE = LETTER
   ELSE IF (C >= DIG0 & C <= DIG9)
      TYPE = DIGIT
   ELSE
      TYPE = C
   RETURN
   END
#-H- XTOC.RAT 751 1980 103 2154
INCLUDE RATDEF
 
 
DEFINE(ABS,IABS)
# XTOC - CONVERT INTEGER  INT  TO CHAR STRING IN  STR IN BASE B
   INTEGER FUNCTION XTOC(INT, STR, SIZE, B)
   INTEGER ABS, MOD
   INTEGER I, INT, INTVAL, J, K, SIZE, B
   CHARACTER STR(ARB)
 
   INTVAL = ABS(INT)
   STR(1) = EOS
   I = 1
   REPEAT <            # GENERATE DIGITS
      I = I + 1
      STR(I) = DIG0 + MOD(INTVAL, B)
      IF (B > 10)
         STR(I) = STR(I) + LETA - DIG9 - 1
      INTVAL = INTVAL / B
      ! UNTIL (INTVAL == 0 \ I >= SIZE)
   IF (INT < 0 & I < SIZE) <      # THEN SIGN
      I = I + 1
      STR(I) = MINUS
      !
   XTOC = 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
#-H- YEAR.RAT 179 1980 103 2154
INCLUDE RATDEF
 
# YEAR - RETURN YEAR IN  N  AND AS FUNCTION VALUE
   INTEGER FUNCTION YEAR(N)
   INTEGER N
   INTEGER JUNK
 
   CALL DATE4(JUNK, N, JUNK, JUNK)
   RETURN(N)
   END
#========== END OF TAPE ==========
 
