*DECK     PUC    PROGRAM UNIT CONTROLLER
          IDENT  PUC
 PUC      SECT   (PROGRAM UNIT CONTROLLER AND SUPPORT.) 
 PUC      SPACE  4,10 
*         IN FTN
          EXT    ABTFTN,COD,CO.ANSI,CO.GO,CO.LOO,CO.OPT,CO.PS,CO.PW 
          EXT    CO.PWE,CP.ABT,CP.AFLL,CP.AFLS,CP.BLF,CP.CARD,CP.EPAG 
          EXT    CP.ERCT,CP.IFMT,CP.ILFL,CP.LSTF,CP.MXFL,CP.NFLS,CP.PAGE
          EXT    CP.PD,ERFO,FV.LGO,FV.OUT,F.ERRS,F.IL,F.IN,F.LGO,F.OUT
          EXT    F.PB,F.REF,GT1,INT.FL,LDCOM,L.CC,L.CCA,L.CCB,L.TA,L.TB 
          EXT    L.TITL,L.TTLA,L.TTLB,L.TWO,MAX.FL,MSG=,OFFSPY,O.C,O.CC 
          EXT    O.CPV,O.TA,O.TITL,O.TTLA,RAPFLAG,RS.PD,SPYW,SYS=,
          EXT    TIME0,TIME1,TL.EJCT,TL.PAGE,TL.PTYP,WNB= 
  
*         IN LISTLNK
          EXT    LUS
  
*         IN QCGLINK
          EXT    CGL,FEL,REL
  
*         IN UTILITY
          EXT    CDD,CIO=,FA=SET,MVE=,RDC=,SFN,WTH= 
          TITLE  GLOBAL TABLE DEFINITIONS.
 SIZES    SPACE  4,10 
**        SIZES - AUX. MACRO FOR TABLE SIZE REMOTES.
*                (FORCES MICRO EVALUATION)
  
  
 SIZES    MACRO  NAME,RATE,INIT,DEFENT
* 
 TABLE    RMT 
 T.NAME  DEFENT INIT
 TABLE    RMT 
* 
 SIZES    RMT 
 T=NAME  DEFENT N.TABLES+T.NAME 
 SIZES    RMT 
* 
.2        IFC    NE, = RATE 
 RATES    RMT 
 X        OCTMIC RATE_BS30/L.TABLES,10
 A        OCTMIC INIT,6 
          VFD    60/0."X"B+"A"B    (NAME)   _______________________ 
 RATES    RMT 
* 
 NAMES    RMT 
          VFD    42/7L_NAME  ,18/-BASES+T.NAME         ____________ 
 NAMES    RMT 
 .2       ELSE
 ALTNAM   RMT 
          VFD    42/7L_NAME  ,18/INIT-BASES            ____________ 
 ALTNAM   RMT 
* 
 .2       ENDIF 
* 
 SIZES    ENDM
 TABLE    SPACE  4,10 
**        TABLE - MACRO TO FORM TABLE PARAMETER WORD FOR COMPILER TABLES
* 
* TNAM    TABLE  RATE,INIT         (OR),
* TNAM    TABLE  =,SHARE
* 
* TNAM    =      TABLE NAME (WITHOUT PREFIX)
*         RATE   =  RELATIVE EXPANSION RATE OF TABLE. 
*                = 5   SUPER TABLE.  PLEASE USE DISCRETION. 
*                = 4   FAST EXPANDER. 
*                = 3   NORMAL RATE. 
*                = 2   SLOWER THAN MOST.
*                = 1   VERY INFREQUENTLY EXPANDED.
*         INIT   =  INITIAL LENGTH OF TABLE IN EACH PROGRAM-UNIT. 
*         SHARE  =  NAME OF TABLE TO SHARE SPACE WITH.
  
  
          MACRO  TABLE,NAM,RATE,INIT,PHASE
 A        MICRO  1,5,/NAM     / 
* 
 .1       IFC    NE, RATE = 
 R        DECMIC RATE 
 R        OCTMIC "R"*16 
 MCNTAB   DECMIC   N.TABLES 
          IRP    PHASE
 MC_PHASE MICRO    1,,/1S"MCNTAB"+"MC_PHASE"/ 
          IRP 
 N.TABLES SET    N.TABLES+1 
 L.TABLES SET    L.TABLES+"R"B
 L=TABLES SET    L=TABLES+INIT
          SIZES  ("A"),"R",INIT,CONENT
* 
 .1       ELSE
* 
          SIZES  ("A"),=,T.INIT,EQUENT
 .1       ENDIF 
 TABLE    ENDM
 TSECT    SPACE  4,10 
**        TSECT - MACRO TO MARK START OF TABLE SECTIONS.
* 
*         TSECT  SECTNAM,COMMENT
  
  
          MACRO  TSECT,NAM,COMMENT
 AAA      MICRO  1,5,/NAM    /
 TABLE    RMT=   (O."AAA"  BSSENT             COMMENT)
 SIZES    RMT=   (L."AAA"  BSSENT             COMMENT)
 TSECT    ENDM
 TABLES   SPACE  4,10 
 L.TABLES SET    0
 L=TABLES SET    0
 N.TABLES SET    0           INITIALIZE TABLE ORDINAL 
 MCDECL   MICRO 
 MCEXU    MICRO 
 MCEND    MICRO              INITIALIZE TABLE VECTOR MICROS 
 TABLES   SPACE  4,10 
**        TABLE DEFINITIONS.
* 
*         THE TABLE VECTORS ARE DIVIDED INTO THREE SECTIONS.
*         THE SECTION IN WHICH A TABLE PARAMETER RESIDES IS DEPENDENT 
*         UPON THAT TABLES STATUS ACROSS CALLS TO THE CCG.
* 
*         SECTION 1 -- CONTAINS TABLES WHICH ARE NOT PRESERVED ACROSS 
*                      CALLS TO CCG. *O.P2NUL*, *L.P2NUL* ARE THE 
*                      ORIGIN AND LENGTH OF THE FIRST TABLE IN THIS 
*                      SECTION. 
* 
*         SECTION 2 -- CONTAINS TABLES WHICH ARE USED DURING CCG. 
*                      *O.P2USE*, *L.P2USE* ARE THE ORIGIN AND LENGTH 
*                      OF THE FIRST TABLE IN THIS SECTION.
* 
*         SECTION 3 -- CONTAINS TABLES WHICH ARE PRESERVED ACROSS CALLS 
*                      TO THE CCG.  *O.P2SAV*, *L.P2SAV* ARE THE ORIGIN 
*                      AND LENGTH OF THE FIRST TABLE IN THIS SECTION. 
  
  
**        SECTION 1 -- TABLES NOT PRESERVED ACROSS CCG. 
  
 P2NUL    TSECT  (SECTION 1 -- NOT PRESERVED BY CCG)
 TABLES   SPACE  4,10 
**        T.TB - TOKEN BUFFER.
* 
*                THIS TABLE MUST BE FIRST BECAUSE A0 POINTS TO THE
*                ORIGIN OF THE TABLE.  BEING THE FIRST TABLE THE ORIGIN 
*                WILL ALWAYS REMAIN CONSTANT. 
*                ITS SPACE IS REUSED FOR THE LGO BUFFER AT END TIME.
  
  
 TB       TABLE  1,401B            TOKEN BUFFER 
 LGOB     TABLE  =,TB        LGO BUFFER 
 TABLES   SPACE  4,10 
 ARG      TABLE  2,,(DECL,EXU,END) STACK OF ACTUAL PARAMETER TURPLES
 PTXTR    TABLE  =,ARG       LOADER PTEXTR (3500) TABLE INFORMATION 
 STF      TABLE  2,,(DECL,END)     STATEMENT FUNCTION SKELETONS 
 EQUS     TABLE  =,STF       TRANSLATED EQUIVALENCE STATEMENTS
 LINK     TABLE  =,STF       LOADER LINK (4400) TABLE INFORMATION 
 COMM     TABLE  2,1,(DECL,EXU)    COMMON TAGS
 BLST     TABLE  2,,(DECL,EXU)    BLOCK STRUCTURE (DO AND BLOCK IF) INFO
 FPO      TABLE  =,COMM      SUB/SUB0 ORGINS FOR FORMAL PARAMETERS
 DVV      TABLE  =,COMM      DATA VARIABLE VALUES IN CONRED/SED 
 SLARG    TABLE  =,COMM      STATEMENT LABEL ARGUMENTS
 IOARG    TABLE  =,COMM      IO ARGUMENTS 
 DATI     TABLE  3,,(DECL,EXU,END) AUX DATA TABLE,LOCAL TO
                                   DATA STATEMENT 
                             CONTAINS CONSTANTS FOUND IN THE STATEMENT
                             AND REP FACTORS, PLUS OTHER GOODIES. 
 OUS      TABLE  =,DATI      OPERAND USAGE STATUS 
 SCR      TABLE  =,DATI      SCRATCH TABLE. 
 PTXT     TABLE  =,DATI      LOADER PTEXT (3500) TABLE INFORMATION
 DATL     TABLE  2,,(DECL,EXU,END) AUX DATA TABLE,LOCAL TO
                                   DATA STATEMENT 
 EOT      TABLE  =,DATL      EQUIVALENCE OVERLAP TABLE
 FILL     TABLE  =,DATL      LOADER FILL BYTES  (PASS 3)
 ILI      TABLE  =,DATL      INPUT LIST ITEMS 
 SAP      TABLE  1,,(DECL,EXU,END)      STACKED APLIST TABLE
 DATS     TABLE  =,SAP       DATA ACCUMULATION TABLE
 IOLC     TABLE  =,SAP       I/O LIST COLLAPSE *CV* DEFINITION TURPLES
 PAR      TABLE  3,,(DECL,EXU,END) I.L.(WRITTEN TO F.IL IN CCG) 
 DAR      TABLE  =,PAR       DATA EXPANSION COPY OF (T.PAR) 
 XFIL     TABLE  =,PAR       LOADER XFIL(4100) TABLE. 
 PCS      TABLE  2,,(DECL,EXU)      PARSER CONTEXT STACK
 STMT     TABLE  1,,(DECL,EXU)     SOURCE STATEMENTS,DEFER LIST BUFFER
 CLWB     TABLE  =,STMT      IO CHAR ARRAY ITEM LENGTH BINARY (FAS/LIST)
 SUB      TABLE  1           *SUB*  BLOCK TABLE 
 VDIM     TABLE  1           VARIABLE DIMENSION TURPLES.
 SUB0     TABLE  =,VDIM      SUB0 BLOCK TABLE 
 C$IF     TABLE  1           C$ CONDITIONAL DIRECTIVE TABLE 
 TABLES   SPACE  4,10 
