*DECK     IO
          IDENT  IO 
 IO       SECT   (INPUT / OUTPUT STATEMENTS.),1 
  
          SST 
  
 B=IO     RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  BUFERR,LST,FFN,LGR,LG.LEN
          ENTRY  O=IOJ,IOLEN,A=BMOD,A=BLWA,A=STR,A=FMT,C=BFWA,C=IOL 
          ENTRY  C=CNT,C=FMT,NULL,REP.,DO.,IF.,ASF.,FORMAT,TO,PRECISI 
          ENTRY  FUNCTIO,EOS,LST5,TYPES,PTN3
          ENTRY  BLWA,CML,IODIR,R.W 
  
*         IN FTN
          EXT    CO.EDT,CO.SNAP 
  
*         IN TABLES 
          EXT    APLSTOR,APLUG,ARGCOMA,ARGMODE,BUFMOD,BUFFWA,BUFLWA 
          EXT    CALLIO,ICONL,IOARGM,MOD,NDC=CNT,NDC=STR,PTN=FMT,REFVAR 
          EXT    REFNUM,TG.APL,TG.PRO,TG.TEM,TP.APL,TP.DIM,TP=DO,TS.CON 
          EXT    TS.SYM,TT.PAR,TP.ILI,TP=ILI
  
*         IN ERRORS 
          EXT    E.ANS,E.IO,E.IOB1,E.IOB3,E.IOB4,E.IOB5,E.IOB7
          EXT    E.IOD1,E.IOD3,E.IOF1,E.IO6U,E.IOL2,E.ION,E.IOS1,E.IOS2 
          EXT    E.IOS3,E.IOS4,E.IOS5,E.IOS7,E.IO1,E.IO10,E.IO11
          EXT    E.IO12,E.IO13,E.IO14,E.IO19
          EXT    E.IO20,E.IO21,E.IO3,E.IO6,E.IO7,E.IO8
          EXT    E.IO9,E.UE,E.UE1,E.UE2,E.ION1,E.IOD2,FILL. 
          EXT    E.IOL1,E.IOL4,E.IOL5,E.IO25,E.IO26,E.IO27,E.IO28 
          EXT    E.IOS6,E.IO29,E.IO62,E.IOS9,E.IOS10
          EXT    E.IOD4 
  
*         IN ALLOC
          EXT    ERT,ADW,ESC,NAP,NCS,SSY,NCM
  
*         IN MAIN 
          EXT    WBL,CPM=EXU,CPM=1ST,CPM=END,CPM=ASF,CPM=NTR,CPM=OK 
          EXT    CPM=DAT,CPM=DEC,CPM=TYP,CPM=TPE,CPM=IMP,CPM=FMT
  
*         IN LEX
          EXT    S=BIN,S=INP,S=OUT,S=COD,S=CONT,S=STR,S.BUFIO,S=FREE
          EXT    S.IOCAL,S.ENDFI,S.REWIN,S.BKSP,S.NLST,TSF,TRV
  
*         IN KEY
          EXT    EMT
  
*         IN TSDATA 
          EXT    CFC
  
*         IN NUM
          EXT    PSN,ISN
  
*         IN REG
          EXT    CIA,CRJ
  
*         IN PAR
          EXT    CURST,C=ERR,PAREXIT,POP.ST1,SOPR,ADT,PAR,POPX,CNF
  
*         IN GEN
          EXT    CVT,MXP,PSO
          EXT    O=BSS,SA=BKS3,EIS.PNX,CAI
  
*         IN ASF
          EXT    AFD
  
*         IN DO 
          EXT    CDI,PDT,SDO
  
*         IN INIT 
          EXT    SCR
  
  
  
**        THIS SECTION IS COMPRISED OF THREE MAIN DIVISIONS --
*         1.  "HEREIF"S FOR ALL I/O STATEMENTS. 
*         2.  ROUTINES CALLED BY THE ABOVE. 
*                IN GENERAL, THESE CALL THE PARSER TO CREATE ENTRIES
*                POINTING TO -- 
*         3.  "O=XXX" OPERATORS INVOKED BY *ARITH* TO GENERATE THE
*                ACTUAL CODE. 
  
 IO=      SPACE  4,8
**        IO= -  I/O LIBRARY CALLING SEQUENCE DEFINITIONS.
*         ORDINAL IN THE AP-LIST OF DEFINED OBJECTS --
  
  
 IO=FIT   EQU    0           FIT/FET ADDRESS
  
 IO=BMOD  EQU    1           BUFFER I/O MODE ADDRESS
 IO=BFWA  EQU    2           BUFFER I/O FIRST WORD ADDRESS
 IO=BLWA  EQU    3           BUFFER I/O LAST WORD ADDRESS 
 IO=BLEN  EQU    4
  
 IO=NGRP  EQU    1           NAMELIST I/O GROUP ADDRESS 
  
 IO=FMT   EQU    1           FORMAT ADDRESS 
  
 IO=CNT   EQU    0           XX-CODE RECORD SIZE
 IO=STR   EQU    2           XX-CODE STRING ADDRESS 
 IO=CM    EQU    7           *,* TERMINATOR FOR LINE CONTROL. 
  
 IOAPT    CON    0           TAG OF AP-LIST UNDER CONSTRUCTION
  
 IOARGO   CON    0           ADDRESS OF OPERATOR
  
 IODIR    CON    0           I/O DIRECTION (S=INP OR S=OUT) 
 IOARGT   CON    0           (ARGMODE) FOR THIS DIRECTION 
 IOREF    CON    0           I/O REFERENCE LETTER 
 IOLEN    CON    0           CURRENT LENGTH OF I/O AP-LIST
                             -1 UNTIL INITIAL ITEMS COMPILED. 
  
 IO1ST    CON    0           FIRST  FIXED-POSITION I/O ITEM 
 IO2ND    CON    0           SECOND FIXED-POSITION I/O ITEM 
 IO3RD    CON    0           THIRD  FIXED-POSITION I/O ITEM 
 IO4TH    CON    0           FOURTH FIXED-POSITION I/O ITEM 
  
  
 IONAM    EQU    ICONL       ORDINAL OF ROUTINE NAME TO CALL (IN S.LIB) 
                             COMPLEMENTED UNTIL INITIAL CALL COMPILED.
 IODOLEN  BSS    1           LENGTH OF DO-TABLE BEFORE THIS STATEMENT 
                             USED TO RESET DO-TABLE IN CASE OF MESSED 
                             UP IMPLIED DO-S. 
 IOENDT   CON    0           GENERATED TAG FOR DEFAULT END= 
  
 IOFIT    EQU    IO1ST       FILE INFORMATION TABLE ADDRESS 
 IOCNT    EQU    IO1ST       XX-CODE RECORD COUNT 
  
 IOBMOD   EQU    IO2ND       BUFFER I/O MODE DESIGNATOR 
 IOFMT    EQU    IO2ND       FORMAT DESIGNATOR
 IONGRP   EQU    IO2ND       NAMELIST GROUP ADDRESS 
  
 IOBFWA   EQU    IO3RD       BUFFER I/O FIRST WORD ADDRESS
 IOSTR    EQU    IO3RD       XX-CODE STRING ADDRESS 
  
 IOBLWA   EQU    IO4TH       BUFFER I/O LAST WORD ADDRESS 
 R.W      CON    0           FLAG USED TO SET IOIND BIT FOR WRITE/PUNCH 
*                            FLAG ALSO FOR PROCESSING CHAR STRINGS IN 
*                            LIST-DIRECTED I/O
 IOSTAT   BSS    1           HOLDING CELL FOR STATIC LOAD INDICATOR 
          SPACE  4,8
**        STLI  -  STATIC LOAD INDICATORS.
* 
*           MACRO TO GENERATE TABLE FOR *LDSET  USE* DIRECTIVES 
*         FOR CRM *STATIC* MODE.
* 
*                STLTAB      NAME 
* 
*         NAME IS THE STATIC *USE* PACKAGE NAME WITH THE FORM 
*         STLXXX, WHERE XXX IS THE PACKAGE IDENTIFICATION 
*         MNEMONIC. STLI REMOVES THE *L* FROM *STL*, AND PREFIXES 
*         THE RESULTANT SYMBOL WITH *M.* . THIS SYMBOL IS THEN
*         ASSIGNED THE NEXT BIT MASK IN SEQUENCE AND DECLARED AN
*         ENTRY POINT. THE TABLE ENTRY IS MADE FOR THE ORIGINAL SYMBOL
*                LEFT JUSTIFIED AND ZERO FILLED.
  
  
 STLTAB   MACRO  PNAM 
          IF     -DEF,MSK,2 
 S.1      SET    0
 MSK      SET    1
 A        MICRO  1,,L_PNAM
 B        MICCNT A
 C        MICRO  B+2,,.PNAM 
          ENTRY  M."A"_"C"
 M."A"_"C"  EQU  MSK
 MSK      SET    MSK+MSK
 S.1      SET    S.1+1
          DATA   L PNAM 
 STLTAB   ENDM
          SPACE 4,8 
*         STATIC LOAD TABLE.
  
          ENTRY  STLTAB,L.STL,N.STL 
 STLTAB   BSS    0
  
*CALL STLOAD
  
 L.STL    =      S.1-S.1/2*2+S.1/2+1 LENGTH/2+REMAINDER+EOT 
 N.STL    =      S.1
          CON    0           TERMINATE TABLE
  
          PURGMAC STLI
 BCK      SPACE  4,8
**        BCK -  PROCESS "BACKSPACE" STATEMENT. 
*         EXIT   TO *REW* WITH
*                (B6) _ BACKSPACE ROUTINE NAME. 
  
  
          HEREIF BACKSPACE
  
          SB6    S.BKSP 
          SX4    M.STBAK
          EQ     REW2 
 BUF      SPACE  4,8