**        SECTION 2 -- TABLES USED DURING CCG.
  
  
 P2USE    TSECT  (SECTION 2 -- USED BY CCG) 
  
          MACRO  TABSH,PASS1,RATE,INIT,PASS2,PHASE
 PASS1    TABLE  RATE,INIT,(PHASE)
 TABLE    RMT=   (O=PASS1  EQUENT T.PASS1)
 SIZES    RMT=   (L=PASS1  EQUENT T=PASS1)
          ENDM
  
*CALL COMSTAB 
 LA       TABLE  =,CUT       (QCG ONLY)  LABELS ASSIGN-ED TO
 TABLES   SPACE  4,10 
**        SECTION 3 -- TABLES PRESERVED BY CCG. 
  
 P2SAV    TSECT  (SECTION 3 -- PRESERVED BY CCG)
  
 REF      TABLE  1           CROSS-REFERENCE TABLE (REFMAP FILE)
                             MAY SPILL TO DISK AND SHRINK TO 0
 LCA      TABLE  1           LCM POINTER CELLS
 ECT      TABLE  1           EQUIVALENCE CLASS TABLE
 ENT      TABLE  1
 LNT      TABLE  2           LINE NUMBER TABLE (FOR  FID) 
 LCC      TABLE  0           LOADER DIRECTIVES
 FMT      TABLE  3,,(DECL,EXU)     FORMAT 
 END      TABLE  0           DUMMY FOR MANAGER
  
          PURGMAC SIZES 
          PURGMAC TABLE 
          PURGMAC TSECT 
  
*         USED FOR EXTERNAL REFERENCE INTERFACES
  
 L=TABLE  EQUENT L=TABLES 
 N.TABLE  EQUENT N.TABLES 
 TABLES   EJECT 
**        TABLES - ACTUAL TABLE PARAMETER WORDS ARE HERE. 
  
          LIST   D           *ORIGINS*
  
 ORIGINS  BSSENT 0           ORIGINS OF TABLES
 BASES    BSSENT 0           BASE ADDRESSES OF TABLES 
  
 TABLE    HERE               ACTUAL TABLE PARAMETER WORDS 
  
  
 SIZES    BSSENT 0           SIZES OF TABLES
  
 SIZES    HERE
  
          LIST   *           *SIZES*
 RATES    BSSENT 0           EXPANSION RATES OF TABLES
          LIST   G           *RATES*
  
 RATES    HERE
  
          LIST   *           *RATES*
  
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
 NAMES    BSSENT 0           TABLE NAMES (TEST MODE ONLY) 
          LIST   G
  
 NAMES    HERE
  
 ALTNAM   BSSENT 0           ALTERNATE TABLE NAMES
  
 ALTNAM   HERE
          DATA   0           END OF TABLE MARKER
  
          LIST   *           TABLE NAMES
 .TEST    ENDIF 
  
*                TABLE VECTORS
  
 TV=DECL  CONENT "MCDECL" 
 TV=EXU   CONENT "MCEXU"
 TV=END   CONENT "MCEND"
 TV=CUR   CONENT 0
  
          TITLE  GLOBAL SYMBOL DEFINITIONS. 
 LBT      SPACE  4,20 
**        LBT - LOCAL BLOCK TABLE.
* 
*         N.B. --  ORDER MUST BE MAINTAINED.
*                (LOCAL) MUST BE FIRST CELL AFTER (LBT).
  
  
          MACRO  LBLK,NR,NAM
 NR   BSSENT 1         (NAM)
          ENDM
  
  
 F.LBT    BSSENT 0           FWA LOCAL BLOCK TABLE
          LOC    0
          LIST   -X,G 
*CALL     COMSLBT            DEFINE LOCAL BLOCK TABLE 
          LIST   *
 Z.LBT    BSSENT 0           NUMBER OF LOCAL BLOCKS 
          LOC    *O 
 SUM.LBT  CONENT 0           LOCAL LENGTH OF PROGRAM-UNIT 
 COMSIZ   CONENT 0           LENGTH OF SCM COMMON 
          CON    0           LENGTH OF LCM COMMON 
 F$LBT    EQUENT F.LBT       CCG INTERFACE NAME 
 Z$LBT    EQUENT Z.LBT       CCG INTERFACE NAME 
 N$LBT    EQUENT Z.LBT       CCG INTERFACE NAME 
 CELLS    EJECT 
**        COMMON CELL DEFINITIONS.
  
 ALC.PAR  CONENT 0           MINIMUM ALLOCATION FOR PAR 
  
 BINIO    CONENT -1          -1 = CCG MODE OR F.PB FLUSHED
                              0 = OTHERWISE 
  
 BLNKCOM  CONENT 0           BLOCK NUMBER OF BLANK COMMON 
  
 CBI      CONENT 0           CURRENT INDEX TO  T.BLKS 
  
 CHARDCL  CONENT 0           CHARACTER DECLARATION PRESENT
  
 ERRORS   CONENT 0           NUMBER OF FATAL ERRORS APPEARING IN CURRENT
                             SUBPROGRAM.  CP.ERCT CONTAINS TOTAL ERROR
                             COUNT.  INCLUDING ALL OF ET=LEVEL. 
  
 ENTRJ    CONENT 0           NZ IF THIS ENTRY POINT CODE HAS RJ YET 
  
 N$FERR   EQUENT ERRORS      CCG INTERFACE NAME 
  
 FAILSFT  CONENT 0           NON-ZERO IF TABLES OVERLAP CATASTROPHICALLY
  
 O.TABS   BSSENT  1          FWA OF MANAGED TABLE AREA
  
 IDENT1   CONENT 10H         USED TO DISPLAY *COMPILING* MESSAGE
 HO$MSG   CONENT 10HCOMPILING 
 IDENT    CONENT 0           ROUTINE NAME 0L FORMAT 
 HO$PRGN  EQUENT IDENT       CCG INTERFACE NAME 
  
 IO.TEM   CONENT 0           MAX TEMPORARY USED BY IO IN EACH PROGRAM 
*                            UNIT.
  
 LCNT     BSZENT 2           LINE COUNT  L/E FILES
 N$LINES  EQUENT LCNT        CCG INTERFACE NAME 
  
 LEVEL    BSSENT 1           LEVEL STATEMENT ENCOUNTERED
 LEVEL0   BSSENT 1           LEVEL0 STATEMENT ENCOUNTERED 
 LEVEL2   CONENT 0           IF ANY LCM/ECS RESIDENT DECLARATIONS 
 HO$LVL2  EQUENT LEVEL2 
  
          BSSZ   1           LINEBUF-1 USED BY *MAP*
 LINEBUF  BSZENT 14          GENERAL PRINT LINE WORKING AREA
  
 LINES    CONENT 0           CURRENT SOURCE LINE NUMBER 
 CARDS    EQUENT LINES
 LINENR   EQUENT LINES
 HO$CSN   EQUENT LINES       CCG INTERFACE NAME 
  
 LOSTREF  CONENT 0           1.  BEFORE REF-MAP PROCESSING, IT IS A 
                             COUNT OF NUM OF REFS FOUND.
                             2.  DURING REF-MAP, IT WILL BE SET TO NUM
                             OF REFS LOST DUE TO CORE LIMITATIONS.
  
 MOD      CONENT 0           SUBPROGRAM MODE  (SET BY *1ST CARD* SCANS) 
  
 NARGS    CONENT 0           PROGRAM-UNIT ARGUMENT COUNT. 
  
 NOLIST   CONENT 1S59        =1S59 IF C/-LIST,ALL ACTIVE
                             =0    IF C/-LIST,NONE ACTIVE 
  
 NREXT    CONENT 0           COUNT OF EXTERNALS REFERENCED IN CURRENT 
                             PROGRAM-UNIT.  COMPUTED BY *END*.
  
 NSQZLH   BSSENT 1           CCG DONT SQUEEZE LONG HOLLERITHS FLAG
  
 N.AP     BSSENT 1           NUMBER OF ACTUAL-PARAMETER LISTS 
  
 N.ARP    CONENT 0           .NZ. = AN ALTERNATE RETURN PARAMETER LIST
                             OCCURRED IN THIS PROGRAM UNIT.  NOT SET
                             UNTIL PASS 1 IS COMPLETE.
  
 N.BUF    BSZENT 1           FIT LENGTHS, BUFL'S, MRL'S FOR USER FILES
 N.CPL    BSSENT 1           LENGTH OF (CP.) ARRAY
  
 N.CON    BSSENT 1           LENGTH OF RUN-TIME CONSTANT TABLE
 N.CT     BSSENT 1           LENGTH OF (CT.) AREA, IN WORDS 
 N.CTMAX  BSSENT 1           MAX (CT.) WORDS IN ANY SEGMENT 
  
 N.DOB    BSSENT 1           NUMBER OF INVENTED DO-BEGIN LABELS 
  
 N.EPL    CONENT 0           .NZ. IF MULTIPLE UNIQUE PARAMETER LISTS
 N$SEP    EQUENT N.EPL       CCG INTERFACE NAME 
  
 N.FP     CONENT 0           NUMBER OF FORMAL PARAMETER 
                             .ZR. IF NOT PROCEDURAL SUBPROGRAM
 N$FPS    EQUENT N.FP        CCG INTERFACE NAME 
  
 N.GL     BSSENT 1           NUMBER OF GENERATED LABELS 
  
 N.MAXIL  CONENT 100*Z=TURP  THRESHOLD SIZE OF IL SEGMENT 
                             TRY TO FLUSH WHEN IT GETS THIS BIG 
** FV            SHOULD ABOVE DEPEND ON FL??
  
 N$LC     CONENT 0           NUMBER OF FP LOCAL COPY CELLS
  
 N.ST     BSSENT 1           NUMBER OF TEMPS IN ONE STATEMENT 
 N.STMAX  BSSENT 1           MAX NUMBER OF STATEMENT TEMPS
  
 N.VD     BSSENT 1           NUMBER OF VARDIM EXPRESSIONS 
 N$VD     EQUENT N.VD        CCG INTERFACE NAME 
  
 O.STITL  CONENT 0           ADDR AND LEN OF SUBTITLE - 30/LEN,30/ADDR
  
 PU.MFL   CONENT 0           PROGRAM UNIT MAX FL
 HO$PMLS  EQUENT PU.MFL      CCG INTERFACE NAME 
  
 PASS     CONENT 0           CONTROLS ACTIONS OF TABLE MANAGER. 
  
 PWBUF    BSSENT 13          LIST BUFFER FOR PW MODE
  
 WOF=ERR  BSZENT 1           0 = LIST TO L  1 = LIST TO E 
  
  
 REFIO    CONENT -1          -1 = T.REF TABLE IS ON DISK
                             0  = T.REF TABLE IS IN SCM 
  
 RPV=CLN  EQUENT LINES       CURRENT LINE NUMBER
 RPV=MSG  EQUENT IDENT1      RPV COMPILING MESSAGE
 RPV=URP  CONENT 0           USER REPRIEVE PROCESSOR
 HO$RDR   EQUENT RPV=URP     CCG INTERFACE NAME 
  
 SAVE     CONENT  0          SAVE INDICATOR 
  
 THRESH   CONENT 0           THRESHHOLD FOR ALLOC BEFORE MEM REQUEST
  
 USAVE    CONENT 0           UNIVERSAL SAVE INDICATOR 
  
 L.TABS   CONENT 1S17        WIDTH OF MANAGED TABLE AREA
 SCRATCH  SPACE  4,10 
**        SCRATCH AREA. 
  
 SCR      BSSENT 10          GENERAL SCRATCH AREA. NEVER TO BE USED BY
*                            TABLE SECTION. SHOULD BE USED ONLY BY LOCAL
*                            ROUTINES.
 LSTWRKG  SPACE  4,10 
**        WORKING COPY OF OPTIONS RESET BY C$ DIRECTIVES. 
* 
*         THESE CELLS MUST MAINTAIN THE SAME ORDER AS THE CO. CELLS IN
*         CO.C$.
  
  
 WO.C$    BSSENT 0           DIRECTIVE CONTROL
  
 WO.CS    BSSENT 1           COLLATE = USER WEIGHT TABLE
 WO.DOLG  BSSENT 1           DO = LONG
 WO.DOOT  BSSENT 1           DO = OT (ONE TRIP) 
 WO.LOA   BSSENT 1           LO = S 
 WO.LOM   BSSENT 1           LO = M 
 WO.LOO   BSSENT 1           LO = O 
 WO.LOR   BSSENT 1           LO = R 
 WO.LOS   BSSENT 1           LO = S 
 WO.QC    BSSENT 1           QC - SET TO QUICK CHECK AFTER FATAL ERRORS 
 WO.LCM   BSSENT 1
 CELLS    SPACE  4,20 
**        MISCELLANEOUS SHORT CONSTANTS USED WHEN PROCESSING A STATEMENT
  
  
          MACRO  CONST,LAB,NUM,CMOD 
          IFC    NE,/LAB//,1
 LAB      BSSENT 0
          VFD    TP.ORDL/0,TP.BIASL/NUM 
          POS    TP.SHRTP+1 
          VFD    1/1
          POS    TP.MODEL 
          VFD    TP.MODEL/M._CMOD 
 CONST    ENDM
  
  
 CONONE   CONST  1,INT
 CONZER   CONST  0,BOOL 
 CONZERI  CONST  0,INT
 VTRUE    CONST  -1,LOG 
 VFALSE   CONST  0,LOG
          PURGMAC CONST 
 F.SORD   SPACE  4,10 
**        F.SORD - CELLS CONTAINING SYMTAB ORDINALS.
* 
*         SEE TABLE (SYM.NAM) IN FEC FOR LIST OF CELLS WHICH ARE ALWAYS 
*         PRESET IN SYMBOL TABLE.  NAMES NOT IN THAT LIST ARE OPTIONAL, 
*         BEING CREATED IN RESPONSE TO SOME FEATURE OF THE SOURCE 
*         PROGRAM.  IF A NAME HAS NOT YET BEEN ENTERED IN THE SYMTAB, 
*         THE CORRESPONDING (S=CELL) WILL CONTAIN ZERO. 
*         THESE CELLS ARE INITIALIZED BY FEC/PUP. 
* 
*         (S$NAME) CELLS ARE FOR USE ONLY BY THE COMMON CODE GENERATOR. 
*         (S=NAME) WILL BE USED BY ALL FORTRAN CODE (INCLUDING BRIDGE). 
  
  
 F.SORD   BSSENT
  
 S=AEXIT  BSSENT 1           AEXIT.    ALTERNATE RETURN EXIT LABEL
 S=BU     BSSENT 1           *O+4S15   "BLOWUP" 
 S=BUFIN  BSSENT 1           BUFIN.    FCL - BUFFER IN ROUTINE
 S=BUF    BSSENT 1           FITS, BUFFERS, ETC. FOR USER FILES 
 S=CES    BSSENT 1           CES.      FCL - CHECK + EVALUATE SUBSCRIPT 
 S=CL     BSSENT 1           CL.       CHARACTER LENGTH DESCRIPTORS 
 S=CON    BSSENT 1           CON.      NUMERIC LITERALS 
 S=CP     BSSENT 1           CP.       APL FOR COPY AP CALL 
 S=CPL    BSSENT 1           CPL.      FCL - COPY AP LIST 
 S=CT     BSSENT 1           CT.         CHARACTER TEMPS
 S=ENTRY  BSSENT 1           ENTRY.    MAIN ENTRY POINT 
 S=ERR    CONENT 0           FERR.     SOURCE PROGRAM FATAL ERROR 
 S=EXIT   CONENT 0           EXIT.     SUBROUTINE EXIT LABEL
 S=FAR    BSSENT 1           FARC.     FCL - FORM ARRAY REFERENCE 
 S=FAS    BSSENT 1           FASC.     FCL - FORM ARRAY SUBSTRING 
 S=FID    BSSENT 1           FID.      CID - FORTRAN INTERACTIVE DEBUG
 S=FMC    BSSENT 1           FMC.      FCL - FIXED MULTIPLE COMPARE 
          BSSENT 1           UMC.      FCL - USER MULTIPLE COMPARE
 S=FVS    BSSENT 1           FVSC.     FCL - FORM VARIABLE SUBSTRING
 S=FILES  BSSENT 1           FILVEC.   VECTOR OF FILE POINTERS
 S=GPL    BSSENT 1           GPL.      GLOBAL PARAMETER LIST
 S=LA     BSSENT 1           LA.       LABEL ASSIGN-ED WORDS
 S=LC     BSSENT 1           LC.       LOCAL COPIES OF FP VALUES
 S=LENP   BSSENT 1           LENP.     PROGRAM-UNIT LENGTH
 S=LMC    BSSENT 1           LMC.      FCL - LEXICAL MULTIPLE COMPARE 
 S=MMC    BSSENT 1           MMC.      FCL - MOVE MULTIPLE CHARACTER
 S=IT     BSSENT 1           IT.       OPTIMIZER TEMPS
 S=INIT   BSSENT 1           QXNTRY    FCL - INITIALIZATION 
 S=OT     BSSENT 1           OT.       OPTIMIZER TEMPS
 S=RD     BSSENT 1           RD.       RUN-TIME DIM TABLE 
 S=SA1    BSSENT 1           SAVEA1 
 S=SA0    BSSENT 1           SAVEA0 
 S=SLI    BSSENT 1           SLI.  FCL - SUB LEVEL0 INSTRUCTS.
 S=SPA    BSSENT 1           SP5.      FCL - SUBSTITUTE PARAMETER ADDRS 
 S=ST     BSSENT 1           ST.       STATEMENT TEMPORARIES
 S=SUB    BSSENT 1           SUB.      ARRAY OF ADDSUB DESCRIPTORS
 S=SUBI   BSSENT 1           SUBI.     ARRAY OF ADDSUB INDICES
 S=SUB0I  BSSENT 1           SUB0I.    ARRAY OF ADDSUB0 INDICES 
 S=TRACE  BSSENT 1           TRACE.    TRACEBACK WORD 
 S=TA0    CONENT 0           TEMPA0.   REMEMBER (A0) FROM ENTRY 
 S=UPW    BSSENT 1           UNIT POINTER WORD
 S=VALUE  BSSENT 1           VALUE.    FUNCTION RESULT
 S=VD     CONENT 0           VD.       VARDIM TEMPS 
  
 Z.SORD   EQUENT *-F.SORD 
  
  
 S$CON    EQUENT S=CON       THESE SYNONYMS FOR CCG 
 S$IT     EQUENT S=IT 
 S$LC     EQUENT S=LC 
 S$OT     EQUENT S=OT 
 S$VD     EQUENT S=VD 
          TITLE  ERROR TYPE DEFINITIONS.
 ERRTYP   SPACE  4,10 
**        ERRTYP - MACRO TO SETUP ERROR TYPES AND LISTING FLAGS 
* 
* 
* TYPE    ERRTYP EL,(WORD)
* 
*         *TYPE* = TYPE OF THE ERROR AS USED IN *ERROR* MACRO CALLS.
*                  ONLY THE FIRST LETTER WILL BE USED.
*         *EL*   = ERROR LEVEL VALUE FOR THE CLASS OF ERROR.  COMPARED
*                  WITH CO.EL TO DETERMINE IF THE *TYPE* OF ERROR JUST
*                  SELECTED IS TO BE PRINTED. 
*         (WORD) = BANNER WORD PRINTED WITH ERROR OF THIS *TYPE*. 
  
  
          MACRO  ERRTYP,T,E,W 
 A        MICRO  1,9,$_W         $
 B        MICRO  1,1, T 
 C        MICRO  1,1,/"A" / 
          ENTRY  ERR."B"
 ERR."B"  VFD    24/4R"C" * ,18/=10H "A",18/E 
 ERRTYP   RMT=   (ERR="B"    CONENT 0)
 ERRTYP   ENDM
 ERRTYP   SPACE  4,10 