**        BUF -  PROCESS "BUFFER IN/OUT" STATEMENT. 
* 
*         BUFFER <DIR> (<FILE>,<MODE>) (FWA,LWA)
*         <DIR>  #  *IN* OR *OUT* 
*         <FILE> #  AS DEFINED BY *RTC* 
*         <MODE> #  <INTEGER-CONSTANT> OR <SIMPLE-INTEGER-VARIABLE> 
* 
*         CALLS  CRJ, RTC, SUP, CAI, O=IOL, NAP, TRV, ANSI, ADDWD,
*                CLOAD, TAGSEX, WARN. 
  
  
          HEREIF BUFFER 
  
          ANSI   E.ANS       NON ANSI STATEMENT.
          SA5    B4 
          SA2    BUFA 
          =A3    A2+1 
          =B6    0
          SX7    CR.INP 
          BX2    X5-X2
          =A1    A5+1        *(*
          =B7    X1-O.LP
          BX3    X5-X3
          SX4    M.STIBU
          ZR     X2,BUF1     IF *IN*
          =B6    1
          SX7    CR.OUT 
          SX4    M.STOBU
          NZ     X3,E.IOB1   IF NOT *OUT*, ERR..
 BUF1     ZR     B7,BUF2     IF SYNTAX OK 
          =B4    B4+1        RESET FOR DIAGNOSTIC 
          EQ     E.IOB3      IF NO *(*
 BUF2     SA2    BUFMOD 
          SB7    S.BUFIO
          SA1    =XSTATIC 
          SB7    B6-B7
          BX6    X1+X4
          SA6    A1          UPDATE STATIC LOAD INFORMATIOM 
          SX6    B7+S.IOCAL 
          SA7    IOREF
          LX7    P.AMR
          BX7    X2+X7
          SA7    ARGMODE
          SA6    IONAM       SAVE ROUTINE NAME
  
**        STORE FILE TAG. 
  
          SA1    B4+2 
          BX6    X1 
          =B4    A1-1 
          RJ     RTC         ASSEMBLE FILE DESIGNATOR 
          =B4    B4+1 
          RJ     PFD         PROCESS FILE DESIGNATOR INTO AP-LIST.
  
**        STORE MODE DESIGNATOR.
  
          =A2    B4 
          SB7    X2-O.COMMA 
          NZ     B7,E.IOB4
          =X7    O.SLP
          SA7    B4 
          RJ     PAR         PARSE THE MODE DESIGNATOR
  
**        STORE FWA INDICATOR.
  
          SA1    B4 
          =A2    B4+1 
          =B4    A2+1        POINT TO FWA 
          =X6 
          SX1    X1-O.RP
          SX2    X2-O.LP
          NZ     X1,E.IOB5   IF NO ) AFTER MODE DESIGNATOR
          ZR     X2,BUF3     IF SYNTAX OK 
          =B4    B4-1        RESET FOR DIAGNOSTIC 
          EQ     E.IOB3      IF NO *(* BEFORE FWA 
  
**        TRANSLATE FWA AND LWA TO TAGS 
  
 BUF3     SA6    ARGCOMA
  
          SA2    BUFFWA 
          SA3    IOREF
          LX3    P.AMR
          BX7    X2+X3
          SA7    ARGMODE
          RJ     PAR         PARSE FIRST WORD ADDRESS 
          =A2    B4+1 
          =B4    B4+1 
          SB7    X2-O.COMMA 
          NZ     B7,E.IOB4   IF NO *,* AFTER FWA
  
          SA2    BUFLWA 
          =X7    O.SLP
          BX6    X2 
          SA7    B4 
          SA6    ARGMODE
          RJ     PAR         PARSE LAST WORD ADDRESS
          =A2    B4 
          BX6    X6-X6
          SB7    X2-O.RP
          NZ     B7,E.IOB5   IF NO *)* AFTER LWA
  
**        CALL *IOJ* TO EMIT AN I/O CALL TURPLE AND CREATE THE APLIST.
  
          RJ     IOJ         COMPILE THE CALL 
  
          SA1    TG.APL 
          SX6    X1-1 
          SA6    A1 
  
          RJ     CAI         COMPILE ALL INSTRUCTIONS 
          EQ     PSN         EXIT.. 
  
**        HERE IF FATAL ERROR IN BUFFER STATEMENT.
*                ADD *O=ERR* OPERATOR TO PARSED FILE. 
  
 BUFERR   RJ     CAI         FLUSH PARSED FILE
          EQ     PSN         EXIT.. 
  
 BUFA     CON    0LIN+O.VAR 
          CON    0LOUT+O.VAR
 DCD      SPACE  4,8         DCD
**        DCD -  PROCESS "DECODE" STATEMENT.
*         EXIT   TO *NDC* WITH
*                (B6) = INPUT DIRECTION INDICATION. 
  
  
          HEREIF DECODE 
  
          =B6    S=INP
          SX7    CR.INP 
          SX4    M.STICO
          EQ     NDC         PROCESS ARGUMENTS AND LIST 
 EFI      SPACE  4,8
**        EFI -  PROCESS "ENDFILE" STATEMENT. 
*         EXIT   TO *REW* WITH
*                (B6) _ ENDFILE ROUTINE NAME. 
  
  
          HEREIF ENDFILE
  
          SA1    B4 
          SB6    S.ENDFI
          BX3    X1 
          =X2    O.VAR-O.CONS 
          LX1    CHAR 
          SB2    X1-1R0-O.VAR*1S6 
          SX4    M.STENF
          MI     B2,REW2     IF 1ST = ALPHA 
          IX6    X3-X2
          SA6    A1          RESET TO INDICATE CONSTANT 
          EQ     REW2        CONTINUE 
 NCD      SPACE  4,8
**        NCD -  PROCESS "ENCODE" STATEMENT.
*         EXIT   TO *NDC* WITH
*                (B6) = OUTPUT DIRECTION INDICATION.
  
  
          HEREIF ENCODE 
  
          =B6    S=OUT
          SX7    CR.OUT 
          SX4    M.STOCO
          EQ     NDC
 PNC      SPACE  4,8
**        PNC -  PROCESS "PUNCH" STATEMENT. 
*         ENTERED BY  *PRINT FMT,*  AND  *READ FMT,*  STATEMENTS. 
*         ENTRY  (X5) = FILE NAME.
*                (X6) = I/O INDICATION TO BE STORED IN *R.W*
*                (B4) _ FORMAT DESIGNATOR.
*                (B6) = I/O DIRECTION (S=INP OR S=OUT). 
*         EXIT   TO *LST* WITH
*                (B6) = DIRECTION + CODED MODE (S=COD) INDICATION.
*         CALLS  ANSI, FFT, PFD, PTN. 
  
  
          HEREIF PUNCH
  
          ANSI   E.ANS       *PUNCH* STATEMENT IS NON-ANSI
          MX6    2
          SA5    =0LPUNCH 
          LX6    1           INDICATES I/O IS PUNCH 
  
*         ENTERED HERE BY *PRINT* STATEMENT PROCESSOR 
  
 PNC1     SX7    CR.OUT 
          SA7    IOREF       SET XREF CELL TO *W* 
          SX4    M.STOCO
          =B6    S=OUT
          SA1    B4 
          SB2    X1-O.( 
          ZR     B2,WOT.R    IF *PUNCH(* OR *PRINT(*
  
*         ENTERED HERE BY *READ FMT, * PROCESSOR
  
 PNC1A    SA1    =XSTATIC 
          BX7    X1+X4
          SA7    A1          UPDATE STATIC LOAD INFORMATION 
          SA1    B4 
          SB2    X1-O.STAR
          SA6    R.W         FLAG FOR TYPE OF I/O 
          NZ     B2,PNC2     IF (HOPEFULLY) FORMATTED *PUNCH* OR *PRINT*
          ANSI   E.IO28      LIST-DIRECTED I/O IS NON-ANSI
          =B4    B4-1        GIVE FFT A CELL TO WORK WITH 
          RJ     FFT         FIND FILE TAG
          RJ     PFD         PROCESS FILE DESIGNATOR INTO AP-LIST 
          =B6    B6+S=FREE
          =A1    B4+1 
          =X6    1
          =B4    B4+1 
          SA6    R.W         SET LIST-DIRECTED FLAG 
          =A3    B4+1 
          SX2    X1-O.COMMA 
          ZR     X1,E.IO27   EOS ENCOUNTERED--NO I/O LIST 
          NZ     X2,PNC1B    IF NOT A COMMA 
          ZR     X3,E.IO27   IF *,* TERMINATOR WITH NO IOLIST.
          EQ     LST
 PNC1B    WARN   E.IO9
          =B4    B4-1        NO COMMA, SO PRETEND THERE IS ONE. 
          EQ     LST         PROCESS I/O LIST 
  
 PNC2     =B4    B4-1        GIVE FFT A CELL TO WORK WITH 
          RJ     FFT         FIND FILE TAG
          RJ     PFD         PROCESS FILE DESIGNATOR INTO AP-LIST.
          =B6    B6+S=COD 
          BX7    0
          SA7    ASSUNIT     SET RETURN CONDITION 
          RJ     PTN         PROCESS FORMAT NUMBER
          SA1    B4 
          SX2    X1-O.COMMA 
          ZR     X1,LST      IF *EOS* 
          ZR     X2,LST      IF COMMA 
          WARN   E.IO9
          EQ     LST         PROCESS I/O LIST 
 PNT      SPACE  4,8
**        PNT -  PROCESS "PRINT" STATEMENT. 
*         EXIT   TO *PNC* WITH -- 
*                (X5) = *OUTPUT* FILE.
  
  
          HEREIF PRINT
  
          ANSI   E.ANS       *PRINT* STATEMENT IS NON-ANSI
          MX6    1
          SA5    =0LOUTPUT
          EQ     PNC1        PROCESS REMAINDER OF STATEMENT 
 REW      SPACE  4,8
**        REW -  PROCESS "REWIND" STATEMENT.
* 
*         ALSO CONTAINS PROCESSING FOR *ENDFILE* AND *BACKSPACE*
*         ENTRY TO *REW2* --
*                (B6) _ THE NAME OF THE FILE MANIPULATION ROUTINE NEEDED
*                            TO PROCESS THE REQUESTED ACTION. 
*                (X4) = M.STXXX INDICATOR FOR STATIC LOAD 
*         *REW2* THEN ASSEMBLES THE FILE DESIGNATOR FROM THE STATEMENT, 
*                CHECKS FOR SUPERFLUOUS TRAILING CHARS., AND COMPILES 
*                A LOAD OF (X1) = FIT ADDRESS, AND AN RJT TO THE ROUTINE
*         CALLS  CLOAD, CRJ, TAGSEX, ADDWD, NAP, RTC, WARN. 
  
  
          HEREIF REWIND 
  
          SB6    S.REWIN
          SX4    M.STREW
  
*         JOINED HERE BY *ENDFILE* AND *BACKSPACE* PROCESSORS 
  
 REW2     SX7    CR.REF 
          SA7    IOREF       SET XREF CELL TO * * 
          SA2    =XSTATIC 
          BX6    X2+X4
          SA6    A2          UPDATE STATIC LOAD INFORMATION 
          SA2    B4 
          SA1    B4+B1
          ZR     X2,E.IO1    IF NO UNIT 
          ZR     X1,REW3     IF *EOS* 
          =B4    B4+1 
          WARN   E.IO6       EXTRA CHARACTERS - WARNING 
          =B4    B4-1 
 REW3     BX6    X2 
          RJ     RTC         ASSEMBLE/TRANSLATE FILE NAME 
          RJ     PFD         PROCESS FILE DESIGNATOR INTO AP-LIST 
          SB3    S.IOCAL
          SX7    B6-B3
          BX6    0
          BX7    -X7         INDICATE NO CALLS YET
          SA7    IONAM
          RJ     IOJ
          SA1    TG.APL 
          SX6    X1-1 
          SA6    A1 
          EQ     PSN         EXIT.. 
 RIT      SPACE  4,8
**        RIT -  PROCESS "READ" STATEMENT.
* 
*         EXIT   (B6) = *INPUT* DIRECTION INDICATION. 
*                TO *PNC* WITH (X5) = *INPUT* FILE, 
*                          AND (B4) _ FORMAT DESIGNATOR.
*                OR *WOT* WITH (B4) _ *(*.
  
  
          HEREIF READ 
  
          SX7    CR.INP 
          SA7    IOREF       SET XREF CELL TO *R* 
          SX4    M.STICO
          SA1    B4 
          SA5    =0LINPUT 
          =B6    S=INP
          SX2    X1-O.( 
          MX6    0
          ZR     X2,WOT.R    IF *READ(* 
          ANSI   E.ANS       ANSI REQUIRES *(* AFTER *READ* 
          MX6    0
          EQ     PNC1A
 WOT      SPACE  4,8         WOT
**        WOT -  PROCESS "WRITE" STATEMENT. 
* 
*         ENTERED BY *READ(* STATEMENT. 
*         ENTRY  (B6) = I/O DIRECTION (IN OR OUT) 
*                (B4) _ *(* 
*         EXIT   *LST* WITH --- 
*                (B6) = DIRECTION AND BINARY/BCD INDICATION.
*         CALLS  PFD, PTN, RTC. 
  
  
          HEREIF WRITE
  
          SX7    CR.OUT 
          SA7    IOREF       SET XREF CELL TO *W* 
          SX4    M.STOCO
          SA1    B4 
          =B6    S=OUT
          SA5    =0LOUTPUT
          SX6    B1 
          SX2    X1-O.( 
          ZR     X2,WOT.R    IF *WRITE(*
          ANSI   E.ANS       ANSI REQUIRES *(* AFTER *WRITE*
          =X6    1
          EQ     PNC1A
  
**        ENTERED HERE BY *READ (* PROCESSOR. 
  
 WOT.R    SA1    B4+B1
          SA6    R.W         FLAG FOR TYPE OF I/O 
          LX6    X4 
          SA6    IOSTAT 
          BX6    X1 
          RJ     RTC         ASSEMBLE UNIT DESIGNATOR 
          RJ     PFD         PROCESS FILE DESIGNATOR INTO AP-LIST.
          SA4    IOSTAT 
          =B6    B6+S=BIN 
          =A1    B4+1 
          =B4    B4+1        POINT TO RPAREN OR COMMA 
          SB7    X1-O.) 
          NZ     B7,WOT1     IF NOT *)* 
          SA2    R.W
          MI     X2,E.IO25   IF NOT *READ* OR *WRITE* 
          LX4    2           CONVERT TO BINARY I/O INDICATOR
          SA1    =XSTATIC 
          BX6    X1+X4
          SA6    A1          UPDATE STATIC LOAD INFORMATION 
          MX7    0           UNFORMATED IO...KEYWORD(U) 
          SA7    A2 
          SA3    IODIR
          ZR     X3,LST      IF *READ*
          =A1    B4+1 
          NZ     X1,LST      IF NOT *EOS* 
          ANSI   E.IO26      ANSI REQUIRES AN I/O LIST
          EQ     LST
  
 WOT1     SA2    =XSTATIC 
          BX6    X2+X4
          SA6    A2          UPDATE STATIC LOAD INFORMATION 
          SB2    X1-O.COMMA 
          NZ     X1,WOT2     IF NOT PREMATURE *EOS* 
          FATAL  E.IO8
 WOT2     ZR     B2,WOT3     IF COMMA 
          WARN   E.IO9       ** ASSUMED COMMA AFTER UNIT ** 
 WOT3     =A1    B4+1 
          ZR     X1,E.IO13   IF PREMATURE EOS (RETURN LST)
          =B4    B4+1 
          SB7    S=BIN
          SB6    B6-B7
          SB6    B6+S=COD 
          SB2    X1-O.STAR
          NZ     B2,WOT3A    IF NOT STAR
          ANSI   E.IO28      LIST-DIRECTED I/O IS NON-ANSI
          =B6    B6+S=FREE
          =B4    B4+1 
          =X6    1
          SA6    R.W         SET LIST-DIRECTED FLAG 
          EQ     WOT3B
  
 WOT3A    =X7    1
          SA7    ASSUNIT     SET RETURN CONDITION 
          RJ     PTN         PROCESS FORMAT DESIGNATOR
 WOT3B    SA1    B4 
          SB7    X1-O.) 
          NZ     B7,E.IO20         IF NOT *)* 
          EQ     LST
 DOB      SPACE  4,8
**        DOB -  I/O LIST DO-BEGIN PROCESSING.
* 
*         ENTRY  (B4) _ IO.DOB MARK 
*         EXIT   TO *LST.GO*. 
*                (B4) PRESERVED.
*         USES   ALL BUT A0.
*         CALLS  CDI. 
  
  
 DOB      BX6    -0 
          RJ     IOJ         INTERRUPT LIST 
          RJ     MXP         MARK EXTERNAL PROCESSOR
          SA2    B4 
          SA1    TG.PRO 
          AX2    18          ISOLATE LINK TO DO-INDEX 
          SX2    X2          ADDRESS OF INDEX 
          =X7    O.=
          =X6    X1+1        UPDATE PROGRAM TAG 
          SX0    B4 
          =A7    X2+1 
          SA6    A1 
          LX0    -18
          BX3    X6+X0
          =B4    X2+1        POINT TO*=*
          LX3    2*18 
          IX7    X3+X2       =  24/ L.TAG,  18/ FWA-DO,  18/ INDEX-ADDR 
          SA7    DOBA        SAVE IO.DOC POINTERS 
  
**        PARSE *DO* INITIAL CODE.
*         (X6) = L-TAG FOR LOOP.
  
          RJ     CDI         PARSE IT.
  
          =X0    IO.DOC 
          SA1    IOARGT 
          SA3    DOBA 
          BX4    X6+X0       SAVE *DO-ERROR* FLAG 
          LX6    X1 
          SB3    B4          _ )
          SB2    X3          ADDRESS OF DO-INDEX
          AX3    18 
          SB4    X3          RESTORE (B4) _ FRONT OF DO-LIST
          SA6    ARGMODE     RESET AFTER *DO* HAS ALTERED.
          SX2    B4-B3
          BX6    O.EOS
          =A6    B2-1        FORCE *EOS* AT END OF LIST 
          IX0    X3-X2
          LX0    18 
          IX7    X0+X4
          SA7    B2          STORE DO-CLOSE MARK (OVER THE INDEX) 
,                            24/ L.TAG,  18/ _),  18/ IO.DOC
          EQ     LST.GO      EXIT.. 
  
 DOBA     BSS    1           TEMP 
 DOC      SPACE  4,8
**        DOC -  I/O LIST DO-CONCLUSION PROCESSING. 
* 
*                MAKES DO-TERMINATION ENTRY IN PARSED FILE. 
*         1.  AN *IOJ* TURPLE.
* 
*         ENTRY  (B4) _ IO.DOC MARK.
*         EXIT   TO *LST.GO*. 
*                (B4) _ NEXT ITEM PAST THE DO.
*         USES   ALL. 
*         CALLS  IOJ, MXP, PDT
  
  
 DOC      BSS    0           ENTRY/EXIT...
          BX6    -0 
          RJ     IOJ         INTERRUPT LIST 
          SA3    B4          24/ L.TAG,  18/ _NEXT,  18/ IO.DOC 
          AX3    18 
          =B4    X3+1        SKIP THE COMMA 
 DOC2     SA2    B4 
          SB2    X2-O.) 
          NZ     B2,DOC4     IF NO REDUNDANT PAREN
          =B4    B4+1        SKIP REDUNDANT PAREN 
          EQ     DOC2 
  
 DOC4     AX3    18 
          SX2    X3          ISOLATE L.TAG OF THIS DO 
          MI     X3,DOC6     IF ERROR IN DO-DEFINITION
          RJ     PDT         PROCESS DO TERMINATION (PASS 1)
  
 DOC6     RJ     MXP         MARK EXTERNAL PROCESSOR
          =A1    B4+1 
          NZ     X1,LST.GO   IF NOT EOS 
          =A2    B4 
          SX2    X2-O.COMMA 
          NZ     X2,LST.GO   IF EOS, CHECK PRECEEDING ELEMENT 
          =B4    B4+1 
          EQ     LST.GO      EXIT.. 
 FFN      SPACE  4,8
**        FFN -  FIND FILE NAME.
* 
*                MANUFACTURES OBJECT PROGRAM FILE NAMES FROM THE SOURCE 
*         PROGRAM FILE-NAME.
*         ENTRY  (X6) = SOURCE-PROGRAM FILE NAME (0L FORMAT, 6 CHAR MAX)
*         EXIT   (X6) = OBJECT-PROGRAM FILE NAME (0L FORMAT). 
*         USES   A2  X1,X3  B7
  
  
 FFN      SUBR               ENTRY/EXIT...
          =X1    1
          SA2    =40404040404040404040B 
          IX1    X6-X1       LOCATE LOWEST BIT
          BX3    -X1+X6 
          SB7    60-CHAR+1
          BX1    X2*X3       40 WHERE CHARACTERS WERE 
          SA2    FFNA 
          LX3    X1,B7
          IX3    X1-X3
          IX1    X1+X3       77 WHERE CHARACTERS WERE 
          BX2    -X1*X2 
          IX6    X6+X2       MERGE TRAILING "FILE" CHARACTERS 
          AX1    CHAR        EXTEND MASK 1 CHAR MORE THAN NR OF ORIGINAL
          BX6    X1*X6       DROP SUPERFLOUS "FILE" 
          EQ     EXIT.
  
 FFNA     LIT    7L"FILE""FILE""FILE""FILE""FILE""FILE""FILE" 
 FFT      SPACE  4,8
**        FFT -  FIND FILE TAG. 
* 
*         ENTRY  (X5) = FILENAME
*                (B4) _ A CELL WHICH MAY BE CLOBBERED (USUALLY IN THE 
*                            *SB*). 
*         EXIT   (X5) = FILE TAG. 
*                     WILL BE ZERO IF NO SUCH FILE. 
*         USES   A1,A2,A3,A6,A7  X0  B2,B7
*         CALLS  FFN, NCS, TAGSEX, WARN, ADDREF, SCAN, ADSYM
  
  
*         PROCESS WHEN IN MAIN PROGRAM
  
 FFT5     SCAN   TS.SYM,SSY 
          MI     B7,FFT3     IF *NIT*, ERROR
          =X5    B7+C.VAR+1 
 FFT9     LX5    P.ATAG 
  
*         SET AVAR BIT FOR *WRITE* STATEMENT SO AS TO GET IOIND BIT SET 
  
          SA1    R.W
          SX2    X1          1 IF *WRITE* OR *PUNCH*, 0 OTHERWISE 
          LX2    P.AVAR 
          BX5    X5+X2
          SA1    REFLAG 
          NZ     X1,FFT      IF REFMAP ENTRY ALREADY, EXIT..
          SA1    IOREF
          ADDREF X5,X1
  
 FFT      SUBR               ENTRY/EXIT...
          BX6    X5 
          RJ     FFN         CREATE APPROPRIATE NAME
          SA2    MOD
          SA6    FILL.       SAVE FILE NAME FOR POSSIBLE ERROR MSG
          =X7    0
          SA7    REFLAG      INITIALIZE REFMAP FLAG 
          IFBIT  X2,PPRO,FFT5 
  
*         PROCESS WHEN IN SUBROUTINE/FUNCTION 
  
 FFT2     SA1    CO.EDT 
          MI     X1,FFT4     IF FILE LINKAGE SUPPRESSED 
          SA1    IOREF
          BX7    X1 
          SA7    REFVAR 
          SA6    B4 
          TAGSEX B4 
          =X7    1
          SA7    REFLAG      INDICATE REFMAP ENTRY
          BX5    X6 
          AX5    P.TAG
          EQ     FFT9        EXIT.. 
  
 FFT3     WARN   E.UE2
          EQ     FFT2 
  
  
**        PROCESS FILE TAG WHEN LINKAGE SUPPRESSED. 
*                (MAKE IT INDIRECT.)
  
 FFT4     SCAN   TS.SYM,SSY 
          PL     B7,FFT45    IF ALREADY IN TABLE
          =X7    M.NVAR 
          ADSYM  A1          ADD TO SYMBOL TABLE
 FFT45    SA1    IOREF
          BX6    X5 
          SA6    SAVNAM      SAVE FILE NAME 
          =X5    B7+C.VAR+1 
          LX5    P.ATAG 
          ADDREF X5,X1
          =X7    1
          SA7    REFLAG      INDICATE REFMAP ENTRY
          SA5    SAVNAM      RETRIEVE FILE NAME 
          BX6    X5 
          MX7    0
          RJ     NCS         ENTER FILE NAME IN CONSTANT TABLE
          =X2    1
          LX2    P.AFIT 
          BX5    X6+X2       SET VARIABLE FIT BIT 
          LX5    -P.ATAG
          EQ     FFT9        EXIT.. 
  
 SAVNAM   BSS    1
 REFLAG   DATA   0
          SPACE  4,8
**        ILI -  INITIAL LIST ITEMS.
* 
*                ADDS HEADER LIST ITEMS TO I/O AP-LIST. 
*         IF ANY ITEM IS ZERO, IT AND SUBSEQUENT ITEMS ARE NOT ADDED. 
*         EXCEPT FOR *ERR=,END=* ADDRESSES, IF DEFINED
*                A.  (IO1ST)
*                B.  (IO2ND)
*                C.  (IO3RD)
*         EXIT   (X1) = NUMBER OF ITEMS ADDED.
*         USES   A1,A2,A3,A6  X0  B2,B3,B7
  
  
 ILI      SUBR               ENTRY/EXIT...
          SA2    IO1ST
          BX6    X2 
          ADDWD  TP.APL      FIT DESIGNATOR TO AP-LIST
  
          SA2    IO2ND
          SX1    B1 
          BX6    X2 
          ZR     X2,ILI.1    IF NO FORMAT (FIT ONLY)
          ADDWD  TP.APL      FORMAT OR RECORD LENGTH TO AP-LIST 
  
          SA2    IO3RD
          =X1    2
          BX6    X2 
          ZR     X2,ILI.1    IF NO COUNT (NOT EN/DE CODE) 
          ADDWD  TP.APL      COUNT DESIGNATOR TO AP-LIST
          SA2    IO4TH
          SX1    3
          BX6    X2 
          ZR     X2,EXIT.    IF NOT BUFFER I/O
          ADDWD  TP.APL 
          SX1    4
          EQ     EXIT.
 ILI.1    SA2    IODIR
          NZ     X2,EXIT.    IF WRITE, DON/T PUT OUT END/ERR WORD 
          SA3    IOENDT 
          =X6    X1+1 
          LX3    P.ATAG 
          SA6    SAVNAM            SAVE COUNT IN TEMPORARY
          BX6    X3 
          ADDWD  TP.APL      ADDRESS WORD TO APLIST 
          SA1    SAVNAM            RESTORE COUNT
          EQ     EXIT.
 IOD      SPACE  4,45 
**        IOD -  MARK OCCURANCES OF IMPLIED DO-LOOPS IN I/O LIST. 
* 
*                BEING A SIMPLE SCHEME FOR DISCOVERING AND MARKING THE
*         EXTENT OF (ANY) IMPLIED-DOS IN AN I/O LIST.  A PSEUDO-STACK 
*         OF PARENTHESES IS KEPT IN THE STRING ITSELF, BY STORING OVER
*         TOP OF EVERY LEFT PAREN THE ADDRESS OF THE PRECEDING ONE. 
*         THIS STACK IS POPPED UP FOR EVERY RIGHT PAREN ENCOUNTERED BY
*         RESETTING THE STACK POINTER (B5) TO THE ADDRESS CONTAINED IN
*         THE LAST LPAREN, AND RESTORING THE LPAREN TO ITS ORIGINAL 
*         VALUE (O.LP).  THUS, WHEN AN EQUAL SIGN IS ENCOUNTERED, THE 
*         TOP OF THE STACK IS ITS OPENING DO-PAREN.  THAT CELL IS 
*         MODIFIED SUCH THAT WHEN THE CLOSING RPAREN IS POPPED, THE 
*         SUPPOSED RESTORATION WILL ACTUALLY TURN IT INTO A DO-BEGIN
*         MARK.  REDUNDANT (NON-DO-IMPLYING) PARENS ARE THEREFORE 
*         EFFECTIVELY IGNORED.
*                AS TRUE DO-IMPLIED PARENS ARE DISCOVERED, WE INSERT
*         *O.EOS* MARKS IN FRONT OF THEM SO THAT THE PARSER WILL LATER
*         STOP THERE AND ALLOW *LST* TO LOOK AT THE DO-BEGIN MARK.
*         THIS IS INHIBITED IF THE LPAREN IS NOT PRECEDED BY A COMMA, 
*         SINCE WHATEVER ELSE IS THERE WILL BE HANDLED BY *LST*, AND NOT
*         THE PARSER. 
*                OF COURSE, ANY LEFT PAREN PRECEDED BY A VARIABLE IS A
*         SUBSCRIPT PAREN, AND IS SKIPPED OVER. 
* 
*         ENTRY  (B4) _ FWA I/O LIST. 
*         EXIT   INTO *LST*.
*                (B4) PRESERVED.
*         USES   ALL BUT A0, B4.
*         CALLS  SKS. 
* 
*         REGISTER ASSIGNMENTS -- 
*                (A4) _ FETCH ADDRESS.
*                (B5) _ LAST LPAREN LINK. 
*                (B6) = PAREN LEVEL.
  
  
 IOD8     NZ     B6,E.IOD1   IF IMBALENCED PARENS.
          BX6    O.EOS
          SA6    A4          RESET THE EOS FOR PAR
          =A6    A4+1        ADD AN EXTRA *EOS* FOR *LST* 
  
 SNAP     IFNE   TEST        DUMP *SB*
          SA1    CO.SNAP
          LX1    1RN         DO SNAP FLAG 
          PL     X1,IODX     IF I/O SNAP NOT REQUESTED
          RJ     =XSVR
          PLINE  (=C= (DUMP OF *SB* -- FROM I/O DO-MARKER.)=),4,1 
          RJ     =XSBL       LIST STRING BUFFER 
          RJ     =XRSR
 SNAP     ENDIF 
  
          EQ     IODX        EXIT.. 
  
 IOD      BSS    0           ENTRY... 
          SX6    O.SLP
          =A6    B4-1        RESET LAST CHARACTER OF UNIT/FORMAT
                             DESIGNATOR TO  PROTECT UNARY MINUS IN I/O
                             LIST 
          SA4    B4          INITIALIZE FETCH 
          =B6    0           PAREN LEVEL
          MX4    0
          =B5    B4-1        FAKE UP A LINK TO LAST LPAREN
  
 IOD2     BX3    X4 
          =A4    A4+1 
          =B7    X4-O.LP
          ZR     X4,IOD8     IF *EOS* 
          =B2    B7+O.(-O.) 
          ZR     B7,IOD6     IF *(* 
          ZR     B2,IOD4     IF *)* 
          NE     B2,B1,IOD2  IF NO *=*, LOOP..
  
**        FOUND A *=*  --  MARK CLOSE OF IMPLIED DO.
  
          =X7    A4-1        POINTS TO DO-INDEX 
          =X2    IO.DOB-O.LP
          LX7    18 
          BX0    X7+X2
          SA3    B5 
          LX0    18 
          IX7    X0+X3
          =A3    B5-1 
          SA7    B5          MARK DO-BEGIN (OVER THE LPAREN)
,                            24/ LINK-TO-INDEX,  18/ IO.DOB,  18/ PREV
          SA2    A4-2 
          SB7    X2-O.COMMA 
          NZ     B7,E.IOD2   IF IMPLIED DO NOT PRECEEDED BY *,* 
          EQ     IOD2 
  
  
**        FOUND A *)*  --  POP UP PAREN STACK.
  
 IOD4     SA2    B5 
          =X6    1
          =B6    B6-1 
          SB5    X2          LINK BACK ONE MORE PAREN LEVEL 
          AX2    18 
          LX6    18 
          MI     B6,E.IOD3   IF TOO MANY RPARENS (RETURN PSP) 
          SX7    A4 
          LX7    36 
          BX7    X2+X7       6/0,18/_),18/LINK TO INDEX,18/IO.DOB OR O.(
          IX6    X4+X6       CONSTRUCT SPECIAL RP 
          SA7    A2          RESTORE LPAREN (OR DOB MARK) 
          SA6    A4          SPECIAL RP 
          EQ     IOD5 
  
  
**        FOUND A *(*  --  PUSH DOWN PAREN STACK. 
*                HOWEVER, IF THIS IS A SUBSCRIPT PAREN (PRECEDING 
*                ELEMENT IS *O.VAR*), SKIP OVER THE SUBSCRIPT AND ANY 
*                PAIRED PARENS WITHIN IT, AND DO NOT MESS UP THE STACK. 
  
 IOD6     =B2    X3-O.VAR 
          NZ     B2,IOD7     IF A FREE-STANDING PAREN 
          RJ     SKS         SKIP OVER THE SUBSCRIPT
 IOD5     SA2    A4+B1       A2 POINTS TO NEXT ELEMENT TO PROCESS 
          SB2    X2-O.VAR 
          ZR     B2,IOD50    IF *)* FOLLOWED BY *O.VAR* 
          SB2    X2-O.CONS
          ZR     B2,IOD50    IF *)* FOLLOWED BY *O.CONS*
          SB2    X2-O.LP
          ZR     B2,IOD50    IF *)* FOLLOWED BY *(* 
          EQ     IOD2 
  
 IOD50    SB4    A2 
          EQ     E.IOD4      EXPECTED COMMA - RETURNS TO MAIN(CPM)
  
 IOD7     =B6    B6+1        INCREMENT LEVEL COUNTER
          LX4    18 
          SX0    B5 
          SB5    A4          LINK NOW TO THIS PAREN 
          IX7    X0+X4
          SA7    A4          THIS PAREN LINKS BACK TO LAST ONE
,                            42/ O.(,  18/ PREV 
          EQ     IOD2 
 IOJ      SPACE  4,8
**        IOJ -  COMPILE JUMP TO I/O ROUTINE. 
* 
*         ENTRY  (X6) = TERMINATION CODE -- 
*                       -0 = INTERRUPTION OF LIST.  NOTHING COMPILED IF 
*                            LIST IS EMPTY. 
*                       +0 = TERMINAL CALL.  MUST BE COMPILED.
*                (IOLEN)  = LENGTH OF CURRENT LIST. 
*                (ROUTNAM)= ADDRESS OF ROUTINE NAME.  IF THE INITIAL
*                            CALL HAS NOT YET BEEN COMPILED, IT IS
*                            COMPLEMENTED.
*         EXIT   (IOLEN) = ZERO, INDICATING EMPTY LIST. 
*                A *O=IOJ* TRIPLE HAS BEEN ADDED TO THE PARSED FILE.
*                     1OP --  APTAG / TRACEBACK 
*                     2OP --  SUBROUTINE TAG
*         (CURST) RESET TO (TT=PAR),   TO PREVENT THINGS FROM GETTING 
*                MOVED AROUND TO THE WRONG PLACE. 
* 
*         USES   ALL BUT  A0  B4
*         CALLS  ADDWD, CLOAD, CRJ, TAGSEX. 
  
  
 IOJ      SUBR               ENTRY/EXIT...
          SA5    IOLEN
          BX4    X6          SAVE (X6)
          PL     X6,IOJ1     IF HARD END, MUST COMPILE
          ZR     X5,EXIT.    IF EMPTY LIST, IGNORE..
 IOJ1     PL     X5,IOJ2     IF NOT VERY FIRST ITEM 
          RJ     ILI
          BX5    X1 
          LX6    X4          RESTORE (X6) 
  
 IOJ2     ADDWD  TP.APL      APPEND TERMINATOR TO AP-LIST BEING MADE. 
          SA1    IOAPT
          SA2    TG.APL 
          =B3    X5+1 
          SX6    X1-1 
          =X5    1           INDICATE NO TRACE-BACK 
          =X7    X2+1 
          SA6    A2          RESET (TG.APL) MOMENTARILY, TO FORCE *NAP* 
,                            TO GENERATE THE TAG WE WANT. 
          SA7    A1 
          RJ     NAP         FIND / ENTER AP-LIST 
          SA3    IONAM
          BX4    X6          SAVE AP-LIST TAG 
  
          PL     X3,IOJ4     IF NOT INITIAL CALL
          BX3    -X3
          =X6    X3+S=CONT   RESET ROUTINE NAME TO CONTINUATION TYPE
          BX5    0           FORCE TRACEBACK
          SA6    A3 
  
 IOJ4     SB5    B4          SAVE (B4)
          BX5    X5+X4       SAVE (APTAG, TRACE)
          TAGSEX X3+S.IOCAL 
          BX4    X6          SAVE ROUTINE TAG 
          RJ     MXP
  
          ALLOC  TT.PAR,L.TURP
          BX6    X4          (2OP) = SUBROUTINE TAG 
          LX7    X5          (1OP) = APTAG + TRACEFLAG
          SA1    CALLIO 
          =A6    B7-L.TURP+OR.2OP 
          =A7    A6-OR.2OP+OR.1OP 
          LX6    X2 
          BX7    X1 
          SA6    CURST
          =A7    A7-OR.1OP+OR.OPR 
          SB4    B5          RESTORE (B5) 
          BX7    0
          SA1    IOAPT
          BX6    X1          RESTORE (TG.APL), RESERVING NEXT ORDINAL 
          SA7    A5          RESET LIST LENGTH TO EMPTY 
          SA6    TG.APL 
          SHRINK TP=ILI,X7
          EQ     EXIT.
 LST      SPACE  4,30 
**        LST -  PROCESS INPUT/OUTPUT LIST
* 
*         CALLED BY ALL I/O STATEMENT PROCESSORS WHICH HAVE AN I/O LIST.
* 
*         FORMAT/NAMELIST DESIGNATOR HAS ALREADY BEEN STORED IN *APLIST*
* 
*         EACH ITEM TO BE TRANSMITTED IS THEN EXAMINED, AND LOOPS 
*                COLLAPSED (WHERE POSSIBLE), AND INTERMEDIATE CALLS 
*                COMPILED AS NECESSARY.  *HBL* AND *HCL* ARE USED TO
*                COMPILE IMPLIED-DO INSTRUCTIONS. 
*         PROCESSING IS SLIGHTLY DIFFERENT FOR *NAMELIST*, IN THAT THERE
*                IS ACTUALLY NO LIST TO DO, SO WE COMPILE AN *RJ* AND 
*                QUIT.
*         SEE THE WRITE-UPS OF THE OBJECT LIBRARY ROUTINES FOR THE GORY 
*                DETAILS. 
* 
*         ENTRY  *PFD* HAS INITIALIZED I/O PROCESSING.
*                (B4) _ SEPARATOR IN FRONT OF I/O LIST. 
*                (B6) INDICATES I/O METHOD (SEE S.IOCALL).
* 
*         EXIT   TO MASTER LOOP.
* 
*         USES   ALL REGISTERS
*                *ROUTNAM* TO SAVE ROUTINE TAG
*         CALLS  ADDWD, CAI, CLOAD, CRJ, IOD, IOJ, NAP, PAR, TAGSEX.
  
  
 LST      BSS    0           ENTRY... 
          SA2    B4 
          ZR     X2,LST1     IF NO I/O LIST 
          =A1    B4+1 
          =A2    A1+1 
          =A3    R.W
          SX1    X1-O.COMMA 
          NZ     X1,LST1     IF NOT EXTRANEOUS COMMA
          ZR     X3,LST12    NOT LIST DIRECTED IO 
          ZR     X2,E.IO27   IF LIST DIRECTED WITH *,* AND NO IOLIST. 
 LST12    WARN   =XE.IO2
          =B4    B4+1 
          EQ     LST         CONTINUE COMMA CHECK 
 LST1     SA1    IODIR
          NZ     X1,LST.S    OUTPUT DIRECTION 
          SA3    TG.APL 
          BX6    X3 
          SA6    IOENDT      USE THE APLIST TAG AND 
          =X7    X6+1         GET A NEW APLIST TAG
          SA7    IOAPT
          SA7    A3 
  
 LST.S    BSS    0           **** ENTRY FOR ENCODE/DECODE ****
          SA1    IOARGT 
          =A2    A1-IOARGT+IOREF
          BX6    X1          SET DIRECTION INTO ARG MODE
          LX7    X2 
          SA3    B4 
          SA6    ARGMODE
          SX6    B6 
          SA7    REFVAR 
          BX6    -X6         INDICATE NO I/O CALLS YET
          SA6    IONAM
          MI     B6,LST.N    IF NAMELIST OPERATION
          ZR     X3,LST.X    IF EMPTY LIST
          EQ     IOD         MARK DO-LOOPS. 
 IODX     BSS    0           ** RETURN FROM *IOD* 
  
          SX6    O.COMMA
          SA6    B4          SET OFF I/O LIST 
 LST.GO    SPACE 2,25        (IN COL 12 TO HIDE FROM *DOCK*)
**
*         LST.GO - PROCESS NEXT ELEMENT OF THE I/O LIST.
* 
*         ENTRY  (B4) _ CURRENT ELEMENT, MINUS ONE. 
* 
*         FIRST, EXAMINE ELEMENT AND DETERMINE WHAT TO DO --
*                <EOS>  _ END-OF-STRING.  CONCLUDE I/O LIST AT "LST.X". 
*                IO.DOB _ DO-BEGIN.  GO TO "DOB" TO COMPILE DO INITIAL
*                         TURPLES.  RETURN TO HERE FOR NEXT ELEMENT.
*                IO.DOC _ DO-CLOSE.  GO TO "DOC" TO COMPILE IMPLIED-DO
*                         CONCLUSION TURPLE.  RETURN TO HERE FOR ELEMENT
*                         PAST THE DO.
*                IO.NIL _ NOTHING.  SOMETHING HAS BEEN ERASED FROM THE
*                         I/O LIST.  IGNORE IT. 
*                IO.BRK _ BREAK.  AN INTERMEDIATE INTERRUPTION OF THE 
*                         LIST IS NEEDED FOR SOME REASON.  CALL "IOJ" 
*                         FOR A SOFT TERMINATION (-0).
*                <ELSE> _ A SIMPLE (OR ERRONEOUS) LIST IS AT HAND.
*                         PARSE IT. 
  
  
 LST.GO   =A2    B4+1        FETCH ELEMENT
          =B4    B4+1 
          SB7    X2-IO.DOC
          ZR     X2,LST.X    IF END OF LIST 
          MI     B7,LST4     IF SIMPLE LIST 
          JP     B7+*+1 
  
          LOC    IO.DOC 
          EQ     DOC         DO-CONCLUSION
          EQ     DOB         DO-BEGIN 
          EQ     LST.GO      NIL -- IGNORE
          LOC    *O 
  
**
*         HANDLE SIMPLE, BREAK-FREE LIST. 
*         *PAR* DOES THE DIRTY WORK, CALLING ON THE COMMA CHECKER 
*         *C=IOL* AT STRATEGIC POINTS.  HE WILL RETURN TO US UPON 
*         FINDING AN *EOS*, WHICH MAY HAVE BEEN INVENTED BY SOME I/O
*         LIST PROCESSING.  RETURN TO *LST.GO* TO CHECK.
  
 LST4     SB7    X2-O.( 
          NZ     B7,LST4B    IF NOT *(* 
  
*         REMOVE ANY EXTRANEOUS *(*.  IF ELEMENT AFTER *)* IS NOT AN
*         OPERATOR, THE PARENS MAY BE EXTRANEOUS. 
  
          AX2    36 
          =A3    X2+1        *SB* AFTER *)* 
          SX6    B4 
          SA4    B4          POINT TO *(* 
          ZR     X3,LST4A    IF *EOS* 
          SB3    X3-O.COMMA 
          SB2    X3-O.) 
          ZR     B3,LST4A    IF *,* 
          NZ     B2,LST4B    IF NOT *)* 
 LST4A    SA6    SCR         SAVE B4
          RJ     CFC         CHECK FOR CPLX CONST 
          SA2    SCR
          SB4    X2          RESTORE B4 AT *(*
          NZ     X0,LST.GO   IF NOT CPLX CONST, REMOVE *(*
 LST4B    RJ     PAR         IF NOT REDUNDANT PAREN 
          =B4    B4+1 
          EQ     LST.GO 
  
  
**
*         HERE TO WRAP-UP WHEN END OF LIST IS REALLY ENCOUNTERED -- 
*         THE OUTCOME OF ALL THIS ACTIVITY HAS BEEN TO CREATE SOME
*         AP-LISTS, AND A PARSED FILE.  SINCE WE CANNOT OPTIMIZE
*         ANYTHING ACROSS EXTERNAL CALLS, WE CALL *ARITH* NOW TO
*         GENERATE CODE FROM THE PARSED FILE. 
*                THEN, JUST IN CASE, INSURE THAT ALL IMPLIED DO-S WERE
*         TERMINATED, AND THAT THE DO-TABLE IS THE SAME AS IT WAS WHEN
*         THIS STATEMENT STARTED. 
  
 LST.X    =A1    A2-2 
          SA3    R.W
          SX1    X1-O.COMMA 
          SA4    IODIR
          NZ     X1,LST5     IF *EOS* NOT PRECEEDED BY *,*
          ZR     X3,E.IOL5   IF NOT LIST DIRECTED IO. 
          ZR     X4,E.IOL5   IF INPUT DIRECTION 
          =X6    IO=CM+"AP=UIOC"S"ATYP" 
          ADDWD  TP.APL 
          SA4    IOLEN       *,* TERMINATED IO, SO ADJUST AP-LIST LENG. 
          =X6    X4+1 
          SA6    A4 
  
 LST5     BX6    0
          RJ     IOJ         COMPILE TERMINAL CALL
  
          SA1    TG.APL 
          SX6    X1-1        WE USED ONE TAG TOO MANY -- FIX IT 
          SA6    A1 
  
          SA4    IOENDT 
          ZR     X4,LST7     IF NO GENERATED TAG FOR *END*
          SA1    TT.PAR 
          SB3    O=BSS
          RJ     EMT         EMIT  (O=BSS, GENERATED TAG) 
 LST7     BSS    0
  
          RJ     CAI         COMPILE ARITHMETIC INSTRUCTIONS. 
  
          SA3    IODOLEN
          SA2    TP=DO
          BX0    X2-X3       CHECK FOR UNPROCESSED DO-S 
          LX6    X3 
          ZR     X0,PSN      IF ALL DO-S BALANCED, EXIT.. 
          SHRINK TP=DO,X6    RESET DO TABLE 
          EQ     E.IO14 
  
  
**
*         HERE WE PROCESS *NAMELIST* CALLS -- 
*                THERE IS NO LIST INVOLVED, AND A GROUP NAME MAY NOT BE 
*         SUBSCRIPTED, SO OUR TASK IS SIMPLE ENOUGH TO AVOID INVOKING 
*         THE PARSER.  WE EMIT CODE DIRECTLY TO LOAD THE AP-LIST ADDRESS
*         AND RJT TO THE NAMELIST GUY.  ISSUE INFORMATIVE DIAGNOSTIC IF 
*         THERE IS A LIST PRESENT (MISTAKENLY). 
  
 LST.N    ANSI   E.ION1 
          SA1    IODIR
          SA5    B4 
          AX2    X1,B1       DIRECTION / 2
          SB3    S.IOCAL
          SB3    -B3
          SX6    B3+S.NLST
          IX6    X6+X2
          BX6    -X6         INDICATE NO I.O CALLS YET
          SA6    IONAM
          ZR     X5,LST5     IF *EOS* -- EXIT O.K.
          SB3    X5-O.) 
          NZ     B3,LST.N1   IF NOT *RP*
          SA5    B4+1 
          ZR     X5,LST5     IF *EOS* -- EXIT OK
 LST.N1   EQ     E.ION
 NDC      SPACE  4,12 
**        NDC -  ENCODE / DECODE ARGUMENTS. 
* 
*         XXCODE (COUNT, FORMAT, STRING-ADDRESS) IOLIST 
*                '                             '
*         B4 _   ENTRY                         EXIT 
* 
*         ENTRY  (B4) _ LPAREN IN STRING-BUFFER.
*                (B6) = DIRECTION.
* 
*         EXIT   TO *LST* WITH -- 
*                (B4) _ RPAREN IN *SB*. 
*                (B6) = DIRECTION + *STRING* MODE.
* 
*         CALLS  PAR, PFD, PTN. 
  
  
 NDC      ANSI   E.ANS       NON-ANSI STATEMENT 
          SA7    IOREF
          SA1    =XSTATIC 
          BX6    X1+X4
          SA6    A1          UPDATE STATIC LOAD INFORMATION 
          RJ     PFD
  
**        ASSEMBLE RECORD LENGTH. 
  
          =A4    B4-1 
          =B2    X4-O.LP
          ZR     X4,E.IOS6   IF PREMATURE EOS 
          ZR     B2,NDCE1    IF LEFT PAREN
          =B4    B4-1 
          EQ     E.IOS1      ERROR - END OF SCAN
 NDCE1    SA2    IOREF
          SA1    NDC=CNT
          LX2    P.AMR
          BX6    X1+X2
          SA6    ARGMODE
          SA4    B4 
          SB2    X4-O.CONS
          =A3    A4+1 
          EQ1    B2,NDCE2    IF VARIABLE
          SX3    X3-O.PERIOD
          NZ     B2,E.IOS9   IF NOT CONS
          ZR     X3,E.IOS9   IF FLOATING POINT
 NDCE2    RJ     PAR         PARSE RECORD COUNT 
          =A4    B4+1 
          =B4    A4+1        POINT TO FORMAT
          =B2    X4-O.COMMA 
          ZR     X4,E.IOS6   IF PREMATURE EOS 
          NZ     B2,E.IOS2   IF NO COMMA
  
**        PROCESS THE FORMAT DESIGNATOR.
*                CALLS *PTN* TO DO THE DIRTY WORK.
  
          =B6    0
          SA4    B4 
          SB2    X4-O.CONS
          EQ1    B2,NDCE3    IF VARIABLE
          NZ     B2,E.IOS10  IF NOT CONSTANT
 NDCE3    BX7    0
          SA7    ASSUNIT     SET RETURN CONDITION 
          RJ     PTN         PROCESS FORMAT DESIGNATOR
          SA4    B4 
          NZ     B6,E.IOS3   IF NAMELIST NAME 
          =B2    X4-O.COMMA 
          ZR     X4,E.IOS6   IF PREMATURE EOS 
          NZ     B2,E.IOS4   IF NO COMMA
  
**        DIGEST STRING ADDRESS.
  
          =X6    O.SLP
          SA2    IOREF
          SA1    NDC=STR
          LX2    P.AMR
          BX7    X1+X2
          SA7    ARGMODE
          SA6    B4 
          =A4    B4+1 
          =B2    X4-O.VAR 
          NZ     B2,E.IOS7   IF NOT VARIABLE
          RJ     PAR         PARSE STRING ADDRESS 
          SA4    B4 
          =B2    X4-O.RP
          NZ     B2,E.IOS5   IF NO RIGHT PAREN
          =A4    B4+1 
          =B2    X4-O.VAR 
          ZR     B2,NDCE5    CHECK FOR VARIABLE 
          =B2    X4-O.LP
          ZR     B2,NDCE5    CHECK FOR LEFT PAREN 
          =A4    A4+1 
          =B2    X4-O.LP
          NZ     B2,NDCE5    IF NOT LEFT PAREN
          =A4    A4-1 
          MX0    L.CDPC 
          SA1    X4+CHARMAP 
          BX6    X0*X1
          SA6    FILL.       SET FILLER 
          FATAL  =XE.AT10 
          =B4    B4+1 
 NDCE5    SA3    IODIR
          =B6    X3+S=STR 
          EQ     LST.S       EXIT..  (TO PROCESS I/O LIST)
 PFD      SPACE  4,30 
**        PFD -  PROCESS FILE DESIGNATOR. 
* 
*                INITIALIZES I/O STATEMENT AP-LIST GENERATION.
*         INITIALIZES SOME PARSER CONTROL CELLS.
* 
*         ENTRY  (X5) = FILE DESIGNATOR.
*                (B6) = DIRECTION INDICATOR.
* 
*         EXIT   FILE DESIGNATOR IS IN (IOFIT). 
*                (B4) ADVANCED BY ONE.
*                (B6) PRESERVED.
*                FLAGS SET TO *NOT-NECESSARY* STATE --
*                            (IO2ND)
*                            (IO3RD)
*                            (IO4TH)
*                            (RTEND)
*                            (RTERR)
                             (IOENDT) 
*                (IOLEN) = -1 TO INDICATE FIRST LIST ITEM.
*                (IODIR)   =  (B6)     FOR TESTING DIRECTION. 
*                (IOAPT)   = AP-TAG FOR FIRST I/O AP-LIST.
*                (IOARGT)  =  A=DIR    FOR SETTING (ARGMODE) LATER. 
*                (IOREF)   =  CR.DIR   FOR X-REF. 
*                (ARGMODE) =  **       NOT SET. 
*                (ARGCOMA) =  0        FOR ALL PARSING. 
*                (IODOLEN) =  (TP=DO)  FOR LATER RESETTING. 
*                (TG.APL)  = ADVANCED.
* 
*         USES   ALL NOT EXPLICITLY MENTIONED ABOVE.
  
  
 PFD      SUBR               ENTRY/EXIT...
          SA1    IOARGM 
          SA3    TP=DO
          SX7    B6 
          NZ     B6,PFD2     IF OUTPUT DIRECTION
          =A1    A1+1 
 PFD2     SA7    IODIR
          BX6    X1 
          =B4    B4+1        ADVANCE (B4) 
          BX7    X5 
          AX1    P.AMR
          =A7    A7-IODIR+IOFIT 
          =A6    A7-IOFIT+IOARGT
          BX7    X1 
          =A7    A6-IOARGT+IOREF
          MX7    -1 
          =A7    A7-IOREF+IOLEN 
          =X7 
          LX6    X3 
          =A7    A7-IOLEN+IO2ND 
          =A7    A7-IO2ND+IO3RD 
          =A7    A7-IO3RD+IO4TH 
          SA7    ARGCOMA
          SA6    IODOLEN
          SA1    TG.APL 
          =X6    X1+1        ADVANCE AP-TAG 
          SA6    IOAPT
          SA7    IOENDT 
          SA6    A1 
          EQ     EXIT.
 PTN      SPACE  4,8
**        PTN -  PROCESS FORMAT/NAMELIST DESIGNATOR 
* 
*         ENTRY  (B4) _ FORMAT DESIGNATOR.
*         EXIT   (B4) _ NEXT CHAR AFTER FORMAT. 
*                (B6) RESET FOR *NAMELIST*, IF APPROPRIATE. 
*                (IOFMT) = FORMAT DESIGNATOR AP-LIST ENTRY. 
*         CALLS  ISN, PAR, SKS, TRV.
  
  
**        HERE WHEN NAMELIST. 
  
 PTN8     SB6    B6+S=NLST   INDICATE NAMELIST OPERATION
  
**        HERE WITH --
*                (X6) = TAG FOR FORMAT DESIGNATOR.
  
 PTN9     MX0    L.ATAG 
          BX6    X0*X6
          SB4    B4+B1       POINT PAST FORMAT
          SA6    IOFMT
  
  
 PTN      SUBR               ENTRY/EXIT...
          SA1    B4 
          SA3    IOREF
          MX7    0
          BX6    X3 
          SA7    R.W         INDICATE FORMATTED, NOT LIST-DIRECTED I/O. 
          =B2    M.SNFMT+M.SNREF
          SA6    REFNUM 
          ZR     X1,E.IO7    IF *EOS* -- ERROR
*         =X6    CR.FMT 
*         =A6    A6-REFNUM+REFVAR 
          SX2    X1 
          BX6    X1-X2
          SB7    X1-O.CONS
          NZ     B7,PTN2     IF NO NUMBER 
          RJ     ISN         IDENTIFY STATEMENT NUMBER
          EQ     PTN9 
  
  
**        HERE IF NON-NUMERIC.  WILL BE VARIABLE FORMAT OR NAMELIST.
  
 PTN2     BSS    0
          SB7    X1-O.VAR 
          NZ     B7,E.IO7    IF NOT VARIABLE EITHER 
          RJ     TRV         TRANSLATE VARIABLE 
 PTN3     BX1    X6 
          IFBIT  X1,NLST,PTN8          IF *NAMELIST*
  
  
**        HERE WE WRESTLE WITH VARIABLE FORMATS.
*                (IT IS NOT CLEAR WHO IS WINNING.)
  
          SX6    B6 
          SA2    IOREF
          SA1    PTN=FMT
          LX2    P.AMR
          BX7    X1+X2
          SA7    ARGMODE
          SX7    O.SLP
          SA6    IONAM       SAVE (B6)
          =A7    B4-1 
          =B4    B4-1 
          RJ     PAR         PARSE THE FORMAT DESIGNATOR
          SA2    IONAM
          SB6    X2          RESTORE (B6) 
          SA1    B4 
          ZR     X1,EXIT.     IF EOS
          =A2    A1+1 
          SB7    X2-O.COMMA 
          NZ     B7,EXIT.    IF NO COMMA, NOT PRINT FMT, STATEMENT
          SB7    X1-O.) 
          NZ     B7,PTN10    IF NOT FORM *PRINT(U,FMT)* 
          SA1    ASSUNIT
          ZR     X1,PTN10    IF NOT FORM *PRINT(U,FMT)* 
          EQ     EXIT.
 PTN10    =B4    B4+1 
          EQ     EXIT.
  
 ASSUNIT  DATA   0           INDICATOR IF UNIT DESIGNATOR EXPLICIT
 RTC      SPACE  4,15 
**        RTC -  ASSEMBLE AND CHECK TAPE NAME 
*         CALLED BY ALL I/O STATEMENTS WHICH CONTAIN AN EXPLICIT *TAPE
*                NUMBER* DESIGNATOR.
*         ENTRY  X6 = I/O DESIGNATOR, WHICH MAY BE EITHER A VARIABLE
*                     NAME OR AN INTEGER CONSTANT FROM 1 TO 99 (ANY 
*                     LEADING ZERO WILL BE DISCARDED).
*                     IF THE DESIGNATOR IS AN INTEGER CONSTANT, THE FILE
*                     NAME WILL BE *TAPE_<INTG-CONST>*. 
*                 B4 _ A CELL (USUALLY IN *SB*) WHICH MAY BE CLOBBERED. 
*         EXIT   (X5) = 1/VAR, 11/0, 18/FITADR-TAG, 30/0
*         USES   A1,A2,A3,A5,A6  X0  B2,B7
*         CALLS  FFT, TRV 
  
  
  
 RTC8     SA5    =0LTAPE
          LX6    -4*CHAR
          BX5    X6+X5       ADD IN VARIABLE
          RJ     FFT         FIND FILE TAG
  
 RTC      SUBR               ENTRY/EXIT...
          ZR     X6,E.IO1    IF NO UNIT SPECIFIED - ERROR 
          SX5    X6 
          SB7    X6-O.VAR 
          ZR     B7,RTC2     IF VARIABLE NAME 
          SB7    X6-O.CONS
          ZR     B7,RTC1     IF NUMBER
          SA2    X6+=XCHARMAP 
          MX0    L.CDPC 
          BX6    X0*X2
          SA6    FILL.
          EQ     E.IO        IF NOT NUMBER OR VARIABLE
 RTC1     BX6    X6-X5       DROP MAP SYMBOL
          MX5    2*CHAR 
          BX5    -X5*X6 
          NZ     X5,E.IO3    IF MORE THAN TWO DIGIT NUMBER - ERROR
          BX5    X6 
          LX5    CHAR 
          SB7    X5-1R0 
          NZ     B7,RTC8     IF NO LEADING ZERO 
          SA6    FILL.
          LX6    CHAR 
          SX5    X5 
          BX6    X6-X5       SUPPRESS LEADING ZERO
          NZ     X6,RTC8     IF NOT UNIT ZERO 
          LX5    9*CHAR 
          BX6    X5 
          EQ     RTC8 
  
 RTC2     =B4    B4+1 
          SA6    B4 
          RJ     TRV         TRANSLATE NAME 
          =B4    B4-1 
          =X5    1
          =X2    "AP=SIZ"S"ATYP"
          LX5    P.AFIT 
          SA3    R.W
          MX0    1
          BX0    X0-X3
          ZR     X0,RTC3     IF PRINT 
          =X3    1
          LX3    P.AVAR      SET AVAR BIT 
          BX5    X5+X3
 RTC3     AX6    P.TAG
          SX3    X1-M.INT 
          IX5    X5+X2
          LX6    P.ATAG 
          BX5    X5+X6       INDICATE VARIABLE *FIT*
          CLAS=  X2,(NVAR,NLST,EXT,ENT) 
          BX6    X2*X6
          ZR     X3,RTC4     IF TYPE INTEGER
          NZ     X1,E.UE     IF NOT UNIVERSAL TYPE
 RTC4     NZ     X6,E.UE1    IF NOT SIMPLE LOCAL VARIABLE 
          EQ     EXIT.
 SKS      SPACE  4,8
**        SKS -  SKIP OVER SUBSCRIPT. 
*         ENTRY  (A4) _ *(*.
*         EXIT   (A4) _ *)*.
*         USES   B2,B3,B7 
  
  
 SKS2     SB3    B3+1 
  
 SKS4     SA4    A4+B1
          SB7    X4-O.LP
          ZR     X4,E.IO11   IF *EOS*, ERR..
          ZR     B7,SKS2     IF LPAREN
          IFNE   O.RP-O.LP,1,1
          ERR    (SKS) --  O.LP + 1  .NE.  O.RP 
          NE     B7,B1,SKS4  IF NO RPAREN, LOOP.. 
          SB3    B3-B1       DECREMENT PAREN LEVEL COUNT
          GT     B3,SKS4     IF A LOWER LEVEL 
          MI     B3,E.IO12   ERR.. IF TOO MANY LEFT PARENS. 
  
 SKS      SUBR               ENTRY/EXIT...
          SB3    B1 
          EQ     SKS4 
 C=IO     EJECT  4,8
**        AAE -  ANALYZE AP-LIST ENTRY. 
* 
*         ENTRY  (X3, X4, X5) AS IN *POP*.
* 
*         EXIT   (X6) = (ATAG) AND (ABIAS) FIELDS FOR AP-LIST.
*                (X5) = AS NECESSARY
*                (X4) = OPERAND FROM PARSED FILE. 
*                (X1) = MODE OF OPERAND.
*                (B7) = FLAG FOR TYPE OF OPERAND, AS BELOW... 
* 
*         IF OPERAND IS AN *ADDRESS* VALUE -- 
*                (B7) = -1. 
*                (X5) = (IOAPT) + (IOLEN) 
*                       TAG OF CURRENT AP-LIST ENTRY. 
*                (X6) = *PLUG* MARK.
*                CALLER SHOULD EMIT A STORE INTO THE AP-LIST. 
* 
*         IF OPERAND IS AN *INTERMEDIATE* --
*                (B7) = 0.
*                (X5) = TEMP TAG + MODE 
*                (X6) = TEMP TAG. 
*                (TG.TEM) ADVANCED BY 1.
*                CALLER SHOULD EMIT A STORE INTO THE TEMP.
* 
*         IF OPERAND IS A NORMAL TAG -- 
*                (B7) = TAG.
*                (X5) = 0 
  
  
**        CONSTRUCT AP-LIST ENTRY FOR A NORMAL TAG. 
  
 AAE4     IFBIT  X5,ARE/INTR,AAE5  IF ENTIRE ARRAY REF. 
          BX6    X5 
          IFBIT  X6,ADDR/ARE,AAE1  IF ADDRESS SET 
  
 AAE5     SBIT   X5,2TAG/ARE+1
          MX0    L.2TAG+L.2BIAS 
          SB7    X5 
          BX6    X0*X4       ISOLATE TAG / BIAS 
          BX5    0           INDICATE NO (OR.2OP) 
  
 AAE      SUBR               ENTRY/EXIT...
          RJ     ESC         EXPAND (POSSIBLE) SHORT CONSTANT 
          MX2    -L.MODE
          BX4    X5 
          SBIT   X5,INTR
          BX1    -X2*X4 
          PL     X5,AAE4     IF NOT INTERMEDIATE RESULT 
          SBIT   X5,ARY/INTR
          MI     X5,AAE2     IF ADDRESS VALUE (PLUG)
  
  
**        CONSTRUCT APLIST FOR EXPRESSION RESULT -- 
*         EMIT   (O=STORE, OPERAND, TEMP-TAG) 
*                (ATAG)  = TEMP TAG.
  
 AAE1     BX6    X1 
          SA2    TG.TEM 
          =B7    0
          AX6    P.LONG 
          =X3    X2+1 
          IX7    X3+X6       ADVANCE (TG.TEM) TWICE IF DOUBLE-WORD ITEM 
          LX2    P.ATAG 
          SA7    A2 
          BX6    X2 
          SBIT   X2,2TAG/ATAG 
          IX5    X2+X1
          EQ     EXIT.
  
  
**        CONSTRUCT AP-LIST ENTRY FOR A *PLUG* (OBJECT-TIME ADDRESS). 
*         EMIT   (O=STORE, OPERAND, APTAG+BIAS) 
*                APTAG = (IOAPT)
*                BIAS  = (IOLEN)
  
 AAE2     IFBIT  X5,LCF/ARY,AAE1  IF LOCF EXPRESSION
  
          SA2    IOAPT
          BX6    X4 
          =B7    -1          INDICATE PLUG
          AX6    P.2TAG 
          =X0    M.2PRO 
          LX2    P.2TAG 
          SB2    X6 
          SA3    TT.PAR 
          MX7    L.ATAG+L.ABIAS 
          SB2    X3+B2
          BX5    X2+X0
          =A3    B2+OR.1OP   ARRAY-TAG
          BX6    X7*X3
          EQ     EXIT.
 A=BMOD   SPACE  4,8
**        A=BMOD - CHECK BUFFER IN/OUT MODE DESIGNATOR. 
  
  
 A=BMOD   BSS    0           ENTRY... 
          MX0    -L.MODE
          BX1    -X0*X5 
          SX0    X1-M.INT 
          NZ     X0,=XE.IOB2 IF NOT INTEGER 
          LX0    X5 
          IFBIT  X0,INTR,=XE.IOB2  IF INTERMEDIATE
          IFBIT  X0,-SHORT/INTR,A=BMOD1  IF NOT SHORT CONSTANT
          BX0    X5 
          AX0    P.SHC
          ZR     X0,A=BMOD1  IF CONSTANT *0*
          =X0    X0-1 
          ZR     X0,A=BMOD1  IF CONSTANT *1*
          EQ     =XE.IOB8 
 A=BMOD1  RJ     AAE         ANALYZE AP-LIST ENTRY
          =X1    M.AVAR+"AP=SIZ"S"ATYP" 
          BX6    X6+X1
 .76      IFEQ   .CPU,76
          LE     B7,A=BMOD2  IF NOT NORMAL TAG. 
*         CHECK FOR 7000 LEVEL
* 
          =B2    A=BMOD2     SET RETURN ADDRESS.
          EQ     VARCHK      GO CHECK FOR VAR SYM 
 .76      ENDIF 
 A=BMOD2  SA6    IOBMOD 
          =X3    IO=BMOD
*         EQ     A=IOT       CHECK PLUGGING 
 A=IOT    SPACE  4,8
**        A=IOT - CHECK FOR PLUG OF TEMPORARY IN I/O. 
* 
*         ENTRY  (X3) = I/O APLIST BIAS.
*         EXIT   TO *PAREXIT* TO EXIT PARSER. 
  
  
 C=IOT    BSS    0
 A=IOT    GT     B7,PAREXIT  IF NO PLUG, NO TURPLE
          LX3    P.2BIAS
          IX5    X3+X5
          SA3    APLUG
          BX6    X3 
          SA6    SOPR 
          RJ     PSO         PROCESS  SUBSCRIPT OPERATION IF IN ONE 
          ZR     X3,PAREXIT  IF REDUCED - EXIT
          RJ     ADT         ADD OPERATOR 
          SA3    APLSTOR
          =A4    B6-1        1ST OPERAND = RESULTS OF *PLUG*
          BX6    X3 
          SA6    SOPR 
          RJ     ADT
          EQ     PAREXIT     EXIT.. 
 A=BLWA   SPACE  4,8
**        A=BLWA - CHECK BUFFER IN/OUT LAST WORD ADDRESS. 
* 
*         EXIT   (IOBLWA) = BUFFER I/O LAST WORD ADDRESS. 
* 
*         ERROR  IF EXPRESSION     (E.IOB7) 
  
  
 A=BLWA   BSS    0           ENTRY... 
          BX0    X5 
          IFBIT  X0,-INTR,A=BLWA1 IF NOT INTERMEDIATE 
          LX0    X5 
          AX0    P.TAG
          SA2    TT.PAR 
          SB7    X0 
          SA1    X2+B7
          SB7    =XO=SUBL 
          AX1    P.TAG
          SB7    -B7
          SX0    X1+B7
          ZR     X0,A=BLWA2  IF ARRAY LOAD TURPLE 
          EQ     E.IOB7      ELSE ERROR 
 A=BLWA1  IFBIT  X0,SHORT/INTR,E.IOB7  IF SHORT CONSTANT
          LX0    X5 
          AX0    P.TGB
          SX0    X0-C.CON/1S13
          ZR     X0,E.IOB7   IF CONSTANT
 A=BLWA2  RJ     AAE         ANALYZE AP-LIST ENTRY
          MI     B7,A=BLWA5  IF ADDRESS PLUG
          SB3    X1-M.DBL 
          MI     B3,A=BLWA3  IF NOT DBL OR CMPLX
          =X2    1
          LX2    P.ABIAS     IF CMPLX OR DBL, BIAS = BIAS + 1 
          IX6    X6+X2
 A=BLWA3  =X1    M.AVAR+"AP=SIZ"S"ATYP" 
          BX6    X6+X1
.76       IFEQ   .CPU,76
          LE     B7,A=BLWA4  IF NOT NORMAL TAG. 
*         CHECK FOR 7000 LEVEL
* 
          =B2    A=BLWA4     SET RETURN ADDRESS.
          EQ     VARCHK      GO CHECK FOR VAR SYM 
 .76      ENDIF 
 A=BLWA4  SA6    IOBLWA 
          MX0    L.TAG
          BX2    X6 
          AX2    P.TAG       LWA TAG
          BX6    -X0*X6 
          AX6    P.2BIAS     LWA BIAS 
          SX6    X6          PROVIDE SIGN EXTENSION 
          SA6    LWABIAS     SAVE FOR FUTURE USE
          SA1    IOBFWA 
          BX7    -X0*X1 
          AX7    P.2BIAS     FWA BIAS 
          SX7    X7          PROVIDE SIGN EXTENSION 
          =A7    A6-LWABIAS+FWABIAS 
          AX1    P.TAG       FWA TAG
          IX0    X2-X1
          NZ     X0,A=BLWA10 IF NOT SAME VARIABLE OR ARRAY
          MI     X6,A=BLWA30 IF NON-CONSTANT SUBSCRIPT - OK BY DEFAULT
          MI     X7,A=BLWA30 IF NON-CONSTANT SUBSCRIPT - OK BY DEFAULT
          IX0    X6-X7
          MI     X0,=XE.IOB10  IF FWA GREATER THAN LWA
          EQ     A=BLWA30 
 A=BLWA5  SB3    X1-M.DBL 
          MI     B3,A=BLWA4  IF NOT DBL OR COMPLEX
          SA3    A3          FETCH VARIABLE FROM TURPLE .. SEE AEE
          =X2    1
          LX2   P.2BIAS 
          IX6    X3+X2       BIAS = BIAS + 1
          SA6    A3          REPLACE VAR IN PARSE FILE
          EQ     A=BLWA4
  
*         TEST FOR FWA AND LWA IN SAME COMMON BLOCK 
*         (X1) = FWA TAG
*         (X2) = LWA TAG
  
 A=BLWA10 SB2    X1-C.VAR 
          SB3    X2-C.VAR 
          SA2    TS.SYM 
          SA1    B2+X2       FWA *ST* ENTRY 
          SA2    B3+X2       LWA *ST* ENTRY 
          LX0    X1 
          IFBIT  X0,COMM,A=BLWA11  IF FWA IN COMMON 
          BX0    X2 
          IFBIT  X0,COMM,=XE.IOB9  IF LWA IN COMMON 
          EQ     A=BLWA20    IF NEITHER IN COMMON 
 A=BLWA11 LX0    X2 
          IFBIT  X0,-COMM,=XE.IOB9  IF LWA NOT IN COMMON
          SA2    =XTA.NAM 
  
*         NAME TABLE ORDINAL = (SYMTABORD+1)/2-1
  
          =X0    B2+1 
          =X1    B3+1 
          AX0    1
          AX1    1
          =X0    X0-1 
          =X1    X1-1 
          IX1    X1+X2
          SA1    X1          LWA TA.NAM ENTRY 
          SX7    X1          LWA COMMON BIAS
          AX1    P.BLOCK
          SB3    X1          LWA BLOCK NO.
          IX0    X0+X2
          SA1    X0          FWA TA.NAM ENTRY 
          SX6    X1          FWA COMMON BIAS
          AX1    P.BLOCK
          SB2    X1          FWA BLOCK NO.
          SB2    B2-B3
          NZ     B2,=XE.IOB9 IF NOT IN THE SAME COMMON BLOCK
          SA1    FWABIAS
          MI     X1,A=BLWA30 IF NON-CONSTANT SUBSCRIPT - OK BY DEFAULT
          =A2    A1-FWABIAS+LWABIAS 
          MI     X2,A=BLWA30 IF NON-CONSTANT SUBSCRIPT - OK BY DEFAULT
          IX6    X1+X6       FWA TOTAL BIAS 
          IX7    X2+X7       LWA TOTAL BIAS 
          IX6    X7-X6
          MI     X6,=XE.IOB10  IF FWA .GE. LWA
          EQ     A=BLWA30    EXIT OK
  
*         TEST FOR FWA AND LWA BOTH FORMAL PARAMETERS 
*         (B2) = FWA *ST* ORDINAL 
*         (B3) = LWA *ST* ORDINAL 
*         (X1) = FWA *ST* ENTRY 
*         (X2) = LWA *ST* ENTRY 
  
 A=BLWA20 LX0    X1 
          IFBIT  X0,FP,A=BLWA21  IF FWA FORMAL PARAMETER
          BX0    X2 
          IFBIT  X0,FP,=XE.IOB9  IF LWA FORMAL PARAMETER
          EQ     A=BLWA25    IF NEITHER FORMAL PARAMETER
 A=BLWA21 BX0    X2 
          IFBIT  X0,-FP,=XE.IOB9  IF LWA NOT FORMAL PARAMETER 
          EQ     A=BLWA30    OK IF BOTH FORMAL PARAMETER
  
*         TEST FOR FWA AND LWA IN SAME EQUIVALENCE CLASS
  
 A=BLWA25 LX0    X1 
          IFBIT  X0,-EQUIV,=XE.IOB9  IF NOT EQUIVALENCED
          BX0    X2 
          IFBIT  X0,-EQUIV,=XE.IOB9  IF NOT EQUIVALENCED
          SA2    =XTA.NAM 
  
*         NAME TABLE ORDINAL = (SYMTABORD+1)/2-1
  
          =X0    B2+1 
          =X1    B3+1 
          AX0    1
          AX1    1
          =X0    X0-1 
          =X1    X1-1 
          IX1    X1+X2
          SA1    X1          LWA TA.NAM ENTRY 
          SX7    X1          LWA EQUIVALENCE BIAS 
          IX0    X0+X2
          SA1    X0          FWA TA.NAM ENTRY 
          SX6    X1          FWA EQUIVALENCE BIAS 
          SA1    FWABIAS
          MI     X1,A=BLWA30 IF NON-CONSTANT SUBSCRIPT - OK BY DEFAULT
          =A2    A1-FWABIAS+LWABIAS 
          MI     X2,A=BLWA30 IF NON-CONSTANT SUBSCRIPT - OK BY DEFAULT
          IX6    X1+X6       FWA TOTAL BIAS 
          IX7    X2+X7       LWA TOTAL BIAS 
          IX7    X7-X6
          MI     X7,=XE.IOB10  IF FWA .GE. LWA
 BLWA     BSS    0
 A=BLWA30 =X3    IO=BLWA
          EQ     A=IOT       CONTINUE.. 
  
 FWABIAS  BSS    2
 LWABIAS  EQU    FWABIAS+1
 C=BFWA   SPACE  4,8
**        C=BFWA - CHECK BUFFER IN/OUT FIRST WORD ADDRESS.
* 
*         EXIT   (IOBFWA) = BUFFER I/O FIRST WORD ADDRESS.
* 
*         ERROR  IF EXPRESSION     (E.IOB7) 
  
  
 C=BFWA   BSS    0           ENTRY... 
          BX0    X5 
          IFBIT  X0,-INTR,C=BFWA1 IF NOT INTERMEDIATE 
          LX0    X5 
          AX0    P.TAG
          SA2    TT.PAR 
          SB7    X0 
          SA1    X2+B7
          SB7    =XO=SUBL 
          AX1    P.TAG
          SB7    -B7
          SX0    X1+B7
          ZR     X0,C=BFWA2  IF ARRAY LOAD TURPLE 
          EQ     E.IOB7      ELSE ERROR 
 C=BFWA1  IFBIT  X0,SHORT/INTR,E.IOB7  IF SHORT CONSTANT
          LX0    X5 
          AX0    P.TGB
          SX0    X0-C.CON/1S13
          ZR     X0,E.IOB7   IF CONSTANT
 C=BFWA2  RJ     AAE         ANALYZE AP-LIST ENTRY
          =X3    IO=BFWA
          MI     B7,C=BFWA3  IF ADDRESS PLUG
          =X1    M.AVAR+"AP=SIZ"S"ATYP" 
          BX6    X6+X1
 .76      IFEQ   .CPU,76
          LE     B7,C=BFWA3  IF NOT NORMAL TAG. 
*         CHECK FOR 7000 LEVEL
* 
          =B2    C=BFWA3     SET RETURN ADDRESS 
          EQ     VARCHK      GO CHECK FOR VAR SYM 
 .76      ENDIF 
 C=BFWA3  SA6    IOBFWA 
          EQ     C=IOT       CONTINUE.. 
 C=CNT    SPACE  4,8
**        C=CNT - CHECK XXCODE *COUNT* INDICATOR. 
* 
*         EXIT   (IOCNT) SET UP.
  
  
 C=CNT    BSS    0           ENTRY... 
          MX0    -L.MODE
          BX1    -X0*X5 
          =X1    X1-M.INT 
          BX0    X5 
          NZ     X1,E.IOS9         IF NOT INTEGER 
          IFBIT  X0,INTR,E.IOS9    IF EXPRESSION
          RJ     AAE         ANALYZE AP-LIST ENTRY
          =X1    M.AVAR+"AP=SIZ"S"ATYP" 
          BX6    X6+X1
 .76      IFEQ   .CPU,76
          LE     B7,CNTA     IF NOT NORMAL TAG
*         CHECK FOR 7000 LEVEL
* 
          =B2    CNTA        SET RETURN ADDRESS.
          EQ     VARCHK      GO CHECK FOR VAR SYM 
 .76      ENDIF 
 CNTA     SA6    IOCNT
          =X3    IO=CNT 
          EQ     C=IOT       CONTINUE.. 
 C=FMT    SPACE  4,8
**        C=FMT - CHECK FORMAT VALIDITY.
* 
*         EXIT   (IOFMT) SET UP.
* 
*         ERROR  IF EXPRESSION. 
  
  
 A=FMT    BSS    0           ENTRY... 
 C=FMT    BSS    0           ENTRY... 
          BX0    X5 
          IFBIT  X0,2ARY,FMTA  IF FORMAT INDICATOR IS ARRAY 
          ANSI   =XE.IOF
 FMTA     RJ     AAE         ANALYZE AP-LIST ENTRY
          =X1    M.AVAR+"AP=SIZ"S"ATYP" 
          BX6    X6+X1       SET VARIABLE FORMAT BIT (FAKE AS FIT)
 .76      IFEQ   .CPU,76
          LE     B7,FMT1A    IF NOT NORMAL TAG
  
*         CHECK FOR 7000 LEVEL
* 
          =B2    FMT1A       SET RETURN ADDRESS 
          EQ     VARCHK      GO CHECK FOR VAR SYM 
 .76      ENDIF 
 FMT1A    PL     B7,FMT1B    IF NO PLUG 
          MX0    L.ATAG+L.ABIAS 
          BX6    -X0*X6 
 FMT1B    SA6    IOFMT
  
          ZR     B7,FMT1     IF EXPRESSION, ERROR 
          =X3    IO=FMT 
          EQ     C=IOT       CONTINUE.. 
  
 FMT1     FATAL  E.IOF1 
          EQ     C=ERR
 C=IOL    SPACE  4,12 
**        C=IOL - MAKE I/O AP-LIST ENTRIES. 
* 
*         EXIT   TO *POPX* -- 
*                ITEM ENTERED IN AP-LIST. 
*                (IOLEN) INCREMENTED. 
* 
*         ERROR  IF EXPRESSION IN INPUT LIST. 
* 
*         CALLS  AAE, ADDWD, NCS, ILI.
  
  
 C=IOL    BSS    0           ENTRY... 
          SA1    IOLEN
          PL     X1,IOL1     IF NOT INITIAL LIST ITEM 
          RJ     ILI         ADD INITIAL LIST ITEMS 
 IOL1     =X6    X1+1        COUNT ITEMS IN (PARTIAL) LIST
          SA6    IOLEN
          RJ     AAE         ANALYZE AP-LIST ENTRY
          NZ     B7,IOL4     IF NOT AN INTERMEDIATE 
  
**        CONSTRUCT AP-LIST ENTRY WHEN AN INTERMEDIATE. 
*                (ATAG)  = TAG
*                (ABIAS) = TYPE 
*                (ATYP)  = AP=SIZ 
*                (ASIZ)   = 1 
  
          SA2    IODIR
          NZ     X2,IOL3     IF OUTPUT DIRECTION
          SA1    IOLEN
          =X6    X1-1 
          SA6    A1          BAD ITEM NOT ADDED TO AP-LIST
          FATAL  E.IOL1 
          EQ     C=ERR
  
 IOL3     =X3    1+"AP=SIZ"S"ATYP"  PRESET ITEM LENGTH = 1
          NZ     X1,IOL3.5   IF NOT MODELESS
          =X1    M.INT       DEFAULT MODE FOR PRINTING
  
 IOL3.5   LX1    P.ABIAS
          BX2    X6+X1
          IX6    X2+X3
 IOL2     ADDWD  TP.APL      ADD ITEM TO APLIST 
          BX0    X5 
          IFBIT  X0,LONG,IOL25     IF DOUBLE LENGTH 
          SA3    APLSTOR     OUTPUT *AP-LIST* STORE TURPLE. 
          EQ     POP.ST1     EXIT.. (TO POP TURPLE -- MODELESS) 
 IOL25    SA3    =XAPLSTOD
          EQ     POP.ST1     EXIT..(TO POP TURPLE--MODELESS)
  
**        HANDLE STORING OF *PLUG*  (OBJECT-TIME ADDRESS).
  
 IOL4     PL     B7,IOL45    IF NO PLUG 
          SA2    IOLEN
          =X3    1+"AP=SIZ"S"ATYP"  ITEM LENGTH = 1 
          SX2    X2-1 
          LX1    P.ABIAS
          IX6    X1+X3       MERGE MODE AND SIZE
          LX2    P.2BIAS
          BX5    X5+X2
 .76      IFEQ   .CPU,76
          LX2    X4          PRESERVE X4
          AX2    P.ATAG      EXTRACT INDEX TO VARIABLE TURPLE 
          SA3    TT.PAR 
          SB2    X2+B1
          SA3    X3+B2       EXTRACT OPERAND CONTAINING VARIABLE
          AX3    P.ATAG      SAVE TAG ONLY
          SB7    X3 
          =B2    IOL43       SET RETURN 
          EQ     VARCHK      GO CHECK LEVEL OF VARIALBE 
 .76      ENDIF 
 IOL43    ADDWD  TP.APL      ADD ITEM TO APLIST 
          =X1    M.ADDR      SET ADDRESS BIT
          SA3    APLUG
          BX4    X1+X4
          BX6    X3 
          SA6    SOPR 
          RJ     ADT         ADD *AP-LIST PLUG* TURPLE
          SA3    APLSTOR
          =A4    B6-1        1ST OPERAND = RESULTS OF *PLUG*
          EQ     POP.ST1     EXIT.. (TO POP TURPLE -- MODELESS) 
  
**        CONSTRUCT AP-LIST ENTRY FOR A VARIABLE. 
  
 IOL45    SA2    TS.SYM 
          SB2    B7-C.CON 
          SB7    B7-C.VAR 
          MI     B2,IOL47    IF ITEM IS NOT A CONSTANT
          MX0    -L.2BIAS 
          SA2    IODIR
          LX0    P.2BIAS
          SA4    R.W
          BX3    -X0*X6      ISOLATE (2BIAS) -- CONTAINS CONSTANT LENGTH
          BX6    X0*X6       CLEAR OUT (2BIAS)
          PL     X4,IOL46    IF NOT CHAR STRING IN LIST-DIRECTED I/O
          =X7    1
          SX1    M.CHAR      HOLL STRING TYPE 
          SA7    A4          RESET LIST-DIRECTED FLAG 
 IOL46    SX4    M.UNIV      UNIVERSAL MODE (USED FOR OCTAL)
          BX7    X1-X4
          NZ     X7,IOL46.2  IF MODE NOT UNIVERSAL
          SX1    M.INT       CHANGE MODE FROM OCTAL TO INTEGER
 IOL46.2  LX1    P.ABIAS
          AX3    P.2BIAS+L.MSHORT 
          BX6    X6+X1       INSERT TYPE
          NZ     X2,IOL5     IF *OUTPUT* DIRECTION
          SA1    IOLEN
          =X6    X1-1 
          SA6    A1          BAD ITEM NOT ADDED TO AP-LIST
          FATAL  E.IOL2      ** CONSTANT ILLEGAL IN INPUT **
          EQ     C=ERR
  
 IOL47    SA2    X2+B7       LOAD SYMBOL TABLE ENTRY
          SA1    IODIR
          =B2    0           SET RETURN ADDRESS = 0 FOR LEVEL CHECK 
          NZ     X1,IOL47A   IF NOT INPUT 
  
          SX1    M.DEF
          BX7    X2+X1
          SA7    A2          SET DEFINED BIT FOR INPUT VARIABLES
*         CHECK IF LIST VARIABLE IS A DO CONTROL INDEX
          SA3    =XTP.DO
          SA5    TP=DO
          IX0    X3+X5
          SB7    X0          LWA+1 OF TABLE 
          SB3    X3+OR.DOCI 
 IOL470   GT     B3,B7,IOL47A  IF END OF TABLE
          SA3    B3          CONTROL INDEX
          BX0    X7-X3
          SB3    B3+L.DOE 
          AX0    P.TAG
          NZ     X0,IOL470   IF CONTROL INDEX NOT REDEFINED 
          FATAL  =XE.DO8     CONTROL INDEX REDEFINED - FATAL
  
 IOL47A   BSS    0
  
 .76      IFEQ   .CPU,76
  
**        TURN ON *ALCM* BIT FOR 7000 LEVEL 2 VARIABLES 
*         B2 = RETURN ADDRESS 
  
          SBIT   X2,LEV 
          PL     X2,IOL48    IF NOT LEVEL VARIABLE
          LX2    P.LEV+1     RESTORE X2 
          MX0    -L.LEVN
          LX0    P.LEVN 
          BX0    -X0*X2 
          AX0    P.LEVN      (X0) = LEVEL NUMBER
          SX0    X0-2 
          NZ     X0,IOL49    IF NOT LEVEL 2 
          =X0    1
          LX0    P.ALCM      TURN ON *ALCM* BIT 
          BX6    X6+X0
          EQ     IOL49
  
 IOL48    LX2    P.LEV+1     RESTORE X2 
  
 IOL49    ZR     B2,IOL49A   IF NO RETURN.
          JP     B2          RETURN TO *A=* AND *C=* PROCESSORS IN *IO*.
  
 .76      ENDIF 
  
 IOL49A   SBIT   X2,ARY 
          =X3    1+"AP=SIZ"S"ATYP"  PRESET SIMPLE ITEM LENGTH = 1 
          SBIT   X4,ARE 
          PL     X2,IOL6     IF NOT ARRAY 
          SBIT   X2,PNT/ARY+1 
          PL     X4,IOL6     IF SNGLE ELEMENT 
          SA3    TP.DIM 
          MX0    -L.PNT 
          BX5    -X0*X2      ISOLATE TP.DIM ORD 
          SB3    X5 
          MX0    -L.DIMLG 
          SA1    X3+B3       FETCH DIMENSION PARAMETERS 
          SBIT   X1,DIMLG+1 
          BX3    -X0*X1      ARRAY LENGTH 
          SBIT   X1,VDIM/DIMLG-1
          PL     X1,IOL5     IF NOT VARAIBLY DIMENSIONED
  
**        THIS ITEM IS VARIABLY DIMENSIONED.  CALL *CVT* TO GENERATE
*                TURPLES WHICH WILL CAUSE THE LENGTH TO BE COMPUTED IN
*                THE SUBPROGRAM PREAMBLE CODE.
  
          SBIT   X1,NDIM/VDIM+1 
          MX0    -L.NDIM
          BX2    -X0*X1      ISOLATE NUMBER OF DIMENSIONS 
          =X0    1
          LX2    18 
          BX4    X2+X0       12/0,18/NO. OF DIMS,18/CURRENT SUBSCR
          SA6    IOLSCR 
          SX6    B1 
          SA6    =XDIMUL     SET TO ONE IN CASE FIRST DIM IS CONSTANT 
 IOL50    SB2    X4 
          SB3    X5          TP.DIM ORD 
          RJ     CVT         GENERATE VAR-DIM TAG 
          BX7    -X6
          =X1    X4+1 
          SA7    =XDIMUL
          AX4    18 
          IX0    X4-X1
          MI     X0,IOL51    IF ALL SUBSCR PROCESSED
          LX4    18 
          BX4    X4+X1
          EQ     IOL50
  
 IOL51    SA4    IOLSCR 
          =X3    X6-C.VDIM+"AP=TEM"S"ATYP"
          BX6    X4          RESTORE (X6) 
          EQ     IOL6        CONTINUE.. 
  
 IOL5     BX7    X3 
          AX7    L.ASIZ 
          NZ     X7,IOL55    IF TOO LONG TO PUT IN DIRECTLY 
          =X3    X3+"AP=SIZ"S"ATYP"    SET I/O LENGTH INIDCATOR 
          EQ     IOL6 
  
 IOL55    LX7    X3 
          BX4    X6 
          SA7    SCR
          SB2    A7          = FWA
          SB3    A7+B1       = LWA + 1
          SCAN   TS.CON,NCM  ENTER ARRAY LENGTH INTO CON TABLE
          SX3    B7+"AP=CON"S"ATYP" 
          BX6    X4          RESTORE (X6) 
  
  
**        ENTER THE ITEM IN AP-LIST TABLE.
*                (X6) = TAG.       (APTAG, APBIAS)
*                (X3) = SIZE.      (APSIZ, APTYP) 
  
 IOL6     BX6    X6+X3
          ADDWD  TP.APL 
          EQ     POPX        EXIT.. (NO TURPLE) 
 IOLSCR   BSS    1           TEMPORARY FOR AP-LIST ITEM 
 A=STR    SPACE  4,8
**        A=STR - CHECK XXCODE *STRING* ADDRESS.
* 
*         EXIT   (IOSTR) = STRING ADDRESS DESCRIPTOR. 
* 
*         ERROR  IF EXPRESSION      (E.IOS7)
*         O.K.   IF PLUG
*         ERROR  IF NOT A VARIABLE  (E.IOS8)
  
  
 A=STR    BSS    0           ENTRY... 
          RJ     AAE         ANALYZE AP-LIST ENTRY
          =X1    M.AVAR+"AP=SIZ"S"ATYP" 
          BX6    X6+X1
 .76      IFEQ   .CPU,76
          LE     B7,STRA     IF NOT NORMAL TAG
*         CHECK FOR 7000 LEVEL
* 
          =B2    STRA        SET RETURN ADDRESS.
          EQ     VARCHK      GO CHECK FOR VAR SYM 
 .76      ENDIF 
 STRA     BX7    X6 
          PL     B7,STRB     IF NO PLUG 
          MX0    L.ATAG+L.ABIAS 
          BX7    -X0*X6 
 STRB     SA7    IOSTR
          ZR     B7,E.IOS7   IF EXPRESSION, ERROR 
          SA3    IODIR
          ZR     X3,STRC     IF NOT OUTPUT DIRECTION
          LX6    L.TAG       SET DEF BIT
          MX3    -L.PWF 
          BX6    -X3*X6 
          SA3    TS.SYM 
          SB2    X6 
          SA3    B2+X3
          SX6    M.DEF
          BX6    X3+X6
          SA6    A3 
  
STRC      =X3    IO=STR 
          MI     B7,C=IOT    IF PLUG
          SB2    C.VAR+2*C.DIF
          GT     B7,B2,E.IOS7      IF NOT VARIABLE TAG
          EQ     PAREXIT     EXIT PARSER. 
 O=IOJ    SPACE  4,8
 .76      IFEQ   .CPU,76
**        VARCHK   -   CHECK FOR VARIABLE SYMBOL
*         ENTRY    -   FROM APPROPRIATE *A=* OR *C=* ROUTINE IN *IO*
*                  (B2) = RETURN ADDRESS (TO APPROP. *A=* OR *C"* ROUT) 
*                  (B7) = TAG TYPE(AS FROM *AAE*) 
* 
*         EXIT     -   IF     VARIABLE SYMBOL TAG - TO *IOL47A (IN *IO*)
*                      IF NOT VARIABLE SYMBOL TAG - TO CALLING ROUTINE
  
  
  
 VARCHK   BSS    0           ENTRY... 
          SB3    C.VAR+2*C.DIF
          GT     B7,B3,VARCHK1   IF NOT VARIABLE TAG
          SA2    TS.SYM 
          SB3    B7-C.VAR 
          SA2    X2+B3       LOAD SYMBOL TABLE ENTRY
          EQ     IOL47A 
 VARCHK1  JP     B2          RETURN TO CALLER(IN *IO*)
 .76      ENDIF 
  
  
**        O=IOJ - COMPILE JUMP TO I/O ROUTINE.
* 
*         ENTRY  (1OP) = APTAG / TRACEBACK
*                (2OP) = SUBROUTINE TAG 
*         EXIT   JUMP COMPILED. 
*         CALLS  ADDWD, CLOAD, CRJ, ILI, NAP, TAGSEX. 
  
  
 O=IOJ    BSS    0           ENTRY... 
          RJ     CIA
          =A4    B4+OR.1OP
          SX6    SA=BKS3+1S3
          SX5    X4          REMEMBER TRACEBACK FLAG
          IX2    X4-X5
          BX7    X6+X2
          LX7    P.LI12 
          WCODE  X7          * SA1 AP-LIST* 
          =A4    B4+OR.2OP
          BX6    X4 
          SX1    X5-1        SET TRACEBACK FLAG FOR *CRJ* 
          SA3    =XTRLINE    LINE NO. FOR TRACEBACK 
          RJ     CRJ         * RJ =XROUT* 
          EQ     IOX         EXIT.. 
 CML      SPACE 4,8 
**        CML - CHECK FOR MATCH IN LIST (TP.ILI)
* 
*         I/O RESTART CALLS WILL BE ISSUED WHEN CERTAIN CONDITIONS ARE
*         SATISFIED FOR ITEMS IN INPUT LISTS. 
* 
*         ENTRY  (X6) = PASS 2 TAG OF ITEM TO BE CHECKED
* 
*         KEEPS  X5,X6  B2,B4,B5,B6 
*         CALLS  IOJ
  
  
 CML      SUBR   0
          SA2    TP=ILI      LENGTH OF LIST ITEM TABLE
          BX4    X6 
          MX0    L.TAG
          SX1    X2-2        ALLOW FOR NAME OF ARRAY
          MI     X1,CMLX     IF TABLE EMPTY, EXIT 
          LX0    -P.2EQUIV-1
          IFBIT  X4,2EQUIV,CML2 IF ITEM EQUIVED 
          SA3    TP.ILI      (X3) = FWA OF TABLE
          BX4    X0*X4
          SA1    X3 
 CML1     IFBIT  X1,2EQUIV,CML2 IF ITEM IN TABLE EQUIVED
          BX1    X0*X1
          SX2    X2-1        DECREMENT LENGTH OF ITEMS
          IX7    X1-X4
          =A1    A1+1 
          ZR     X7,CML2     IF TAGS MATCH
          ZR     X2,CMLX     IF TABLE EXHAUSTED, EXIT 
          EQ     CML1        CONTINUE TABLE SEARCH
  
 CML2     SA6    CMLT1       X6 SAVED 
          SA4    TP=ILI 
          BX6    X5 
          IX0    X3+X4
          SA2    X0-1 
          SX1    B2 
          LX7    X2 
          =A6    A6+1        X5 SAVED 
          SA7    CMLT2       ARRAY NAME IS RETAINED 
          SX4    B5 
          LX1    18 
          BX0    X1+X4
          SX2    B6 
          LX0    18 
          BX7    X0+X2       B2,B5,B6 SAVED 
          =A7    A6+1 
          BX6    -0 
          RJ     IOJ         I/O APLIST INTERRUPT ISSUED
          SA4    CMLT2
          LX6    X4 
          ADDWD  TP.ILI      ARRAY NAME IS RETAINED IN TABLE
          SA1    CMLT1
          =A4    A1+1 
          BX6    X1          X6 RESTORED
          =A2    A4+1 
          BX5    X4          X5 RESTORED
          SB6    X2          B6 RESTORED
          AX2    18 
          SB5    X2          B5 
          AX2    18 
          SB2    X2          B2 
          EQ     CMLX        EXIT 
  
 CMLT1    BSS    1           TEMPORARY FOR X6 
          BSS    1                         X5 
          BSS    1                         B2,B5,B6 
 CMLT2    BSS    1           TEMP FOR ARRAY NAME
 IOX      SPACE  4,8
**        IOX -  COMMON EXIT POINT FOR ALL I/O OPERATORS. 
  
  
 IOX      =B4    B4+L.TURP
          EQ     EIS.PNX     EXIT.. 
  
          NOREF  A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
          NOREF  EXIT.
 JUMPTO   SECT   (LETTER GROUP / JUMPTO  TABLES.),1 
 JUMPTO.  SPACE  4,8
**        LGR    LETTER GROUP JUMPTO TABLE FOR KEYWORD STATEMENTS.
  
  
 LGR      BSS    0           BASE OF KEYWORD JUMPTO TABLE 
  
          LOC    0
          LIST   G           JUMPTO.
 ASSIGN   SATTR  0LASSI,ASSIGN=,EXU,(GEN,LBL),6 
 TO       SATTR  0LTO,TO=,OK,(NIF),2
 BLOCKDA  SATTR  0LBLOC,BLOCKD=,1ST,(NIF),9 
 CALL     SATTR  0LCALL,CALL=,EXU,(CDS,GEN,LBL),4 
 CONTINU  SATTR  0LCONT,CONTIN=,EXU,(GEN,LBL),8 
 END      SATTR  0LEND,END=,END,(BKD,CDS,GEN,NIF),3 
 FUNCTIO  SATTR  0LFUNC,FUNCTI=,1ST,(NIF),8 
 LDSET    SATTR  0LLDSE,LDSET=,1ST,(NIF),5
 OVERLAY  SATTR  0LOVER,OVERLA=,1ST,(NIF),7 
 NAMELIS  SATTR  0LNAME,NAMELI=,OK,(NIF),8
 ENTRY    SATTR  0LENTR,ENTRY=,NTR,(CDS,GEN,NIF),5
 .TEST    IFNE   TEST,0,1 
 PATCH    SATTR  0LPATC,PATCH=,OK,(BKD,NIF),5 
 PAUSE    SATTR  0LPAUS,PAUSE=,EXU,(CDS,GEN,LBL),5
 PROGRAM  SATTR  0LPROG,PROGRA=,1ST,(NIF),7 
 RETURN   SATTR  0LRETU,RETURN=,EXU,(DON,GEN,LBL),6 
 GOTO     SATTR  0LGOTO,GOTO=,EXU,(DON,GEN,LBL),4 
 STOP     SATTR  0LSTOP,STOP=,EXU,(CDS,DON,GEN,LBL),4 
 SUBROUT  SATTR  0LSUBR,SUBROU=,1ST,(NIF),10
 DATA     SATTR  0LDATA,DATA=,DAT,(BKD,NIF),4 
 COMMON   SATTR  0LCOMM,COMMON=,DEC,(BKD,NIF),6 
 DIMENSI  SATTR  0LDIME,DIMENS=,DEC,(BKD,NIF),9 
 EQUIVAL  SATTR  0LEQUI,EQUIVA=,DEC,(BKD,NIF),11
 EXTERNA  SATTR  0LEXTE,EXTERN=,DEC,(NIF),8 
 LEVEL    SATTR  0LLEVE,LEVEL=,DEC,(BKD,NIF),5
 LOGICAL  SATTR  0LLOGI,LOGICA=,TYP,(BKD,NIF),7 
 INTEGER  SATTR  0LINTE,INTEGE=,TYP,(BKD,NIF),7 
 REAL     SATTR  0LREAL,REAL=,TYP,(BKD,NIF),4 
 DOUBLE   SATTR  0LDOUB,DOUBLE=,TYP,(BKD,NIF),6 
 PRECISI  SATTR  0LPREC,PRECIS=,OK,(NIF),9
 COMPLEX  SATTR  0LCOMP,COMPLE=,TYP,(BKD,NIF),7 
 TYPE     SATTR  0LTYPE,TYPE=,TPE,(BKD,NIF),4 
 IMPLICI  SATTR  0LIMPL,IMPLIC=,IMP,(BKD,NIF),8 
 FORMAT   SATTR  0LFORM,FORMAT=,FMT,(LBL,NIF),6 
 BACKSPA  SATTR  0LBACK,BACKSP=,EXU,(CDS,GEN,LBL),9 
 BUFFER   SATTR  0LBUFF,BUFFER=,EXU,(CDS,GEN,LBL),6 
 DECODE   SATTR  0LDECO,DECODE=,EXU,(CDS,GEN,LBL),6 
 ENDFILE  SATTR  0LENDF,ENDFIL=,EXU,(CDS,GEN,LBL),7 
 ENCODE   SATTR  0LENCO,ENCODE=,EXU,(CDS,GEN,LBL),6 
 PUNCH    SATTR  0LPUNC,PUNCH=,EXU,(CDS,GEN,LBL),5
 PRINT    SATTR  0LPRIN,PRINT=,EXU,(CDS,GEN,LBL),5
 REWIND   SATTR  0LREWI,REWIND=,EXU,(CDS,GEN,LBL),6 
 READ     SATTR  0LREAD,READ=,EXU,(CDS,GEN,LBL),4 
 WRITE    SATTR  0LWRIT,WRITE=,EXU,(CDS,GEN,LBL),5
 LG.LEN   BSS    0           LENGTH OF KEYWORD TABLE
  
  
**        FOLLOWING /JUMPTO./ WORDS ARE FAKE ENTRIES FOR SYNTACTICLLY 
*                RECOGNIZED STATEMENTS. 
*         THESE WORDS MUST EXIST, BUT THEY MAY NOT BE INCLUDED IN THE 
*         LENGTH SPECIFIED BY *LG.LEN*. 
  
  
 ASF.     SATTR  -1,AFD,ASF,(NIF) 
 DO.      SATTR  2LDO,SDO,EXU,(DON,GEN,LBL,NIF),2 
 IF.      SATTR  -1,IFS,EXU,(GEN,LBL) 
 REP.     SATTR  -1,CNF,EXU,(GEN,LBL) 
 EOS      SATTR  -1,END=,END,(BKD,CDS,GEN)
 NULL     SATTR  -1,PSN,EXU,(GEN,LBL) 
  
          LOC    *O 
 TYPES    CON    LGR+LOGICAL
          CON    LGR+INTEGER
          CON    LGR+REAL 
          CON    LGR+DOUBLE 
          CON    LGR+COMPLEX
          LIST   D
          END 