**        ERRTYP - TABLE OF ERROR FLAG WORDS. 
  
 ERRTYP   BSSENT 0           TABLE OF ERROR FLAG WORDS
          LOC    0
****
 ANSI     ERRTYP ,(ANSI)
 MDERR    ERRTYP ,(MDEP)
          IFEQ   TEST,ON,1
 DEBUG    ERRTYP EL=D,(DEBUG) 
 TRIVIAL  ERRTYP EL=T,(TRIVIAL) 
 WARNING  ERRTYP EL=W,(WARNING) 
 FATAL    ERRTYP EL=F,(FATAL) 
 KILL     ERRTYP EL=C,(CATASTROPH)
 CONTINUE ERRTYP ,( ) 
****
 N.ERRT   BSSENT 0           NUMBER OF ERROR TYPES
          LOC    *O 
 ERRTYP   HERE
 E=TOTAL  CONENT 0           COUNT OF ALL ERRORS IN STATEMENT 
          PURGMAC ERRTYP
  
**        MEM DOWN FIELD LENGTH FOR *GO* MODE.
  
 LDRFL    VFD    12/0,18/MEM.GOFL,30/0
 PUC      TITLE  PROGRAM UNIT CONTROLLER. 
 PUC      SPACE  4,10 
**        PUC - PROGRAM UNIT CONTROLLER.
* 
*         ENTRY - FROM OVERLAY INITIALIZATION OR WHEN PREVIOUS
*                COMPILATION IS COMPLETE OR ABANDONED.
*                DECIDES WHETHER TO TERMINATE COMPILATION,
*                PASS CONTROL TO COMPASS, OR BEGIN ANOTHER
*                PROGRAM UNIT.
* 
*         EXITS  TO *ENDFTN* - IF END OF RECORD.
*                TO *LDCOM* - IF INTERMIXED ASSEMBLY. 
* 
*         CALLS  CAF,CDD,CGL,CLOSE,FEL,MESSAGE, 
*                PLINE,PUP,RECALL,REL,WRITER,WRITEC 
  
  
 PUC      BSSENT 0           ENTRY... 
  
  
**        SET UP LISTING PAGE FOR NEXT PROGRAM UNIT.
  
          SA4    CO.PS
          SA2    CP.LSTF
          SA3    CP.PAGE
          SA1    CP.BLF 
          SX7    X4+B1
          SA7    LCNT        SET EMPTY PAGE 
          SA7    A7+B1       EMPTY PAGE ON E-FILE 
          LX1    1
          BX2    X2*X3       EXTRACT EVEN/ODD PAGE COUNT IF LISTING ON
          BX1    X1*X2
          IX6    X3+X1
          PL     X3,PUC1     IF PROPAGATING PAGE COUNT
          MX6    2
          BX6    X6*X3
  
 PUC1     SA6    A3          UPDATE/RESET PAGE COUNT
          SX7    B1 
          SA7    NPU         RESET NEXT PROGRAM UNIT FLAG 
          ZR     X1,PUC2     IF (EVEN PAGE COUNT) OR (SHORT/NO LIST)
          WRITEH F.OUT,(=2L1 ),1  MAINTAIN PAGE PARITY
  
  
**        CLEAN UP SCRATCH FILES. 
  
 PUC2     SA1    CP.IFMT
          MI     X1,PUC3     IF EOR ON LAST READ
          BX6    0
          SA2    RAPFLAG     READ ALREADY PERFORMED FLAG
          SA6    A2          RESET RAP FLAG 
          NZ     X2,PUC4     IF READ ALREADY PERFORMED
          READC  F.IN,CP.CARD,16  GET NEXT INPUT LINE 
          ZR     X1,PUC4     IF NOT EOR ON INPUT
  
 PUC3     BSS 
          RJ     CAF         CLOSE ALL FILES
          EQ     ENDFTN      TERMINATE COMPILATION
  
 PUC4     SA2    CO.OPT 
          ZR     X2,PUC4A    IF NOT CCG MODE
          CLOSE  F.IL,UNLOAD
  
 .RM      IFNE   CP#RM,0,1
          OPEN   F.IL 
  
 PUC4A    SA2    FV.LGO 
          SA1    CO.LOO 
          BX3    X1+X2
          ZR     X3,PUC7     IF NEITHER BINARY NOR OBJECT LISTING 
          ZR     X2,PUC5     IF NO BINARY 
  
          IFEQ   CP#RM,0,1   IF USING DIRECT CIO
          RECALL F.LGO
  
 PUC5     SA4    BINIO
          SA2    CO.OPT 
          SX6    0
          ZR     X2,PUC6     IF NOT CCG MODE
          SX6    -1 
  
 PUC6     SA6    A4          RESET (BINIO)
          BX0    X4 
          SA1    CO.OPT 
          NZ     X1,PUC6A    IF NOT QCG MODE
          SETFIL FILE=F.PB,MODE=RESET    MAKE F.PB LOOK REWOUND 
  
 PUC6A    ZR     X0,PUC7     IF ACTUAL I/O NOT PERFORMED
          CLOSE  F.PB,UNLOAD
  
 .RM      IFNE   CP#RM,0,1
          OPEN   F.PB 
  
 PUC7     SA2    REFIO
          PL     X2,PUC8     IF REF NOT SPILLED TO DISK 
          MX6    0
          SA6    A2 
          CLOSE  F.REF,UNLOAD 
  
 .RM      IFNE   CP#RM,0,1
          OPEN   F.REF
  
          SA1    CO.OPT 
          NZ     X1,PUC8     IF NOT QCG MODE
          SETFIL FILE=F.REF,MODE=RESET   MAKE F.REF LOOK REWOUND
  
  
**        CHECK FOR COMPASS *IDENT*.
  
 PUC8     SA5    =1H
          SA2    CP.CARD
          MX0    6*CHAR 
          SA3    A2+B1
          SA4    =6LIDENT 
          IX1    X2-X5
          NZ     X1,PUC9     IF COLS. 1-10 NOT BLANK
          BX6    X0*X3
          IX4    X4-X6
          NZ     X4,PUC9     IF COL 11-16 NOT *IDENT *
          SA2    CP.PAGE
          LX2    59-58
          PL     X2,PUC85    IF NOT LIST OUTPUT 
          WRITER F.OUT,RCL
  
 PUC85    SA2    CP.EPAG
          LX2    59-58
          PL     X2,LDCOM    IF NO ERROR LIST OUTPUT
          WRITER =XF.ERRS,RCL 
          EQ     LDCOM       LOAD COMPASS (1,0)...
  
  
  
**        ADJUST CARRIAGE CONTROL FOR EFILE.
  
 PUC9     SA5    CP.EPAG
          ZR     X5,PUC11    IF EFILE NOT WRITTEN ON BY COMPASS 
          SA5    CO.PWE 
          SA2    =10H-
          BX6    X2 
          SX2    TL.EJCT
          SX2    X2+ERFO     X2 = ADDRESS FOR STORE 
          SX5    X5-126 
          PL     X5,PUC10    IF EFILE NOT IN PW MODE
          SX2    O.TTLA 
          SA2    X2+ERFO
          MX6    2*CHAR 
          BX6    -X6*X2      ERASE PREVIOUS CARRIAGE CONTROL
          SA3    =2L- 
          BX6    X6+X3       MERGE NEW ONE
          SX2    A2          X2 = ADDRESS FOR STORE 
  
 PUC10    SA6    X2          UPDATE CARRIAGE CONTROL
  
  
**        PROCESS NEXT PROGRAM UNIT.
  
 PUC11    CALL   FEL         FRONT END LOADER 
          CALL   CGL         CODE GENERATOR LOADER
          CALL   REL         REAR END LOADER
  
  
**        UPDATE STORAGE USED.
  
          SA1    CP.AFLS
          SA2    PU.MFL      PROGRAM UNIT MAX FL
          MX6    X1+X2       MAX USED FOR PROGRAM UNIT
          SA3    CP.MXFL
          SX1    X6+77B 
          AX1    6
          LX1    6           ROUND UP TO NEAREST 100B 
          BX2    X1 
          MX6    X2+X3       MAX CORE USED BY ANY PROGRAM UNIT
          SA6    A3 
  
 .SPY     IFEQ   .SPY,ON     IF SPYING
          SA1    SPYW 
          ZR     X1,PUC13    IF NOT SPYING THIS TIME
          SA1    CP.AFLS
          CALL   COD
          LX6    12 
          SX5    2R  -2RB 
          IX6    X6-X5
          SA6    PUCA+1      FL USED
          SA1    IDENT
          CALL   SFN         SPACE FILE PROGRAM NAME
          SA6    PUCA 
          MESSAGE PUCA,,R    PROGNAM  NNNNNNB CM USED 
  
 PUC13    BSS 
 .SPY     ENDIF 
  
  
**        LIST PROGRAM UNIT STATISTICS. 
  
          SA1    CP.AFLS
          CALL   LUS         LIST UNIT STATISTICS 
  
  
**        RESET PROGRAM UNIT START TIME.
  
          CALL   TIMER
          SA6    TIME1
  
**        RETURN TO INITIAL FIELD LENGTH. 
  
          SA3    INT.FL 
          SA2    O.TABS 
          SX2    X2+MIN.TABS+10 
          MX1    X2+X3       SELECT MAX OF TWO VALUES 
          SX1    X1+77B 
          AX1    6
          LX1    6           ROUND UP TO NEXT 100B
          SA2    CP.AFLS     CURRENT FL 
          IX6    X1-X2
          ZR     X6,PUC20    IF CURRENT = INITIAL 
          RJ     GMC         RETURN TO INITIAL FL 
  
          IFEQ   TEST,ON,1   IF TEST MODE 
          NE     B7,B1,"BLOWUP"    IF REQUEST NOT HONORED 
  
          SA1    O.TABS      ORIGIN OF TABLE AREA 
          IX6    X6-X1
          SA6    L.TABS      LENGTH OF TABLE AREA 
          AX6    FLSLOP 
          SX6    X6+FLSLUP
          SA6    THRESH      GIVE ALLOC SOME ELBOW ROOM 
  
  
**        SEND ANSI AND MACHINE DEPENDENT ERROR 
*         SUMMARIES TO DAYFILE AND CONSOLE. 
  
 PUC20    =X5    ERR.A       STARTING OFFSET
          SA1    CO.ANSI
          NZ     X1,PUC30    IF ANSI DIAGNOSTICS DESIRED
          SX5    ERR.M       AVOID ANSI DIAGNOSTICS 
  
 PUC30    =X6    ERR.M       ENDING OFFSET
          ERRNZ  ERR.M-ERR.A-1     MUST BE CONSECUTIVE
          RJ     PES         PRINT ERROR SUMMARY
  
**        SEND REST OF ERROR SUMMARIES TO DAYFILE AND CONSOLE.
  
          =X5    ERR.M+1     STARTING OFFSET
          =X6    ERR.C       ENDING OFFSET
          ERRPL  ERR.T-ERR.C
          RJ     PES         PRINT ERROR SUMMARY
          EQ     PUC         LOOP FOR NEXT PROGRAM UNIT...
  
 ENDFTN   TITLE  TERMINATE COMPILATION
**        TERMINATE COMPILATION.
  
  
 ENDFTN   BSSENT 0           ...ENTER HERE TO TERMINATE COMPILATION 
 ENDFTN   SPACE  4,10 
**        SEND FL USED TO DAYFILE.
  
          SA1    CP.MXFL     MAX FL USED
          CALL   COD         CONVERT OCTAL DIGITS 
          SA6    FLUSED 
          MESSAGE FLUSED,,RCL 
  
  
**        SEND COMPILATION TIME TO DAYFILE. 
  
          SA2    TIME0       START OF COMPILATION TIME
          CALL   CPTIM       COMPUTE/CONVERT ELAPSED CPU TIME 
          SA6    CPTMSG      TIME TO DAYFILE MESSAGE TEXT 
          MESSAGE CPTMSG,,RCL 
  
  
**        TURN OFF PPU PROGRAM SPY. 
  
 .SPY     IFEQ   .SPY,ON     IF SPY OPTION
          IFNE   .OS,2,1     IF NOT SCOPE 2 
          CALL   OFFSPY 
 .SPY     ENDIF 
  
  
**        PROCESS ABNORMAL TERMINATION CONDITIONS.
  
          SA1    CP.ERCT
          SA2    CP.ABT 
          MX3    1
          BX1    -X3*X1      CLEAR BINARY REGARDLESS FLAG 
          LX3    59-29
          BX2    X2*X3
          ZR     X1,END4     IF NO COMPILATION OR ASSEMBLY ERRORS 
          ZR     X2,END4     IF ABORT (ET=0) OPTION OFF 
  
          IFEQ   CP#RM,0,1   IF USING CIO I/O 
          CALL   WFA         WAIT FILE ACTIONS
          EQ     =XABTFTN 
  
**        PROCESS AUTO EXECUTE (GO-OPTION) REQUEST. 
  
 END4     SA1    CO.GO
          ZR     X1,END5     IF GO-OPTION OFF 
  
          BX6    X1 
          SA6    RA.PGN      POST FILE/PROGRAM NAME FOR MSG AND LOADER
  
 .RM      IFEQ   CP#RM,0     IF USING *CIO* DIRECT I/O
          CALL   WFA         WAIT FILE ACTIONS -- ALL QUIET 
 .RM      ENDIF 
  
 .OS      IFNE   .OS,2       IF NOT SCOPE 2 
          MEMORY SCM,LDRFL,RCL     RFL DOWN BEFORE CALLING LOADER 
 .EC      IFNE   CT.ECS,0 
          SA1    CP.ILFL
          BX6    X1 
          LX6    30 
          SA6    GT1         INITIAL LCM FIELD LENGTH 
          MEMORY LCM,GT1,R,,NOABT  RETURN TO INITIAL LCM FL 
 .EC      ENDIF 
 .OS      ENDIF 
  
          RPVOFF GT1         CANCEL REPRIEVE REQUEST
  
          MESSAGE RA.PGN,,RCL 
          LOADREQ   0 
+         EQ     *           WAIT FOR OP SYS TO PICK UP REQUEST 
  
  
**        TERMINATE COMPILATION NORMALLY. 
  
 END5     BSS    0
          IFEQ   CP#RM,0,1   IF USING CIO I/O 
          CALL   WFA         WAIT FILE ACTIONS
          SA1    INT.FL      INITIAL FL 
          SA2    CP.AFLS     CURRENT FL 
          IX6    X1-X2
          ZR     X6,END10    IF CURRENT = INITIAL FL
          BX6    X1 
          LX6    30 
          SA6    GT1
          MEMORY SCM,GT1,RCL RETURN TO INITIAL FL 
  
 END10    SA1    CP.ILFL     INITIAL LCM FL 
          SA2    CP.AFLL     CURRENT LCM FL 
          IX6    X1-X2
          ZR     X6,END15    IF CURRENT = INITIAL LCM FL
          BX6    X1 
          LX6    30 
          SA6    GT1
          MEMORY LCM,GT1,R,,NOABT  RETURN TO INITIAL LCM FL 
  
 END15    ENDRUN
  
  
**        DAYFILE MESSAGES. 
  
 CPTMSG   DIS    ,/   NNN.NNN CP SECONDS COMPILATION TIME./ 
 FLUSED   CON    0
          DIS    ,/ "SCM" STORAGE USED./
 CPTIME   SPACE  4,10 
**        CPTIME - COMPUTE AND CONVERT ELAPSED CPU TIME.
* 
*         ENTRY  (X2) = CPU START TIME IN MILLISECONDS
* 
*         EXIT   (X6) = DPC ELAPSED TIME, F10.3 FORMAT
* 
*         CALLS  TIMER, CFD 
  
  
 CPTIM    SUBR   =           ENTRY/EXIT...
          CALL   TIMER       RETURNS (X6) = CURRENT CPTIME
          IX1    X6-X2       (X1) = ELAPSED TIME (BINARY) 
          CALL   CFD         CONVERT FLOATING DIGITS TO F10.3 
          EQ     EXIT.       EXIT...
 TIMER    SPACE  4,10 
**        TIMER - OBTAIN ACCUMULATED CPU TIME.
* 
*         TIME IS CONVERTED INTO AN INTEGRAL NUMBER OF MILLISECONDS.
* 
*         ENTRY  NO REQUIREMENTS
* 
*         EXIT   (X6) = CURRENT CPU TIME IN MILLISECONDS
* 
*         USES   X - 0, 3, 4, 5, 6
*                A - 5
*                B - NONE 
* 
*         CALLS  TIME 
  
  
 TIMER    SUBR   =           ENTRY/EXIT...
          TIME   GT1
          SA5    GT1
          MX0    60-12
          BX4    -X0*X5      MSEC 
          AX5    12 
          SX3    1000D       SEC * 1000 
          MX0    60-24
          BX5    -X0*X5 
          IX3    X5*X3
          IX6    X3+X4
          EQ     EXIT.       EXIT...
 WFA      SPACE  4,10 
**        WFA - WAIT FILE ACTIONS.
* 
*         WAIT FOR ALL FILES IDLE.
* 
*         ENTRY  (RA.ARG) = FIRST WORD OF FILE VECTOR TABLE.
* 
*         CALLS  RECALL 
  
  
 .RM      IFEQ   CP#RM,0     IF USING CIO I/O 
  
 WFA      SUBR   0           ENTRY/EXIT...
          =B2    0
 WFA1     SA5    B2+RA.ARG   (X5) = FILE VECTOR ENTRY 
          =B2    B2+1 
          MI     X5,EXIT.    IF END OF TABLE, EXIT... 
          ZR     X5,WFA1     IF FILE DESELECTED 
          SX2    X5 
          RECALL X2 
          EQ     WFA1        LOOP FOR MORE
 .RM      ENDIF 
*CALL COMCCFD 
          IFEQ   .SPY,ON,1
 PUCA     DATA   0,0,7LCM USED
 PUCB     BSS    1
 CAF      TITLE  PUC SUPPORT ROUTINES 
 CAF      SPACE  4,10 
**        CAF - CLOSE ALL FILES.
* 
*         ENTRY  EOR ON INPUT 
* 
*         CALLS  CLOSE,FA=CLO,RECALL,WRITEC,WRITER
  
  
 CAF      SUBR   =           ...ENTRY/EXIT... 
  
          =X0    0
          RJ     COF         CLOSE OUTPUT FILE
          =X0    1
          RJ     COF         CLOSE ERROR FILE 
  
  
**        WRITE EOR ON LGO. 
  
          SA2    FV.LGO 
          ZR     X2,CAF3     IF BINARY OUTPUT SUPPRESSED (B=0)
          WRITEF F.LGO
          BKSP   F.LGO
  
  
**        EVICT SCRATCH FILES 
  
 CAF3     BSS    0
  
 .TEST    IFEQ   TEST,OFF    IF NOT TEST MODE 
          SA1    BINIO
          PL     X1,CAF35    IF PREBIN FILE NOT USED
          CLOSE  F.PB,UNLOAD
  
 CAF35    SA1    CO.OPT 
          ZR     X1,CAF36    IF QCG MODE
          CLOSE  F.IL,UNLOAD
  
 CAF36    BSS    0
          SA2    REFIO
          PL     X2,CAF4     IF REF FILE NOT USED 
          CLOSE  F.REF,UNLOAD 
 CAF4     BSS    0
 .TEST    ENDIF 
  
 #RM      IFEQ   CP#RM,7     IF 7RM I/O 
          =B2    0
 CAF5     SA2    RA.ARG+B2   (X2) = FIT ADDRESS FROM FILE VECTOR TABLE
          =B2    B2+1 
          MI     X2,CAF6     IF END OF TABLE
          ZR     X2,CAF5     IF FILE DESELECTED 
          CLOSE  A2 
          EQ     CAF5        LOOP FOR MORE
  
 CAF6     BSS    0
 #RM      ENDIF 
  
  
          EQ     EXIT.       EXIT...
          SPACE  4,8
**        COF - CLOSE OUTPUT FILE.
* 
*         ENTRY  X0 = 0/1  OUTPUT/ERRS
  
 COF      SUBR
  
*         RESET PRINT DENSITY IF NECESSARY. 
  
          SA1    PAGELOC+X0  TOTAL NUMBER OF PAGES ON OUTPUT
          SA1    X1 
          LX1    59-58
          PL     X1,EXIT.    IF NO LINES WRITTEN
          SA2    FV.OUT+X0
 .RM      IFEQ   CP#RM,0
          SX2    X2 
 .RM      ELSE
          SX2    A2 
 .RM      ENDIF 
          SA1    CO.PW+X0 
          MI     X1,COF10    IF FILE CONNECTED
  
          SA1    CP.PD
          SA3    RS.PD       JOB DEFAULT PRINT DENSITY CHAR 
          BX1    X1-X3
          ZR     X1,COF10    IF JOB DEFAULT IN USE
          BX6    X3 
          SA6    GT1
 .RM      IFEQ   CP#RM,0
          SA2    FV.OUT+X0
 .RM      ELSE
          SX2    FV.OUT+X0
 .RM      ENDIF 
          WRITEH X2,GT1,1    RESET DENSITY
  
 COF10    WRITER X2 
          EQ     EXIT.
*CALL     COMFECB            EVALUATE CONSTANT SUBSTRING AND BIAS 
 GCL      SPACE   4,10
**        GCL - GET CHARACTER LENGTH. 
* 
*         ENTRY  X1 = ORD, SYMTAB ORDINAL 
* 
*         EXIT   X1 = WC.CLEN[ORD]
*                X2 = -0 IF CTYP=1, ELSE +0 
*                X3 = VD. TAG IF CTYP=1, ELSE 0 
* 
*         USES   A2,A3, X0,X2,X1,X3,X5, B2
  
 GCL      SUBR   =
          LX2    B1,X1
          SA3    =XT.SYM
          IX5    X1+X2
          MX0    -WC.CLENL
          SB2    X3+WC.W
          SA2    B2+X5
          LX2    -WC.CLENP
          BX1    -X0*X2 
          SA3    =XS=VD 
          LX2    WC.CLENP-1-WC.CTYPP
          AX2    59 
          BX3    X2*X3
          EQ     EXIT.
          TITLE  PROGRAM UNIT SUPPORT ROUTINES
          TITLE  PROGRAM UNIT SUPPORT ROUTINES
 GMC      SPACE  4,10 
**        GMC - GET MORE CORE.
* 
*         IF THE CURRENT FL + INCREMENT IS .LE. THE MAX FL FOR
*         THIS JOBSTEP, THE REQUEST IS HONORED. IF THE REQUEST
*         IS GREATER THAN MAX FL, THEN MAX FL IS REQUESTED. IF
*         MAX FL = CURRENT FL THE CALLER IS INFORMED. IN ANY
*         CASE, CP.AFLS AND CP.NFLS ARE UPDATED.
* 
*         ENTRY  (X6) = INCREMENT 
* 
*         EXIT   (B7) = -1 IF MAXFL WAS REACHED THIS TIME 
*                        0 IF CURRENT FL ALREADY WAS MAXFL
*                       +1 IF REQUESTED INCREMENT HONORED 
*                (X6) = ACTUAL FL 
*                (X7) = NOMINAL FL (ACTUAL - 10)
*                (CP.AFLS) = ACTUAL FL
*                (CP.NFLS) = NOMINAL FL (ACTUAL - 10) 
* 
*         CALLS  MEMORY, PCS
  
  
 GMC      SUBR   =           ...ENTRY/EXIT... 
          SA1    MAX.FL      MAX FL FOR JOB STEP
          SA3    CP.AFLS     ACTUAL CURRENT FL
          AX1    30 
          IX6    X3+X6       CURRENT FL + INCREMENT 
          =B7    1           FLAG HONORED REQUEST 
          IX4    X1-X6       MAXFL - NEWFL
          PL     X4,GMC10    IF NEWFL .LE. MAXFL
  
          SB7    -1          FLAG MAXFL REQUESTED 
          IX2    X3-X1       CURRENT FL - MAXFL 
          PL     X2,GMC20    IF MAXFL .LE. CURRENT FL, DIE
  
          BX6    X1          NEWFL = MAXFL
 GMC10    LX6    30 
          SA6    GT1
          MEMORY SCM,GT1,RCL
  
 .TEST    IFEQ   TEST,ON,1   IF TEST MODE 
          RJ     PCS         PRINT CORE STATISTICS
  
          SA1    GT1
          AX1    30 
          BX6    X1 
          SA6    CP.AFLS     SET ACTUAL FL
          SX6    X6-10
          SA6    CP.NFLS     SET NOMINAL FL 
          EQ     EXIT.       EXIT...
  
*         HERE IF NO MORE ROOM. 
  
 GMC20    =B7    0           FLAG NO MORE ROOM
          SA1    CP.AFLS
          BX6    X1          SET ACTUAL FL
          SA2    CP.NFLS
          BX7    X2          SET NOMINAL FL 
          EQ     EXIT.       EXIT...
 LJS      SPACE  4,10 
**        LJS -  LEFT JUSTIFY (AND REFORMAT) STATEMENT LABEL. 
* 
*         ENTRY  (X5) = DPC STATEMENT LABEL (0RNNNNN).
* 
*         EXIT   (X6) = DPC STATEMENT LABEL (0H.NNNNN). 
* 
*         USES   A1,A2,A3,A6  B2,B3,B7  X1,X2,X3,X5,X6
* 
*         CALLS  SFN. 
  
  
 LJS      SUBR   =           ...ENTRY/EXIT... 
  
          IFEQ   TEST,ON,1
          ZR     X5,"BLOWUP" IF ZERO -- COMPILER ERROR
  
          MX2    CHAR 
          SX3    2R.*-1R*    (X3) = 1R. SHIFTED 6 
 LJS4     BX6    X2*X5
          LX5    CHAR 
          ZR     X6,LJS4     IF (X5) NOT LEFT JUSTIFIED 
          BX1    X5+X3       PREFIX PERIOD TO LABEL 
          LX1    -2*CHAR     0L.NNNNN  FORMAT 
          CALL   SFN         SPACE FILL NAME
          EQ     EXIT.
 MTD      SPACE  4,10 
**        MTD -  MOVE ALL TABLES TO LOW CORE. 
* 
*         PACKS UP ALL TABLES AT LOWER END OF MANAGED SPACE.
* 
*         ENTRY  (X0) = ADDRESS TO PLACE LOWEST TABLE 
* 
*         EXIT   (X0) = LWA+1 OF LAST TABLE 
* 
*         USES   A1,2,4,6,7  X0-4,6,7  B3,7 
* 
*         CALLS  MOVE 
  
  
 MTD      SUBR   =           ...ENTRY/EXIT... 
          SB3    N.TABLE-1
          SB3    -B3
  
 MTD1     SX1    B3+N.TABLE-1      NEXT ORDINAL IN TABLE VECTOR 
          SA2    X1+BASES    (X2) = FWA OF CURRENT TABLE
          SA1    X1+SIZES    (X1) = LENGTH OF CURRENT TABLE 
          LX3    X0          (X3) = NEW FWA OF CURRENT TABLE
          IX0    X0+X1       (X0) = FUTURE FWA OF NEXT TABLE
          LX7    X3 
          SA7    A2          UPDATE FWA OF CURRENT TABLE
          SB3    B3+1        POINT TO NEXT HIGHER TABLE 
          MOVE   X1,X2,X3    MOVE CURRENT TABLE DOWN
          NZ     B3,MTD1     IF MORE TABLES TO MOVE 
          EQ     EXIT.       DONE...
 MTU      SPACE  4,10 
**        MTU - MOVE ALL TABLES TO HIGH CORE. 
* 
*         PACKS ALL TABLES TOWARD HIGHER END OF MANAGED SPACE.
* 
*         ENTRY  (X0) = LWA OF NEW TABLE AREA 
* 
*         EXIT   (X0) = FWA-1 OF LOWEST TABLE 
* 
*         USES   A1,2,4,6,7 X0-4,6,7 B3,7 
* 
*         CALLS  MOVE 
  
  
 MTU      SUBR   =           ...ENTRY/EXIT... 
          SB3    N.TABLE-1   NUMBER OF TABLES TO MOVE 
  
 MTU1     SA2    B3+BASES-1  (X2) = FWA OF CURRENT TABLE
          SA1    B3+SIZES-1  (X1) = LENGTH OF CURRENT TABLE 
          IX0    X0-X1       (X0) = FUTURE LWA OF NEXT TABLE
          SX3    X0+1        (X3) = NEW FWA OF CURRENT TABLE
          LX7    X3 
          SA7    A2          UPDATE FWA OF CURRENT TABLE
          =B3    B3-1        POIN TO NEXT LOWER TABLE 
          MOVE   X1,X2,X3    MOVE CURRENT TABLE UP
          NZ     B3,MTU1     IF MOVE TABLES TO MOVE 
          EQ     EXIT.       DONE...
 PES      SPACE  4,10 
**        PES - PRINT ERROR SUMMARY.
* 
*         SENDS SUMMARIES OF THE VARIOUS ERROR TYPES
*         THAT OCCURED IN THE CURRENT PROGRAM UNIT TO 
*         THE DAYFILE AND THE CONSOLE.
* 
*         ENTRY  (X5) = STARTING OFFSET INTO *ERRTYP* . 
*                (X6) = ENDING OFFSET INTO *ERRTYP* . 
* 
*         EXIT   ERROR SUMMARIES OUTPUT.
* 
*         CALLS  CDD,MESSAGE,PLINE. 
* 
*         USES   ALL REGISTERS. 
  
  
 PES      SUBR               ENTRY/EXIT...
          SA6    PESA        PRESERVE ENDING OFFSET 
  
 PES10    SA1    ERR=A+X5    X1 = ERROR COUNT THIS LEVEL
          ZR     X1,PES30    IF NO ERRORS THIS LEVEL
          SB6    X1          SAVE NUMBER OF ERRORS
          CALL   CDD         CONVERT TO DPC 
          LX6    CHAR 
          SA2    X5+ERRTYP   X2 = ERROR TYPE INFO 
          AX2    18 
          SA1    X2          ERROR TYPE DPC 
          SA6    LINEBUF
          SA3    =20L ERROR IN  ERRORS IN 
          SA2    IDENT
          BX7    X1 
          LE     B6,B1,PES20 IF ONLY ONE ERROR
          =A3    A3+1 
  
 PES20    =A7    A6+1        +1 = (ERROR TYPE DPC)
          SX1    1R 
          LX6    X3 
          BX7    X2+X1
          =A6    A7+1        +2 = ERROR(S) IN 
          LX7    -CHAR
          =A7    A6+1        +3 = (IDENT) 
          MESSAGE  LINEBUF,,RCL 
          PLINE  LINEBUF,4,1
  
 PES30    SA1    PESA 
          =X5    X5+1 
          IX6    X1-X5
          PL     X6,PES10    IF MORE ERROR TYPES
          EQ     EXIT.
  
 PESA     EQU    SCR         PRESERVE LOOP LIMIT HERE 
 PIA      SPACE  4,10 
**        PIA - PROCESS INSTRUCTION ADDRESS.
* 
*                CONVERTS A BINARY NUMBER TO OCTAL DPC WITH LEADING 
*         ZERO SUPPRESSION. 
* 
*         NOTE-- INTENDED FOR CONVERTING A NUMBER WITH .LE. TO 6 BINARY 
*         (3 BIT) DIGITS. NO ERROR CONDITION IS FLAGGED IF .GT. 6 DIGITS
*         ARE CONVERTED.
* 
*         ENTRY  (X1) = BINARY NR TO BE CONVERTED 
* 
*         EXIT   (X2) = NR CONVERTED TO OCTAL DPC, RIGHT JUSTIFIED TO 
*                         BIT 18, WITH BLANK FILL--  (.=BLANK(55B)) 
*                         CHAR POS 10 9 8 7 6 5 4 3 2 1 
*                         CONV NR   . 1 2 3 4 5 6 . . . 
*                (X6) = SAME AS ABOVE WITH -B- SUFFIX-- 
*                                   . 1 2 3 4 5 6 B . . 
*                (B7) = NR OF DIGITS*6 CONVERTED + 2*6  (NOT INCLUDING
*                         -B- SUFFIX). TO LEFT JUSTIFY NR IN X2 OR X6 --
*                SB7    B7-9*CHAR 
*                AX2    X2,B7 
* 
*         USES   X - 1,2,6,7
*                A - 2
*                B - 7
* 
*         CALLS  NONE 
  
 PIA      SUBR   =           ** ENTRY/EXIT ** 
          SA2    =10H 
          SB7    2*CHAR 
  
 PIA2     MX7    -3 
          SB7    B7+CHAR
          BX6    -X7*X1 
          LX2    -CHAR
          SX6    X6+1R0-1R
          AX1    3
          IX2    X2+X6
          NZ     X1,PIA2     IF NOT FINISHED ASSEMBLING NR
          LX2    X2,B7       (X2) = NR IN OCTAL DPC, RT JUST TO BIT 18
          SX1    1R -1RB
          LX1    2*CHAR 
          IX6    X2-X1       (X6) = SAME AS (X2) W/ -B- SUFFIX
          EQ     EXIT.
 PCS      SPACE  4,10 
**        PCS - PRINT CORE STATISTICS.
* 
*         PRINT REQUESTED CORE EACH ALLOC MEMORY REQUEST. 
* 
*         ENTRY  (GT1) = 30/FL, 30/UNUSED 
* 
*         USES   ALL BUT (B7).
  
  
 .TEST    IFEQ   TEST,ON
 PCS      SUBR               ...ENTRY/EXIT... 
          SA1    GT1
          SX5    B7          REMEMBER (B7)
          AX1    30 
          CALL   COD         CONVERT OCTAL DIGITS 
          BX6    X4 
          SA6    PCSB 
          PLINE  PCSA,PCSC
          SB7    X5          RESTORE (B7) 
          EQ     EXIT.       EXIT...
  
 PCSA     DIS    3, -----    *         NEW FL IS
 PCSB     CON    0           FL 
 PCSC     EQU    *-PCSA 
 .TEST    ENDIF 
 WHL      SPACE  4,10 
**        WHL - WRITE HEADER LINES. 
* 
*         USES   A1-A4,A6,A7
*                X1-X4,X6,X7
*                B1-B7
  
  
 WHL      SUBR   0           ENTRY/EXIT...
          SA1    WOF=ERR
          SX2    ERFO 
          IX6    X1*X2
          SA6    TTLOFF 
          SA2    PAGELOC+X1 
          SA2    X2 
          LX2    59-58
          MI     X2,WHL1     IF NOT FIRST TIME IN 
          MX6    1
          BX6    X6+X2
          LX6    58-59
          SA6    A2 
          SA1    CO.PW+X1 
          MI     X1,WHL1     IF FILE CONNECTED
          SA1    CP.PD
          ZR     X1,WHL1     IF PD NOT ON CONTROL CARD
          SA2    WOFB 
          WRITEH X2,CP.PD,1  SET PAGE DENSITY 
  
 WHL1     =X6    0
          SA1    WOF=ERR
          SA4    PAGELOC+X1 
          SA4    X4 
          SA6    LCNT+X1     RESET LINE COUNT 
          =X3    1
          IX7    X4+X3
          SX1    X7 
          SA7    A4          UPDATE PAGE COUNT
          CALL   CDD         CONVERT PAGE NUMBER
          SA3    WOF=ERR
          SA1    CO.PW+X3 
          SX1    X1-126 
          SA2    WOFB 
          SA3    TTLOFF 
          MI     X1,WHL5     IF PW MODE 
          LX6    10*CHAR-6*CHAR 
          =A6    TL.PAGE+X3 
          WRITEH X2,O.TITL+X3,L.TITL
          SA1    WOF=ERR
          SA3    NPU+X1 
          ZR     X3,WHL2     IF SECOND PAGE OF PROGRAM UNIT 
          NZ     X1,WHL2     IF E FILE WRITE
          SX6    2
          SA3    TTLOFF 
          SA6    HLC         SET HEADER LINE COUNT
          WRITEH X2,O.CPV+X3,L.TWO  SECOND LINE 
          SA3    TTLOFF 
          WRITEH X2,O.CC+X3,L.CC    THIRD LINE
  
 WHL2     BSS    0
          SA3    WOF=ERR
          NZ     X3,WHL7     IF E-FILE WRITE
          SA2    O.STITL
          SB2    X2 
          AX2    30 
          SB4    X2 
          SX2    F.OUT
          WRITEH X2,B2,B4 
          EQ     WHL7 
  
 WHL5     SA1    TL.PAGE-1+X3 
          MX4    -6*6 
          BX1    X4*X1
          BX6    -X4*X6 
          BX6    X6+X1
          SA6    A1          10HPAGE 12345
          WRITEH X2,O.TTLA+X3,L.TTLA
          SA3    TTLOFF 
          WRITEH X2,TL.PTYP+X3,L.TTLB 
          SA1    WOF=ERR
          SA3    NPU+X1 
          ZR     X3,WHL7     IF SECOND PAGE OF PROGRAM UNIT 
          NZ     X1,WHL7     IF E FILE WRITE
          SX6    4           HEADER LINE COUNT
          SA3    TTLOFF 
          SA6    HLC         SET HEADER LINE COUNT
          WRITEH X2,O.CPV+X3,L.TA 
          SA3    TTLOFF 
          WRITEH X2,O.TA+X3,L.TB
          SA3    TTLOFF 
          WRITEH X2,O.CC+X3,L.CCA 
          SA3    TTLOFF 
          WRITEH X2,O.C+X3,L.CCB
  
 WHL7     WRITEH X2,HDRBL,1 
          EQ     EXIT.       EXIT...
  
 TTLOFF   BSS    1
 PAGELOC  CON    CP.PAGE,CP.EPAG   LOCS OF PAGE COUNTS
 NPU      CON    0,1         NEXT PROGRAM UNIT FLAG // HEADER LINE FLAG 
*                            FOR ERROR FILE.
 HLC      CON    0           HEADER LINE COUNT - 2 OR 4 
 WOF      SPACE  4,12 
**        WOF -  WRITE OUTPUT FILE
* 
*         ENTRY  (X1) _ FWA OF LINE IN H FORMAT 
*                (X2) = LINE LENGTH IN WORDS
*         (B5) = 1 + NUMBER OF BLANK LINES TO OUTPUT BEFORE LINE
* 
*         USES   A1-4,A6,A7 
*                X1-4,X6,X7 
*                B1-7 
* 
*         CALLS  WHL, WRITEH
  
  
 WOF      SUBR   =           ENTRY/EXIT...
          SX6    B4 
          SA6    WOFC 
          SA4    WOF=ERR
          SA3    FV.OUT+X4
          BX6    X3 
          ZR     X3,EXIT.    IF L=0 
 #RM      IFNE   CP#RM,0,1
          SX6    A3          POINT TO FIT FOR RM MACRO
          SA6    WOFB        FET FOR OUT/ERR
          SA3    LCNT+X4
          SA4    CO.PS
          SX6    X3+B5
          IX7    X4-X6
          SA6    A3          UPDATE LINE COUNT
          SB6    X1 
          PL     X7,WOF1     IF PAGE NOT FULL 
  
*         WRITE HEADER LINE.
  
          LX2    30 
          IX6    X1+X2
          SA6    WOFA        SAVE FWA AND LENGTH OF LINE
          RJ     WHL         WRITE HEADER LINES 
          SA1    WOF=ERR
          LX4    X1 
          SA1    LCNT+X1
          =X6    X1+1 
          SA2    NPU+X4     X4  =  WOF=ERR
          ZR     X2,WOF0    IF NOT FIRST PAGE OF PROGRAM UNIT 
          SX7    X2-1 
          SA7    A2         NEXT PROGRAM UNIT FLAG
          SA2    HLC        HEADER LINE COUNT 
          IX6    X6+X2      ACCOUNT FOR HEADER LINES
  
 WOF0     BSS    0
          SA6    A1 
          EQ     WOF3        WRITE REQUESTED LINES
  
*         WRITE BLANK LINES BEFORE REQUESTED LINE.
  
 WOF1     EQ     B5,B1,WOF4  IF NO BLANKS TO WRITE
          LX2    30 
          IX6    X1+X2
          IFEQ   TEST,ON,2   IF TEST MODE 
          SB7    4
          GT     B5,B7,"BLOWUP" ONLY 4 BLANK LINES PROVIDED 
  
          SB7    B5-1 
  
          SA6    WOFA        SAVE FWA AND LENGTH
          SA2    WOFB 
          WRITEH X2,HDRBL,B7
 WOF3     SA2    WOFA 
          SB6    X2          RESTORE FWA
          AX2    30          RESTORE LENGTH 
  
*         WRITE REQUESTED LINE. 
  
 WOF4     NZ     B6,WOF5     IF LINE TO WRITE 
          SA1    WOF=ERR
          SA1    LCNT+X1
          =X6    X1-1 
          SA6    A1 
          EQ     WOF7 
  
 WOF5     SB7    X2+
  
 .T       IFEQ   TEST,ON
          ZR     B7,"BLOWUP" REQUEST WITHOUT LENGTH NFG 
 .T       ENDIF 
  
          SA2    WOFB 
          WRITEH X2,B6,B7 
 WOF7     SA1    WOFC 
          SB4    X1+         RESTORE B4 
          EQ     EXIT.       DONE...
  
 WOFC     BSS    1           SAVE B4
 WOFA     BSS    1           SAVE FWA AND LENGTH
 WOFB     BSS    1           FET FOR OUTPUT/ERRORS
  
  
 HDRBL    LIT    2L  ,2L  ,2L  ,2L
          ENTRY  HDRBL
          TITLE  INSTRUCTION SKELETON TABLE.
 INST     SPACE  4,10 
**        INST - MACRO TO GENERATE INSTRUCTION SKELETONS. 
* 
*         GENERATES TABLE OF INSTRUCTION SKELETONS USED TO BY *LIST*
*                TO CONVERT INSTRUCTIONS TO HUMAN-READABLE FORM FOR 
*                THE OBJECT CODE LISTING. 
* 
*         INST   (KEY),(ATTRS)
* 
*         *KEY*  = INSTRUCTION DESCRIPTOR.  EACH CHARACTER OF THE *KEY* 
*                  HAS MEANING AS FOLLOWS --
*                            I   I-PORTION OF INSTRUCTION 
*                            J   J-PORTION OF INSTRUCTION 
*                            K   K-PORTION OF INSTRUCTION (3 BITS ONLY) 
*                            Q   18-BIT *K* ADDRESS FIELD (MUST BE LAST)
*                            C   OUTPUT A *B* IF THE NEXT REGISTER IS 
*                                            NOT A ZERO,
*                                            ELSE, SKIP THE NEXT 2 ITEMS
*                            + - * / A B X , AND BLANK ALL STAND FOR
*                                            THEMSELVES.
*         *ATTRS* = LIST OF ATTRIBUTES.  SEE (OD.) DATA STRUCTURE.
  
  
 M        EQU    OD.ATRL
          ERRNZ  59-OD.QP    ASSUMPTIONS IN MACRO 
          ERRNZ  58-OD.BJMPP
          ERRNZ  57-OD.FUPAP
          ERRNZ  4-OD.EDL 
          ERRNZ  12-OD.GHL
          ERRMI  30-OD.ATRL  OCTMIC WON'T WORK RIGHT
  
  
 INST     MACRO  KEY,ATTRS
*                            INIT AND SET (C) = NUMBER OF DESCRIPTORS.
 A        MICRO  3,1,=KEY=
 B        MICRO  5,,=KEY= 
 B        MICRO  1,,="A""B"=
 C        MICCNT B
 1        ERRPL  C-OD.EDN    DESCRIPTOR (KEY) IS TOO LONG 
 E        MICRO  1,,-3/L- 
*                            MARK AS LONG IF LAST DESRIPTOR IS Q
 A        MICRO  C+3,1,=KEY=
 L        SET    0
          IFC    EQ,="A"=Q=,1 
 L        SET    L+4
*                            DECODE EXPLICIT ATTRIBUTES.
 F        MICRO  1,, 0
          IRP    ATTRS
          IFC    EQ,=ATTRS=BJMP=,2
 L        SET    L+2
 .3       SKIP
          IFC    EQ,=ATTRS=FUPA=,2
 L        SET    L+1
 .3       SKIP
 G        DECMIC OD.ATTRS_P-OD.ATRP 
 F        OCTMIC "F"B+1S"G" 
 .3       ENDIF 
          IRP 
*                            TRANSLATE EDIT DESCRIPTORS INTO NUMBERS. 
 D        SET    0
 .1       DUP    OD.EDN 
 D        SET    D+1
 A        MICRO  D,1,="B"...........= 
 A        MICRO  2*1R"A"-1,2,/101112-D-E-F-G-H010203-L-M-N-O-P04-R-S-T-U
,-V-W13-Y-Z-0-1-2-3-4-5-6-7-8-905060708-(-)-$-=140900/
 E        MICRO  1,,="E",4/"A"= 
.1        ENDD
*                            PASTE IT ALL TOGETHER. 
 A        MICRO  1,2, KEY 
 +        VFD    "E",M/"F"B,12/2R"A"
 INST     ENDM
 F.PIK    SPACE  4,30 
**        F.PIK - INSTRUCTION DESCRIPTION VECTOR. 
  
  
 F.PIK    BSSENT 0           MACHINE OP DESCRIPTION VECTOR
 PIK=PS   BSSENT 0           **** OLD NAME TEMP ****
          LOC    00 
          INST   (PS  Q)                 00    (FAKE) 
          INST   (RWI XJ,XK)             01    (FAKE)  LCM DIRECT ONLY
          INST   (JP  CI+Q),(FUPA)       02 
          INST   (JXI XJ,Q)              03I    (FAKE)
 PIK.EQ   INST   (EQ  CI,CJ,Q),(BJMP)    04 
          INST   (NE  CI,CJ,Q),(BJMP)    05 
          INST   (GE  CI,CJ,Q),(BJMP)    06 
          INST   (LT  CI,CJ,Q),(BJMP)    07 
  
          INST   (BXI XJ),(COPY)         10 
          INST   (BXI XJ*XK)             11 
          INST   (BXI XJ+XK)             12 
          INST   (BXI XJ-XK)             13 
          INST   (BXI -XJ),(COPY)        14 
          INST   (BXI -XK*XJ),(KJ)       15 
          INST   (BXI -XK+XJ),(KJ)       16 
          INST   (BXI -XK-XJ),(KJ)       17 
  
          INST   (LXI JKB),(JKV)         20 
          INST   (AXI JKB),(JKV)         21 
          INST   (LXI CJ,XK),(BJ)        22 
          INST   (AXI CJ,XK),(BJ)        23 
          INST   (NXI CJ,XK),(BJ)        24 
          INST   (ZXI CJ,XK),(BJ)        25 
          INST   (UXI CJ,XK),(BJ,UP)     26 
          INST   (PXI CJ,XK),(BJ,PK)     27 
  
          INST   (FXI XJ+XK),(FPA)       30 
          INST   (FXI XJ-XK),(FPA)       31 
          INST   (DXI XJ+XK),(FPA)       32 
          INST   (DXI XJ-XK),(FPA)       33 
          INST   (RXI XJ+XK),(FPA)       34 
          INST   (RXI XJ-XK),(FPA)       35 
          INST   (IXI XJ+XK)             36 
          INST   (IXI XJ-XK)             37 
  
          INST   (FXI XJ*XK),(FPA)       40 
          INST   (RXI XJ*XK),(FPA)       41 
          INST   (DXI XJ*XK),(FPA,IM)    42 
          INST   (MXI JKB),(JKV)         43 
          INST   (FXI XJ/XK),(FPA,DIV)   44 
          INST   (RXI XJ/XK),(FPA,DIV)   45 
          INST   (NO  IJKB)              46 
          INST   (CXI XK),(COPY)         47 
  
          INST   (SAI AJ+Q)            50 
          INST   (SAI CJ+Q)            51 
          INST   (SAI XJ+Q)            52 
          INST   (SAI CK+XJ)           53 
          INST   (SAI CK+AJ)           54 
          INST   (SAI AJ-BK)           55 
          INST   (SAI CK+BJ)           56 
          INST   (SAI BJ-BK)             57 
  
          INST   (SBI AJ+Q)            60 
          INST   (SBI CJ+Q)            61 
          INST   (SBI XJ+Q)            62 
          INST   (SBI CK+XJ)           63 
          INST   (SBI CK+AJ)           64 
          INST   (SBI AJ-BK)           65 
          INST   (SBI CK+BJ)           66 
          INST   (SBI BJ-BK)             67 
  
          INST   (SXI AJ+Q)            70 
          INST   (SXI CJ+Q)            71 
          INST   (SXI XJ+Q)            72 
          INST   (SXI CK+XJ)           73 
          INST   (SXI CK+AJ)           74 
          INST   (SXI AJ-BK)           75 
          INST   (SXI CK+BJ)           76 
          INST   (SXI BJ-BK)             77 
          LOC    *O 
 PIK=EQ   EQUENT PIK.EQ+F.PIK 
  
 .DAL     IFEQ   .DAL,.DAL   DIRECT ACCESS LCM INSTRUCTIONS 
 PIK=LCM  BSSENT 0
          INST   (RXJ XK)                014   DRL
          INST   (WXJ XK)                015   DWL
 .DAL     ENDIF 
  
 PIK=XJP  BSSENT 0           X-REGISTER JUMPS 
          INST   (ZR  XJ,Q)              030
          INST   (NZ  XJ,Q)            031
          INST   (PL  XJ,Q)            032
          INST   (MI  XJ,Q)            033
          INST   (IR  XJ,Q)            034
          INST   (OR  XJ,Q)            035
          INST   (DF  XJ,Q)            036
          INST   (ID  XJ,Q)            037
  
 PIK=PI   BSSENT 0           PSEUDO-INST SKELETON TABLE 
          INST   (RJK Q),(FUPA)          0001  RJT
          INST   (RJ  Q),(FUPA)          0002  SHORT RJ 
          INST   (JP  CI+Q),(FUPA)       0003 
          INST   (EQ  Q),(FUPA)          0004 
  
          PURGMAC INST
          SPACE  4,10 
          LIST   D
          END 
