*DECK SET6
USETEXT CCTTEXT 
USETEXT DNTEXT
USETEXT PPTEXT
    PROC SET6;
         CONTROL PACK;
          BEGIN 
         DEF BOOLEAN #2#; 
*CALL DPPPDDATA 
*CALL PPCOMMON2 
*CALL RCT 
*CALL DNATVALS
*CALL AUXTVALS
*CALL PLTVALS 
         SWITCH SUB    #SUB0#,
         SUB1 , SUB2 , SUB3 , SUB4 , SUB5 , 
         SUB6 , SUB7 , SUB8 , SUB9 , SUB10, 
         SUB11, SUB12, SUB13, SUB14, SUB15, 
         SUB16, SUB17, SUB18, SUB19, SUB20, 
         SUB21, SUB22, SUB23, SUB24, SUB25, 
         SUB26, SUB27, SUB28, SUB29, SUB30, 
         SUB31, SUB32, SUB33, SUB34, SUB35, 
         SUB36, SUB37, SUB38, SUB39, SUB40, 
         SUB41,      ,      , SUB44, SUB45, 
              , SUB47, SUB48, SUB49, SUB50, 
         SUB51, SUB52, SUB53, SUB54, SUB55, 
         SUB56, SUB57,      , SUB59, SUB60, 
         SUB61, SUB62, SUB63, SUB64, SUB65, 
         SUB66, SUB67, SUB68, SUB69, SUB70, 
         SUB71, SUB72,      , SUB74,      , 
              , SUB77, SUB78, SUB79, SUB80, 
              ,      ,      , SUB84, SUB85; 
         SWITCH SCASE SCASE0, 
                      SCASE1, 
                      SCASE2, 
                      SCASE3; 
         CONTROL EJECT; 
          XREF PROC SETPLST;
          ITEM STOPBUFFER C(60);
          ITEM INITALLBIT;
    PROC INITPROC;
          BEGIN 
          ITEM LEVELREG        I; 
          ITEM TYPEREG         I; 
          ITEM DNATREG         I; 
          ITEM ILX             I; 
          ITEM INITGRPLEVEL    I; 
          ITEM REG1            I;    #RECEIVING FIELD LOOP INDEX# 
          ITEM REG2            I;    #STACK INDEX#
          ITEM REG3            I;    #DNAT INDEX OF TEMP INDEX NAME#
          ITEM REG4            I;    #PNAT INDEX OF GENERATED LABEL#
          ITEM REG5            I;    #SCRATCH#
          ITEM REG6            I;    #SCRATCH#
         CONTROL EJECT; 
    PROC INITIALIZE;
         BEGIN
         SWITCH CASESW CASE0, 
                       CASE1, 
                       CASE2, 
                       CASE3, 
                       CASE4, 
                       CASE5, 
                       CASE6, 
                       CASE7; 
          #IT IS ASSUMED THAT ANY MOVE WILL BE LEGAL IF#
          #WE GET THIS FAR UNLESS INCOMPATIBLE IS SET#
          IF INCOMPATIBLE EQ 1  THEN RETURN;
          #WHAT KIND OF REPLACEMENT IS SPECIFIED #
         GOTO CASESW[REPTYPE];
CASE0:  
               BEGIN
               #REPTYPE = 0 : NO REPLACING PHRASE SPECIFIED#
               IF TYPEREG LQ ALPHNUMED
               THEN INITLATTEMP = -2; 
               ELSE BEGIN 
                    IF TYPEREG EQ BOOLBIT OR
                       TYPEREG EQ BOOLDSP OR
                       (TYPEREG GQ LOWNUMRESULT AND 
                        TYPEREG LQ HINUMOPERND) 
                    THEN BEGIN
                         INITLATTEMP = -1;
                         END
                    ELSE BEGIN
                         RETURN;
                         END
                    END 
               GOTO ENDCASE;
               END
CASE1:  
               BEGIN
               #REPTYPE = 1 : ALPHABETIC# 
               IF TYPEREG NQ ALPHABET AND 
                  TYPEREG NQ ALPHEDIT 
               THEN RETURN; 
               ELSE GOTO ENDCASE; 
               END
CASE2:  
               # REPTYPE = 2  BOOLEAN # 
               IF TYPEREG NQ BOOLDSP AND
                  TYPEREG NQ BOOLBIT
               THEN RETURN; 
               ELSE GOTO ENDCASE; 
               RETURN;
CASE3:  
               BEGIN
               #REPTYPE = 3 : ALPHANUMERIC# 
               IF TYPEREG NQ ALPHNUM
               THEN RETURN; 
               ELSE GOTO ENDCASE; 
               END
CASE4:  
               BEGIN
               #REPTYPE = 4 : ALPHANUMERIC EDIT#
               IF TYPEREG NQ ALPHNUMED
               THEN RETURN; 
               ELSE GOTO ENDCASE; 
               END
CASE5:  
               #REPTYPE = 5 : NOT USED# 
               RETURN;
CASE6:  
               BEGIN
               #REPTYPE = 6: NUMERIC EDIT#
               IF TYPEREG NQ NUMERICEDIT
               THEN RETURN; 
               ELSE GOTO ENDCASE; 
               END
CASE7:  
               BEGIN
               #REPTYPE = 7 : NUMERIC#
               IF TYPEREG LS LOWNUMOPERND OR
                  TYPEREG GR HINUMOPERND
               THEN RETURN; 
               END
ENDCASE:  
          #WHAT KIND OF SENDING FIELD DO WE HAVE #
          IF LSW EQ 1 
          THEN BEGIN
               #CREATE A NEW LAT ENTRY FOR EACH MOVE : LITERAL,#
               #ZERO OR SPACE. LATTEMP MAY HAVE BEEN CLOBBERED# 
               #IF LOOPS HAVE BEEN SET UP#
              #INITLATTEMP EQ -2 MEANS SPACES#
              #INITLATTEMP EQ -1 MEANS ZEROS# 
              #FOR THESE WE WILL USE IMMEDIATE LAT ENTRIES# 
              IF INITLATTEMP LS 0 
              THEN BEGIN
                   #ZERO OR SPACE#
                   #CREATE A GTEXT ATOM, A DNAT, AND AN LAT ENTRY#
                   #THE LAT IMMEDIATE BIT IS TURNED ON# 
                   LATTEMP = 0; 
                   OPERAND1 = CREATELDL(DNATREG,1); 
                   IF INITLATTEMP EQ -2 
                   THEN SET(L$SPACES,LAT$,LATLENGTH,1); 
                   END
              ELSE BEGIN
                   #LITERAL OTHER THAN ZERO OR SPACE# 
                   LATTEMP = INITLATTEMP; 
                   OPERAND1 = CREATELDL(DNATREG,0); 
                   SET(L$ALL,LAT$,LATLENGTH,INITALLBIT);
                   END
              SET(L$VCODE,LAT$,LATLENGTH,2);
              END 
          ELSE BEGIN
               #BUMP REF COUNT FOR SUBSCRIPTED SENDING FIELD# 
               IF SENDREFINDX NQ 0
               THEN BEGIN 
                    FIX1 = GET(RCT$ENTRY,RCT$,SENDREFINDX) + 1; 
                    SET(RCT$ENTRY,RCT$,SENDREFINDX,FIX1); 
                    END 
               END
          #DO WE NEED TO WORRY ABOUT SUBSCRIPTS # 
          #UPDATE REFERENCE COUNT OF CURRENT CALCULATION LEVEL# 
          REG5 = INITREFCOUNT[ILX]; 
          #ARE THERE ANY SUBSCRIPTS ANYWAY #
          IF REG5 NQ 0
          THEN BEGIN
               FIX1 = GET(RCT$ENTRY,RCT$,REG5) + 1; 
               SET(RCT$ENTRY,RCT$,REG5,FIX1); 
               END
          #GENERATE THE ELEMENTARY MOVE GTEXT#
          NGMOVE; 
          NG(OPERAND1); 
          NG(OPERAND2); 
          #ALL LOOPS UP TO CURRENT LEVEL ARE NOW NECESSARY# 
          FOR REG5 = 1 STEP 1 UNTIL ILX 
              DO INITNULL[REG5] = 0;
          RETURN; 
          END #INITIALIZE#
         CONTROL EJECT; 
    PROC LOOPEPILOGUE;
          BEGIN 
          #DELETE THE LOOP IF IT CONTAINS NO ELEMENTARY MOVES#
          IF INITNULL[ILX] NQ 0 
          THEN BEGIN
               #DELETE THE GTEXT FOR LOOP SETUP ALREADY GENERATED#
               G = INITNULL[ILX]; 
               #DID WE HAVE ANY SUBSCRIPTS AT NEXT LOWER LEVEL #
               REG5 = INITREFCOUNT[ILX-1];
               IF REG5 EQ 0 
               THEN REG6 = 0; 
               ELSE BEGIN 
                    #DECREMENT REF COUNT FOR UNUSED COMBINATION#
                    FIX1 = GET(RCT$ENTRY,RCT$,REG5) - 1;
                    SET(RCT$ENTRY,RCT$,REG5,FIX1);
                    REG6 = 1; 
                    END 
               #DELETE REFERENCE COUNT TABLE ENTRIES# 
              RFTLENGTH = RFTLENGTH - 2 * REG6; 
               #DELETE UNUSED MNEMONIC NUMBERS# 
               SUBSCRIPT$ = SUBSCRIPT$ - 1 - REG6;
               END
          ELSE BEGIN
               #OTHERWISE GENERATE GTEXT TO INCREMENT LOOP INDEX# 
               NG($SET);
               NG($SETUPBY);
               NG(INITINCR[ILX]); 
               NG(INITTEMP[ILX]); 
               #GENERATE THE TEST FOR END OF TABLE# 
               NG($NOTGT);
               NG(INITTEMP[ILX]); 
               NG(INITMAX[ILX]);
               NG(INITBRANCH[ILX]); 
               #NOW ACTUALLY ALLOCATE STORAGE FOR INDEX NAME TEMP#
               REG5 = INITVAR[ILX]; 
               LOCALTEMP(REG5); 
               END
          #DECREMENT DEPTH INDICATOR# 
          ILX = ILX - 1;
          RETURN; 
          END #LOOPEPILOGUE#
  
  
          #****** MAIN LINE OF INITPROC ******# 
          #SET UP DEPTH OF NESTING INDICATOR# 
          ILX = 0;
          #PROCESS RECEIVING FIELDS LEFT TO RIGHT#
          FOR REG1 = 1 STEP 1 UNTIL S$
          DO BEGIN
               #OUTPUT SUBSCRIPTS TO GTEXT - WE MAY ADD MORE LATER# 
               REG2 = RETRIEVE(REG1); 
               #CALCULATE PRELIMINARY INFORMATION#
               OPERAND2 = STACK(REG2);
               DNATREG = TPOINTER(REG2);
               TYPEREG = GET(DN$TYPE,DNAT$,DNATREG);
               LEVELREG = GET(DN$LEVEL,DNAT$,DNATREG);
               #SAVE NECESSARY SUBSCRIPTING INFORMATION#
               REG8 = COMMONSTACK(REG1);
               INITSSNUM [0] = B<45, 15> REG8;
               INITREFCOUNT [0] = B<30,15> REG8;
               INITMNUMBER [0] = B<51,09>OPERAND2;
               #MAKE PRELIMINARY TYPE VALIDITY CHECKS#
               IF TYPEREG EQ ERRTYPE THEN GOTO NEXTRECFIELD;
               IF TYPEREG EQ INDXDATA 
               THEN BEGIN 
                    #TOO BAD - USAGE IS INDEX IS ILLEGAL# 
                    ERROR(SEVERE,703,LINE(REG2),COLUMN(REG2));
                    GOTO NEXTRECFIELD;
                    END 
               #MAKE PRELIMINARY TESTS ON LEVEL#
               IF LEVELREG GR DATANAMEMAX AND 
                  LEVELREG NQ 77 AND
                  LEVELREG NQ REFMODLEVEL 
               THEN BEGIN 
                    #TROUBLE - LEVEL NUMBER IS INCORRECT# 
                    FIX1 = 0; 
                    IF LEVELREG EQ 66 
                    THEN FIX1 = 701;
                    ELSE IF LEVELREG EQ FDDESCR 
                         THEN FIX1 = 187; 
                         ELSE IF LEVELREG EQ SDDESCR
                              THEN FIX1 = 188;
                              ELSE IF LEVELREG EQ CDDESCR 
                                   THEN FIX1 = 189; 
                                   ELSE IF LEVELREG EQ RDDESCR
                                        THEN FIX1 = 190;
                                        ELSE IF LEVELREG EQ INDXLEVL
                                             THEN FIX1 = 704; 
                    IF FIX1 NQ 0
                    THEN  ERROR(SEVERE,FIX1,LINE(REG2),COLUMN(REG2)); 
                    GOTO NEXTRECFIELD;
                    END 
               #DETERMINE IF ITEM IS ELEMENTARY OR GROUP# 
               IF TYPEREG EQ GROUP  THEN GOTO GROUPPROC;
               IF TYPEREG EQ VARGROUP 
               THEN BEGIN 
                    #VARIABLE GROUPS MAY NOT BE INITIALIZED#
                    ERROR(SEVERE,705,LINE(REG2),COLUMN(REG2));
                    GOTO NEXTRECFIELD;
                    END 
  
  
  
               #THE RECEIVING FIELD IS ELEMENTARY#
               IF GET(DN$DEP,DNAT$,DNATREG) EQ 1
               THEN BEGIN 
                    #THE DEPENDING BIT IS SET.# 
                    #IT IS OK IF THE OCCURS BIT IS OFF. IN THAT CASE,#
                    #THIS ITEM DOES NOT CONTAIN THE OCCURS DEPENDING #
                    #ON CLAUSE BUT IS SUBORDINATE TO AN ITEM THAT # 
                    #CONTAINS THE DEPENDING ON CLAUSE.# 
                    IF GET(DN$OCCURS,DNAT$,DNATREG) EQ 1
                    THEN BEGIN
                         #THE DEPENDING AND THE OCCURS BITS ARE SET.# 
                         #THAT DOESN"T NECESSARILY MEAN THAT THIS ITEM# 
                         #CONTAINS THE OCCURS DEPENDING ON CLAUSE,# 
                         #IT COULD CONTAIN AN ORDINARY OCCURS CLAUSE# 
                         #AND BE SUBORDINATE TO AN ITEM THAT CONTAINS#
                         #AN OCCURS DEPENDING ON CLAUSE.# 
                         #OCCURS DEPENDING ON CAN ONLY APPEAR AT THE# 
                         #FIRST LEVEL OF SUBSCRIPTING. THUS IF #
                         #SUBSCRIPT DEPTH IS GREATER THAN 1 THEN #
                         #WE ARE SUBORDINATE.#
                         IF GET(DN$SDEPTH,DNAT$,DNATREG) LQ 1 
                         THEN BEGIN 
                              #THIS ITEM CONTAINS AN OCCURS#
                              #DEPENDING ON CLAUSE.  THIS IS ILLEGAL.#
                              #NOTE - WE COULD HANDLE THIS BUT WE DON"T#
                              ERROR(SEVERE,705,LINE(REG2),COLUMN(REG2));
                              GOTO NEXTRECFIELD;
                              END 
                         END
                    END 
               IF REPTYPE NQ 0
               THEN BEGIN 
                    #REPLACING WAS SPECIFIED# 
                    #RECEIVING FIELD IS ELEMENTARY, THEREFORE,# 
                    #THE CATEGORY OF THE RECEIVING FIELD MUST BE# 
                    #IDENTICAL TO THE REPLACING TYPE CATEGORY.# 
                    IF REPTYPE EQ NUMERIC AND 
                       TYPEREG GQ LOWNUMOPERND AND
                       TYPEREG LQ HINUMOPERND 
                       THEN GOTO L3;
                    IF REPTYPE EQ BOOLEAN AND 
                       (TYPEREG EQ BOOLBIT OR TYPEREG EQ BOOLDSP) 
                    THEN BEGIN
                         GOTO L3; 
                         END
                    IF REPTYPE NQ TYPEREG 
                    THEN BEGIN
                         ERROR(TRIVIAL,707,LINE(REG2),COLUMN(REG2));
                         GOTO NEXTRECFIELD; 
                         END
                    END 
               L3:  
               #EVERYTHING SEEMS TO BE OK#
               INITIALIZE;
               GOTO NEXTRECFIELD; 
         CONTROL EJECT; 
GROUPPROC:  
               #THE RECEIVING FIELD IS A GROUP ITEM#
               #NOW PROCESS EACH DNAT IN THE GROUP ONE AFTER THE OTHER# 
               #IGNORE : LEVEL 77 ITEMS#
               #         LEVEL 88 ITEMS#
               #         INDEX NAMES# 
               #         INDEX DATA ITEMS#
               #         FILLER ITEMS#
               #         REDEFINED AREAS IN GROUP#
               #THE GROUP ITSELF MAY BE A REDEFINITION# 
               #SAVE LEVEL OF CURRENT GROUP ITEM# 
               INITGRPLEVEL = LEVELREG; 
LOOP: 
               #ADVANCE TO THE NEXT DNAT# 
               DNATREG = DNATREG + 1; 
               TYPEREG = GET(DN$TYPE,DNAT$,DNATREG);
               LEVELREG = GET(DN$LEVEL,DNAT$,DNATREG);
               IF LEVELREG EQ 77  THEN GOTO LOOP; 
               IF LEVELREG EQ 88  THEN GOTO LOOP; 
               IF LEVELREG EQ INDXLEVL  THEN GOTO LOOP; 
               #TEST FOR GROUP TERMINATORS# 
               IF LEVELREG GR DATANAMEMAX  THEN GOTO ENDOFGROUP;
               IF LEVELREG LQ INITGRPLEVEL THEN GOTO ENDOFGROUP;
               #WATCH FOR REDEFINES#
               IF GET(DN$RDEF,DNAT$,DNATREG) EQ 1 
               THEN BEGIN 
                    #SKIP THE REDEFINED AREA# 
                    FOR $DUMMY$ = 0 WHILE 
                        GET(DN$LEVEL,DNAT$,DNATREG+1) GR LEVELREG 
                     DO  DNATREG = DNATREG + 1; 
                    #START AGAIN WITH UNREDEFINED AREA# 
                    GOTO LOOP;
                    END 
               #TERMINATE ALL ACTIVE LOOPS IF ANY#
               FOR $DUMMY$ = 0 WHILE
                 ILX GR 0 AND LEVELREG LQ INITLEVEL[ILX]
               DO  LOOPEPILOGUE;
               IF (ILX EQ 0) AND (LSW EQ 1) AND 
                    (GET(DN$TYPE,DNAT$,DNATREG - 1) NQ GROUP) THEN
                    NG($SEPARATOR); 
               #TEST FOR NEW TABLE : MEANING MORE SUBSCRIPTING# 
               IF GET(DN$OCCURS,DNAT$,DNATREG) EQ 1 
               THEN BEGIN 
                    #THIS IS THE START OF A TABLE#
                    ILX = ILX + 1;
                    IF ILX GR MAXILX
                    THEN BEGIN
                         # ILX DEPTH EXCEEDS CURRENT MAXIMUM #
                         CMM$GLV(ISTACK,16);
                         MAXILX = MAXILX + 4; 
                         END
                    INITLEVEL[ILX] = LEVELREG;
                    INITNULL[ILX] = G;
                    #CREATE AN INDEX NAME TEMP FOR LOOP CONTROL#
                    REG3 = NEXTTEMP;
                    INITVAR[ILX] = REG3;
                    INITTEMP[ILX] = GTX(GDATAREF,REG3,0); 
                    #SET ATTRIBUTES OF THE INDEX NAME TEMP# 
                    SET(DN$MAJMSEC,DNAT$,REG3,TEMPMSEC);
                    SET(DN$TYPE,DNAT$,REG3,INDXNAME); 
                    FIX1 = GET(DN$AUXREF,DNAT$,DNATREG);
                    SET(DN$AUXREF,DNAT$,REG3,FIX1); 
                    FIX1 = GET(DN$SDEPTH,DNAT$,DNATREG);
                    SET(DN$IDXDEP,DNAT$,REG3,FIX1); 
                    SET(DN$ITMLEN,DNAT$,REG3,10); 
                    SET(DN$NUMLEN,DNAT$,REG3,5);
                    LOCALTEMP(REG3);
                    #THE INITIAL VALUE AND INCREMENT IS 1#
                    LATTEMP = 1;
                    INITINCR[ILX] = CREATELDL(REG3,1);
                   SET(DN$MAJMSEC,DNAT$,DNATLENGTH,LITMSEC);
                   SET(DN$TYPE,DNAT$,DNATLENGTH,NUMERIC); 
                    #INITIALIZE THE LOOP INDEX TO 1#
                    NG($SET); 
                    NG($SETTO); 
                    NG(INITINCR[ILX]);
                    NG(INITTEMP[ILX]);
                    #ALLOCATE A MNEMONIC NUMBER FOR THIS SUBSCRIPT# 
                    SUBSCRIPT$ = SUBSCRIPT$ + 1;
                    IF SUBSCRIPT$ GR CSTMAXNUM
                    THEN CSTMAXNUM = SUBSCRIPT$;
                    INITREFCOUNT [ILX] = 0; 
                    #GENERATE A SUBSCRIPT FETCH FOR THE INDEX NAME# 
                    NGGTX(GVERB,SUBSCRIPT$,GSUBSFET); 
                    NGGTX(GDATAREF,REG3,0); 
                    #DEFINE A LABEL FOR THE TOP OF THE LOOP#
                    REG4 = NEXTPNAT;
                    NGLABELDEF(REG4); 
                    #BUILD THE LABEL REFERENCE TO BE USED # 
                    #AT LOOP BOTTOM.# 
                    INITBRANCH[ILX] = GTX(GLABELREF,REG4,GTRUE);
                    #GENERATE A COMBINATION OF CURRENT INDEX NAME#
                    #WITH PREVIOUS SUBSCRIPTS IF THERE ARE ANY# 
                    REG5 = INITSSNUM[ILX-1];
                    IF REG5 NQ 0
                    THEN BEGIN
                         #SET UP REFERENCE COUNT FOR COMBINATION# 
                         RFTLENGTH = RFTLENGTH + 2; 
                         SET(RCT$ENTRY,RCT$,RFTLENGTH,0); 
                         NGGTX(GVERB,RFTLENGTH,GSUBSUM);
                         NGGTX(GSUBATOM,SUBSCRIPT$,SUBSCRIPT$+1); 
                         NGGTX(GSUBATOM,REG5,0);
                         #INCREMENT REF COUNT FOR CONSTITUENT ELEMENTS# 
                         REG5 = INITREFCOUNT[ILX-1];
                         IF REG5 NQ 0 
                         THEN 
                              BEGIN 
                              FIX1 = GET(RCT$ENTRY, RCT$, REG5) + 2;
                              SET( RCT$ENTRY, RCT$, REG5,FIX1); 
                              END 
                         #ACTUALLY ALLOCATE SUBSCRIPT MNEMONIC# 
                         SUBSCRIPT$ = SUBSCRIPT$ + 1; 
                         IF SUBSCRIPT$ GR CSTMAXNUM 
                         THEN CSTMAXNUM = SUBSCRIPT$; 
                         INITREFCOUNT [ILX] = RFTLENGTH;
                         END
                    #SAVE INFORMATION FOR LATER USE#
                    MNUMBER = MNUMBER + 1;
                    IF MNUMBER GR CCTMAXMNUM
                    THEN BEGIN
                         CCTMAXMNUM = MNUMBER;
                         END
                    INITMNUMBER [ILX] = MNUMBER;
                    NGGTX(GVERB,INITMNUMBER[ILX],GSUBSREF); 
                    NGGTX(GSUBATOM,SUBSCRIPT$,0); 
                    INITSSNUM[ILX] = SUBSCRIPT$;
                    REG5 = GETAUX(DNATREG,MAXOCCUR);
                    LATTEMP = GET(AX$MAXOCCNO,AUX$,REG5); 
                    INITMAX[ILX] = CREATELDL(REG3,1); 
                   SET(DN$MAJMSEC,DNAT$,DNATLENGTH,LITMSEC);
                   SET(DN$TYPE,DNAT$,DNATLENGTH,NUMERIC); 
                    END 
               IF TYPEREG EQ GROUP  THEN GOTO LOOP; 
               #ITEM IS ELEMENTARY : IGNORE IF FILLER OR INDEX USAGE# 
               IF GET(DN$FILLREF,DNAT$,DNATREG) EQ 1
               THEN GOTO LOOP;
               IF TYPEREG EQ INDXDATA  THEN GOTO LOOP;
               #CONSTRUCT SENDING FIELD#
               OPERAND2 = GTX(GDATAREF,DNATREG,INITMNUMBER[ILX]); 
               #READY TO INITIALIZE THIS ELEMENTARY ITEM# 
               INITIALIZE;
               GOTO LOOP; 
ENDOFGROUP: 
               #TERMINATE ALL ACTIVE LOOPS# 
               FOR $DUMMY$ = 0 WHILE ILX GR 0 
                    DO  LOOPEPILOGUE; 
NEXTRECFIELD: 
               END #END OF THE RECEIVING FIELD LOOP#
          END #INITPROC#
         CONTROL EJECT; 
         # ----- SET 6 MAIN LINE BEGINS HERE ----- #
  
         GOTO SUB[SUB$];
SUB48:  
#INTEGER DATA ITEM ROUTINE# 
          #VERIFY THAT IDENTIFIER IS AN INTEGER DATA ITEM#
          #REGISTER USAGE#
               #REG1 : DNAT INDEX OF IDENTIFIER#
               #REG2 : DNAT TYPE OF IDENTIFIER# 
          REG1 = TABLENAME; 
          REG2 = GET(DN$TYPE,DNAT$,REG1); 
          IF REG2 NQ ERRTYPE
          THEN BEGIN
               IF(REG2 NQ NUMERIC     AND 
                 REG2 NQ COMP4 AND
                  REG2 NQ BINARY)     OR
                  GET(DN$POINT,DNAT$,REG1)  GR 0
               THEN BEGIN 
                    TRUEFALSE = 0;
                    ERROR(SEVERE,263,TABLELINE,TABLECOLUMN);
                    END 
               ELSE TRUEFALSE = 1;
               END
          RETURN; 
SUB5: 
#CD NAME ROUTINE# 
          #CHECK IF REF IS A CD-NAME# 
          IF GET(DN$LEVEL,DNAT$,VALUE$) EQ CDDESCR
          THEN TRUEFALSE = 1; 
          ELSE TRUEFALSE = 0; 
          RETURN; 
SUB38:  
#CD NAME CHECK INPUT# 
          IF GET(DN$CDINP,DNAT$,VALUE$) NQ 1
          THEN  ERROR(SEVERE,252,LINE$,COLUMN$);
          RETURN; 
SUB45:  
#CD NAME CHECK OUTPUT#
          IF GET(DN$CDOUT,DNAT$,VALUE$) NQ 1
          THEN  ERROR(SEVERE,253,LINE$,COLUMN$);
          RETURN; 
SUB18:  
#PURGE ROUTINE# 
          VD; 
          S = S + 1;
          XSTACK(S,$PURGE); 
          RETURN; 
SUB44:  
#SEND ROUTINE#
          #AFTER PARSING, STACK IS AS FOLLOWS:# 
               #1  CD-NAME# 
               #2  IDENTIFIER-1/NULL# 
               #3  ESI/EMI/EGI/IDENTIFIER-2#
               #4  BEFORE/AFTER#
               #5  ID-3/MNEMONIC/LIT/PAGE#
          VD; 
          #INITIALIZE STACK FOR NO WITH CLAUSE# 
          XSTACK(0,0);
          RETURN; 
SUB47:  
#SEND WITH# 
          #SET FLAG FOR WITH CLAUSE#
          XSTACK(0,1);
          RETURN; 
SUB50:  
#SEND ESI#
          S = S + 1;
          XSTACK(S,$ESI); 
          RETURN; 
SUB51:  
#SEND EMI#
          S = S + 1;
          XSTACK(S,$EMI); 
          RETURN; 
SUB52:  
#SEND EGI#
          S = S + 1;
          XSTACK(S,$EGI); 
          RETURN; 
SUB54:  
#SEND BEFORE# 
          S = S + 1;
          XSTACK(S,$BEFORE);
          RETURN; 
SUB55:  
#SEND AFTER#
          S = S + 1;
          XSTACK(S,$AFTER); 
          RETURN; 
SUB56:  
#SEND PAGE# 
          S = S + 1;
          XSTACK(S,$PAGE);
          RETURN; 
SUB53:  
#SEND FORMAT1#
          #THIS ROUTINE IS CALLED IF NO EGI,EMI,ESI OR ID-2#
          IF STACK(0) EQ 1 OR STACK(2) EQ $NULL 
          THEN
               #ERROR SINCE WE HAD A "WITH" WITHOUT EGI, ETC.#
               #OR NO "FROM" AND NOTHING GOOD FOLLOWING.# 
               #ERROR MESSAGE GENERATED IN TABLES.# 
               TRUEFALSE = 0; 
          ELSE
               #VALID FORMAT1 SEND STATEMENT# 
               TRUEFALSE = 1; 
          RETURN; 
SUB57:  
#INTEGER LITERAL ROUTINE# 
          #THIS LITERAL MUST BE AN UNSIGNED INTEGER#
          PLTPTR = LATTEMP; 
          IF GET(PL$TYPE,PLT$,PLTPTR) NQ PLTUNSGNILIT AND 
             GET(PL$CODE,PLT$,PLTPTR) NQ PLTFGCONZERO 
          THEN  ERROR(SEVERE,269,LINE$,COLUMN$);
          ELSE BEGIN
               #SET UP CGL DNAT ENTRY#
               REG1 = DNATLENGTH; 
               SET(DN$ITMLEN,DNAT$,REG1,10);
               SET(DN$NUMLEN,DNAT$,REG1,5); 
               SET(DN$POINT,DNAT$,REG1,0);
               SET(DN$TYPE,DNAT$,REG1,BINARY);
               END
          RETURN; 
SUB49:  
#SEND MSG INDICATOR#
          #MESSAGE INDICATOR MUST BE 1 CHAR. UNSIGNED INTEGER#
          REG1 = TABLENAME; 
          IF GET(DN$SIGNBIT,DNAT$,REG1) NQ 0
          THEN  ERROR(SEVERE,268,TABLELINE,TABLECOLUMN);
          RETURN; 
SUB59:  
#SEND EPILOGUE# 
          NG($SEND);
          #OUTPUT GTEXT USING NULL IF NO STACK ELEMENT# 
          FOR REG1 = 1 STEP 1 UNTIL 5 
          DO BEGIN
               IF REG1 GR S 
               THEN NG($NULL);
               ELSE NGSTACK(REG1);
               END
          RETURN; 
SUB37:  
#RECEIVE ROUTINE# 
          #AFTER PARSING,THE STACK IS AS FOLLOWS:#
               #1 RECEIVE#
               #2 NULL# 
               #3 CD-NAME#
               #4 MESSAGE/SEGMENT#
               #5 RECEIVING IDENTIFIER# 
          VD; 
          S = S + 1;
          XSTACK(S,$RECEIVE); 
          #ENTER NULL FOR ABSENCE OF NO DATA PHRASE INTO STACK# 
          S = S + 1;
          XSTACK(S,$NULL);
          RETURN; 
SUB39:  
#RECEIVE MESSAGE# 
          S = S + 1;
          XSTACK(S,$MESSAGE); 
          RETURN; 
SUB40:  
#RECEIVE SEGMENT# 
          S = S + 1;
          XSTACK(S,$SEGMENT); 
          RETURN; 
SUB41:  
#NO DATA PROLOGUE1# 
          #CHANGE GTEXT SINCE THE NO DATA PHRASE IS PRESENT#
         IF ENDADDRESS EQ 0 
         THEN BEGIN 
              ENDADDRESS = NEXTPNAT;
              END 
         G = G - 2; 
         NGLABELREF(ENDADDRESS,0);
         NSFLAG = 1;
         G = G + 1; 
          RETURN; 
SUB9: 
#ENABLE ROUTINE#
          VD; 
          XSTACK(1,$ENABLE);
          S = 3;
          RETURN; 
SUB1: 
#DISABLE ROUTINE# 
          #AFTER PARSING,THE STACK IS AS FOLLOWS:#
             #1 ENABLE/DISABLE# 
             #2 INPUT/OUTPUT# 
             #3 TERMINAL/NULL#
             #4 CD-NAME IDENTIFIER# 
             #5 KEY (LIT OR IDENTIFIER)#
          VD; 
          XSTACK(1,$DISABLE); 
          S = 3;
          RETURN; 
SUB2: 
#DISABLE ENABLE OUTPUT# 
          XSTACK(2,$OUTPUT);
          XSTACK(3,$NULL);
          RETURN; 
SUB3: 
#DISABLE ENABLE INPUT#
          XSTACK(2,$INPUT); 
          XSTACK(3,$NULL);
          RETURN; 
SUB4: 
#DISABLE ENABLE TERMINAL# 
          #REVISE STACK FOR TERMINAL# 
          XSTACK(3,$TERMINAL);
          RETURN; 
SUB6: 
#DISABLE ENABLE OPERAND#
          #CHECK INPUT-OUTPUT CONFLICTS#
          IF STACK(2) EQ $INPUT 
          THEN GOTO SUB38;
          ELSE GOTO SUB45;
SUB7: 
#DISABLE ENABLE IDENTIFIER# 
          FIX1 = NONNUMID(4); 
          RETURN; 
SUB8: 
#DISABLE ENABLE LITERAL#
          FIX1 = NONNUMLIT; 
          #MAY HAVE TO FIX UP LITERAL VIA L-POOLER FOR MCS USE# 
          RETURN; 
SUB19:  
#INSPECT ROUTINE# 
          VD; 
          #INITIALIZE STACK FOR TALLYING# 
          XSTACK(0,$TALLY); 
          #INITIALIZE COUNTER FOR NUMBER OF TALLYING CLAUSES# 
          ITALLYCOUNT = 0;
          #INITIALIZE COUNTER FOR NUMBER OF REPLACING CLAUSES#
          IREPCOUNT = 0;
          #WHILE PARSING,THE STACK HAS THE FOLLOWING APPEARANCE#
          #0  TALLY VERB ATOM             REPLACE VERB ATOM#
          #1  INSPECTEE                   INSPECTEE#
          #2  TALLYEE#
          #3  CHAR/ALL/LEADING            CHAR/ALL/LEADING/FIRST# 
          #4  NULL/DATA-REF/LIT-REF       REPLACEE# 
          #                                (NULL/DATA-REF/LIT-REF)# 
          #5  BEFORE/AFTER/NULL           REPLACER(DATA-REF/LIT-REF)# 
          #6  NULL/DATA-REF/LIT-REF       BEFORE/AFTER/NULL#
          #7                              NULL/DATA-REF/LIT-REF#
          RETURN; 
SUB28:  
#INSPECT ALL# 
          S = 3;
          XSTACK(S,$ALL); 
          RETURN; 
SUB29:  
#INSPECT LEADING# 
          S = 3;
          XSTACK(S,$LEADING); 
          RETURN; 
SUB30:  
#INSPECT FIRST# 
          S = 3;
          XSTACK(S,$FIRST); 
          RETURN; 
SUB25:  
#INSPECT CHARACTERS#
          S = 4;
          XSTACK(3,$CHARACTERS);
          XSTACK(S,$NULL);
          #INITIALIZE SAVE SIZE FOR CHARACTERS# 
          IOPERANDSIZE = 1; 
          RETURN; 
SUB32:  
#INSPECT BEFORE#
          S = S + 1;
          XSTACK(S,$BEFORE);
          RETURN; 
SUB33:  
#INSPECT AFTER# 
          S = S + 1;
          XSTACK(S,$AFTER); 
          RETURN; 
SUB36:  
#INSPECT SPECIAL BEFORE AFTER#
          #ERASE STACK ATOM FOR BEFORE OR AFTER#
          S = S - 1;
          #FALL THROUGH#
SUB34:  
#INSPECT NO BEFORE OR AFTER#
          S = S + 1;
          XSTACK(S,$NULL);
          S = S + 1;
          XSTACK(S,$NULL);
          RETURN; 
SUB31:  
#INSPECT TALLY EPILOGUE#
          #BUMP NO. OF TALLYINGS COUNTER# 
          ITALLYCOUNT = ITALLYCOUNT + 1;
          #USE BLDGTXT COMMAND IN TABLES TO#
          #RESET STACK POINTER TO 1 AND TO# 
          #OUTPUT GOOD GTEXT IN THE ORDER#
               #TALLY ATOM# 
               #TALLYEE ATOM# 
               #SEARCH SPECIFICATION# 
               #SEARCHEE ATOM#
               #BEFORE-AFTER SUBVERB# 
               #BEFORE-AFTER REF# 
          #THAT IS STACK ATOMS 0 AND 2-6# 
          RETURN; 
SUB35:  
#INSPECT CHECK IF TALLYING# 
          IF STACK(0) EQ $TALLY 
          THEN TRUEFALSE = 1; 
          ELSE TRUEFALSE = 0; 
          RETURN; 
SUB22:  
#INSPECT REPLACE PROLOGUE#
          #INITIALIZE STACK FOR REPLACE VERB# 
          XSTACK(0,$REPLACE); 
          #GENERATE NEW HEADER PACKET IF HAD TALLYING PACKETS#
          #OTHERWISE REPLACING GTEXT STARTS AT TALLYING START#
          #WE CANT PATCH TALLYING HEADER PACKET YET BECAUSE#
          #THIS SUBROUTINE MAY NOT BE EXECUTED IF NO REPLACING# 
          IF ITALLYCOUNT NQ 0 
          THEN BEGIN
               #SET POINTER TO START OF REPLACING GTEXT#
               IPOINTER1 = G; 
               NG($INSPECT);
               NG(STACK(1));
               #LEAVE ROOM FOR COUNT ATOMS# 
               G = G + 2; 
               #IF INSPECTEE WAS SUBSCRIPTED BUMP ITS REFERENCE COUNT#
               #BECAUSE OF ADDITIONAL REFERENCE IN NEW HEADER PACKET# 
               IF RECREFINDX NQ 0 
               THEN BEGIN 
                    REG1 = GET(RCT$ENTRY,RCT$,RECREFINDX) + 1;
                    SET(RCT$ENTRY,RCT$,RECREFINDX,REG1);
                    END 
               END
          ELSE IPOINTER1 = IPOINTER0; 
          RETURN; 
SUB27:  
#INSPECT REPLACE EPILOGUE#
          #BUMP NO. OF REPLACEMENTS COUNTER#
          IREPCOUNT = IREPCOUNT + 1;
          #USE BLDGTXT COMMAND IN TABLES TO#
          #RESET STACK POINTER TO 3 AND TO# 
          #OUTPUT GOOD GTEXT IN THE ORDER#
               #REPLACE VERB# 
               #SEARCH SPECIFICATION# 
               #REPLACEE ATOM#
               #REPLACER ATOM#
               #BEFORE-AFTER SUBVERB# 
               #BEFORE-AFTER REF# 
          #THAT IS STACK ATOMS 0 AND 3-7# 
          RETURN; 
SUB24:  
#INSPECT TALLYEE# 
          #CHECK VALIDITY OF TALLYEE# 
          OPERANDTEST(S); 
          RETURN; 
SUB20:  
#INSPECT INSPECTEE# 
          #CHECK VALIDITY OF IDENTIFIER#
          FIX1 = NONNUMID(1); 
          #SAVE REFERENCE COUNT TABLE INDEX FOR INSPECTEE IN CASE#
          #WE GENERATE AN ADDITIONAL HEADER PACKET FOR REPLACING# 
          RECREFINDX = REFCOUNTINDX;
          #SET POINTER FOR START OF TALLYING GTEXT# 
          #AFTER INSPECTEE SUBSCRIPTS (IF ANY)# 
          IPOINTER0 = G;
          #OUTPUT HEADER GTEXT# 
          NG($INSPECT); 
          NGSTACK(1); 
          #LEAVE ROOM FOR TALLY AND REPLACE COUNTS# 
          G = G + 2;
          RETURN; 
SUB26:  
#INSPECT OPERAND# 
          #REGISTER USAGE#
               #REG1 : GDATAREF OR GLITREF# 
               #REG2 : LENGTH OF OPERAND : 0 IF BAD#
               #REG3 : DNAT INDEX OF CGL ENTRY# 
               #REG4 : LAT INDEX OF LITERAL#
          #ACCESS APPROPRIATE ATOM FIELDS#
          REG1 = TCODE(S);
          #CHECK ATTRIBUTES AND OBTAIN OPERAND LENGTH IF VALID# 
          IF REG1 EQ GLITREF
          THEN BEGIN
               SET(L$VCODE,LAT$,LATLENGTH,3); 
               IF NONNUMLIT EQ 1
               THEN BEGIN 
                    REG2 = GET(PL$LENGTH,PLT$,LATTEMP); 
                    IF CCTFIPSLEVEL LS 3 AND REG2 NQ 1
                    THEN BEGIN
                         #FIPS=3 SUPPORTS INSPECT STATEMENT LITERALS# 
                         #GREATER THAN ONE CHARACTER IN LENGTH# 
                         ERROR(TRIVIAL,814,LINE$,COLUMN$);
                         END
                    END 
               ELSE REG2 = 0; 
               END
          ELSE BEGIN
               IF NONNUMID (1) EQ 1 
                THEN REG2 = GET(DN$ITMLEN,DNAT$,TABLENAME); 
                ELSE REG2 = 0;
                IF GET(DN$LEVEL,DNAT$,TABLENAME) EQ REFMODLEVEL 
                THEN BEGIN
                     # SKIP LENGTH TESTS ON REFERENCE MODIFIED ITEMS #
                     REG2 = 0;
                     END
                END 
          #COMPARISON OF OPERAND SIZES DEPENDS ON STACK LOCATION# 
          #AND WILL ONLY OCCUR FOR REPLACING OPTION#
          #S=4        REPLACEE                  ID-5,LIT-3# 
          #S=5        REPLACER                  ID-6,LIT-4# 
          #S=7        BEF/AFT OPERAND           ID-7,LIT-5# 
  
         GOTO SCASE[S - 4]; 
SCASE0: 
               BEGIN
               #REPLACEE - SAVE SIZE FOR FUTURE#
               IOPERANDSIZE = REG2; 
               RETURN;
               END
SCASE1: 
               BEGIN
               #REPLACER : COMPARE SIZES FOR EQUALITY#
               #NO COMPARE IF EITHER ERRONEOUS# 
               IF REG2 NQ 0 AND IOPERANDSIZE NQ 0 
               THEN BEGIN 
                    #CHECK FOR FIGURATIVE CONSTANT - SPECIAL# 
                   IF REG1 EQ GLITREF AND 
                    GET(PL$FIGCON,PLT$,LATTEMP) NQ 0
                    THEN BEGIN
                         #CHANGE ITEM LENGTH IN CGL DNAT ENTRY# 
                         REG3 = DNATLENGTH; 
                         SET(DN$ITMLEN,DNAT$,REG3,IOPERANDSIZE);
                         #TURN ON ALL INDICATOR#
                         REG4 = LATLENGTH;
                         SET(L$ALL,LAT$,REG4,1);
                         END
                    ELSE #CHECK FOR EQUALITY WITH PREVIOUS OPERAND# 
                         IF REG2 NQ IOPERANDSIZE
                         THEN  ERROR(SEVERE,175,LINE(S),COLUMN(S)); 
                    END 
               RETURN;
               END
SCASE2: 
               #NO ACTION - BEF/AFT OPERAND FOR TALLYING# 
               RETURN;
SCASE3: 
               BEGIN
               #BEF/AFT OPERAND FOR REPLACING#
               #CHECK 1 CHAR OPERAND FOR CHARACTERS OPTION# 
               IF STACK(3) EQ $CHARACTERS AND REG2 GR 1 
               THEN  ERROR(TRIVIAL,176,LINE(S),COLUMN(S));
               END #END OF CASE STATEMENT#
          RETURN; 
SUB23:  
#INSPECT EPILOGUE#
          #REGISTER USAGE#
               #REG1 : LENGTH OF TALLYING GTEXT#
               #REG2 : LENGTH OF REPLACING GTEXT# 
               #REG3 : INDEX OF LAST MOVED REPLACING GTEXT# 
               #REG4 : SCRATCH INDEX# 
          #FIX UP NUMBER OF TALLYING CLAUSES# 
          IF ITALLYCOUNT NQ 0 
          THEN BEGIN
               SETGT(IPOINTER0+3,GTX(GSUBVERB,ITALLYCOUNT,GCOUNT)); 
               SETGT(IPOINTER0+4,GTX(GSUBVERB,0,GCOUNT)); 
               END
          #FIX UP NUMBER OF REPLACING CLAUSES#
          IF IREPCOUNT NQ 0 
          THEN BEGIN
               SETGT(IPOINTER1+3,GTX(GSUBVERB,0,GCOUNT)); 
               SETGT(IPOINTER1+4,GTX(GSUBVERB,IREPCOUNT,GCOUNT)); 
               END
          #RE-ARRANGE THE GTEXT IF REPLACING DONE FIRST#
          IF INSPECTFLAG EQ 1 
          THEN BEGIN
               #CALCULATE TEXT PORTION LENGTHS# 
               REG1 = IPOINTER1 - IPOINTER0;
               REG2 = G - IPOINTER1;
               REG3 = IPOINTER0 + REG2; 
               #MOVE TALLYING GTEXT TO SCRATCH AREA#
               FOR REG4 = 1 STEP 1 UNTIL REG1 
                   DO  SETGT(G + REG4,GETGT(IPOINTER0 + REG4)); 
               #MOVE REPLACING GTEXT TO TALLY GTEXT AREA# 
               FOR REG4 = 1 STEP 1 UNTIL REG2 
                   DO SETGT(IPOINTER0 + REG4,GETGT(IPOINTER1 + REG4));
               #MOVE TALLYING GTEXT FOLLOWING REPLACING GTEXT#
               FOR REG4 = 1 STEP 1 UNTIL REG1 
                   DO SETGT(REG3 + REG4,GETGT(G + REG4)); 
               END
          RETURN; 
SUB60:  
#STRING ROUTINE#
          VD; 
          #SET UP VERB IDENTIFICATION IN STACK# 
          XSTACK(0,$STRING);
          #INITIALIZE COUNT OF NUMBER OF DELIMITED CLAUSES# 
          SCLAUSECOUNT = 0; 
          # REFERENCE MODIFICATION HAS NOT BEEN ENCOUNTERED (YET) # 
          RMPRESENT = 0;
          RETURN; 
SUB65:  
#STRING SIZE# 
          #NO DELIMITER SPECIFIED#
          S = S + 1;
          S$ = S$ + 1;
          XSTACK(S,$SIZE);
          #FALL THROUGH#
SUB84:  
#STRING DELIMITED#
          #INCREMENT CLAUSE COUNTER#
          SCLAUSECOUNT = SCLAUSECOUNT + 1;
          #SAVE S$ OF CURRENT DELIMITER#
          XCOMMONSTACK(SCLAUSECOUNT,S$);
          # SPECIAL FLAG FOR DELIMITER OTHER THAN SIZE #
          RMPRESENT = 1;
          RETURN; 
SUB64:  
#STRING OPERAND#
          IF TCODE(S) EQ GLITREF
          THEN BEGIN
               SET(L$VCODE,LAT$,LATLENGTH,3); 
               FIX1 = NONNUMLIT;
               END
          ELSE BEGIN
               FIX1 = NONNUMID(1);
               IF GET(DN$TYPE,DNAT$,TABLENAME) EQ VARGROUP
               THEN BEGIN 
                    # SPECIAL FLAG FOR VAR GROUP STRING OPERANDS #
                    RMPRESENT = 1;
                    END 
               END
          RETURN; 
SUB61:  
#STRING IDENTIFIER# 
          IF GET(DN$LEVEL,DNAT$,TABLENAME) EQ REFMODLEVEL THEN
          ERROR(TRIVIAL,479,TABLELINE,TABLECOLUMN); 
          #CHECK FOR GROUP OR VARIABLE GROUP ELSE NON EDIT DISPLAY# 
          REG1 = GET(DN$TYPE,DNAT$,TABLENAME);
          IF (REG1 EQ GROUP) OR (REG1 EQ VARGROUP) OR 
            (GET(DN$JUST,DNAT$,TABLENAME) EQ 1) 
             THEN ERROR(JOD,273,TABLELINE,TABLECOLUMN); 
             ELSE FIX1 = NONNUMID(3); 
          RETURN; 
SUB62:  
#STRING UNSTRING POINTER# 
          #CHECK IF POINTER IS LARGE ENOUGH#
          #REGISTER USAGE#
               #REG1 : DNAT INDEX OF POINTER# 
               #REG2 : STACK INDEX OF POINTED AT ITEM#
               #REG3 : DNAT INDEX OF POINTED AT FIELD#
               #REG4 : NECESSARY DIGIT LENGTH OF POINTER# 
          REG1 = TABLENAME; 
          #DETERMINE STACK LOCATION OF APPLICABLE DATA ITEM#
          IF STACK(0) EQ $STRING
          THEN BEGIN
               REG2 = S - 1; #STRING# 
               FIX1 = SEVERE; 
               END
          ELSE BEGIN
               REG2 = 1;     #UNSTRING# 
               FIX1 = ADVISORY; 
               END
          REG3 = TPOINTER(REG2);
          IF GET(DN$TYPE,DNAT$,REG3) NQ ERRTYPE 
          THEN BEGIN
               REG4 = GET(DN$ITMLEN,DNAT$,REG3);
              #WE WANT TO SEE IF THE POINTER DATA ITEM# 
              #IS BIG ENOUGH TO CONTAIN THE MAXIMUM VALUE#
              #IT MIGHT BE REQUIRED TO CONTAIN# 
              REG5 = GET(DN$NUMLEN,DNAT$,REG1); 
              REG6 = 1; 
              FOR REG7 = 1
              STEP 1
              UNTIL REG5
              DO REG6 = REG6 * 10;
              IF REG6 LQ REG4 
               THEN  ERROR(FIX1,264,TABLELINE,TABLECOLUMN); 
               END
          RETURN; 
SUB63:  
#STRING EPILOGUE# 
          #REGISTER USAGE#
               #REG1 : STACK S$ COUNTER#
               #REG2 : INDEX THRU DELIMITED CLAUSES#
               #REG3 : S$ FOR CURRENT DELIMITER#
               #REG4 : S FOR CURRENT DELIMITER# 
               #REG5 : S FOR CURRENT OPERAND# 
          #OUTPUT GLOBAL VERB ATOM# 
          NGSTACK(0); 
          #OUTPUT RECEIVING FIELD ATOM# 
          NGSTACK(S-1); 
          #OUTPUT POINTER - MAY BE NULL#
          NGSTACK(S); 
          #CALCULATE NUMBER OF SENDING FIELDS#
         FIX1 = COMMONSTACK(SCLAUSECOUNT) - SCLAUSECOUNT; 
          #GENERATE COUNT SUBVERB FOR SENDING FIELDS# 
          NGGTX(GSUBVERB,FIX1,RMPRESENT); 
          #GENERATE OVERFLOW REFERENCE AND SAVE LABEL#
          NGLABELREF((NEXTPNAT),0); 
          OVERFLOWLBL = PNATLENGTH; 
          #NOW LOOP THRU DELIMITED CLAUSES# 
          REG1 = 1; 
          #GENERATE GTEXT FOR EACH DELIMITED GROUP# 
          FOR REG2 = 1 STEP 1 UNTIL SCLAUSECOUNT DO BEGIN 
               #ACCESS S$ FOR CURRENT DELIMITER#
               REG3 = COMMONSTACK(REG2);
               #OUTPUT SUBSCRIPTS FOR DELIMITER#
               REG4 = RETRIEVE(REG3); 
               #OUTPUT DELIMITED VERB#
               NG($SDELIMITED); 
               #OUTPUT DELIMITER ITSELF#
               NGSTACK(REG4); 
               #LOOP THRU OPERANDS OF CURRENT CLAUSE# 
               FOR REG1 = REG1 STEP 1 UNTIL REG3 - 1
               DO BEGIN 
                    #OUTPUT OPERAND SUBSCRIPTS# 
                    REG5 = RETRIEVE(REG1);
                    #OUTPUT OPERATOR VERB#
                    NG($SOPERATOR); 
                    #OUTPUT CURRENT OPERAND ATOM# 
                    NGSTACK(REG5);
                    END 
               #SKIP STACK S$ COUNT PAST DELIMITER - NOW AT DELIMITER#
               REG1 = REG1 + 1; 
               #SUBSCRIPTS FOR DELIMITER BECOME INACTIVE HERE#
               END
          RETURN; 
SUB77:  
#NO ON OVERFLOW#
          #OVERFLOW BRANCH IS NEXT STATEMENT - NO OVERFLOW VERB#
          #GENERATE OVERFLOW LABEL ITSELF#
          NGLABELDEF(OVERFLOWLBL);
          RETURN; 
SUB78:  
#ON OVERFLOW GO TO# 
          #OVERFLOW LABEL IS PN - OVERFLOW VERB IS TRUE BRANCH TO PN# 
          SET(PN$EQUATE,PNAT$,OVERFLOWLBL,PN);
          #GENERATE OVERFLOW VERB#
          NG($OVERFLOW);
          NGPROCREF(PN,GTRUE);
          #GENERATE OVERFLOW SUBVERB BASED ON SOURCE STATEMENT# 
         IF STACK(0) EQ $STRING 
                  THEN TEMPATOM = $STROVRFLW; 
         ELSE IF STACK(0) EQ $UNSTRING
                  THEN TEMPATOM = $UNSTROVRFLW; 
                  ELSE TEMPATOM = $NULL;
          NG(TEMPATOM); 
          RETURN; 
SUB79:  
#ON OVERFLOW PROLOGUE#
          #OVERFLOW LABEL GENERATED - VERB FALSE TO NEXT SENTENCE#
          #SET UP NEXT SENTENCE LABEL GENERATION# 
          IF ENDADDRESS EQ 0
          THEN BEGIN
               ENDADDRESS = NEXTPNAT; 
               END
          #GENERATE OVERFLOW VERB#
          NG($OVERFLOW);
          NSFLAG = 1; 
          NGLABELREF(ENDADDRESS,GFALSE);
          #GENERATE OVERFLOW SUBVERB BASED ON SOURCE STATEMENT# 
         IF STACK(0) EQ $STRING 
                  THEN TEMPATOM = $STROVRFLW; 
         ELSE IF STACK(0) EQ $UNSTRING
                  THEN TEMPATOM = $UNSTROVRFLW; 
                  ELSE TEMPATOM = $NULL;
          NG(TEMPATOM); 
          #GENERATE LABEL FOR IMPERATIVE STATEMENT# 
          NGLABELDEF(OVERFLOWLBL);
          RETURN; 
SUB66:  
#UNSTRING ROUTINE#
          VD; 
          #SET UP VERB IDENTIFICATION IN STACK# 
          XSTACK(0,$UNSTRING);
          #INITIALIZE VALUE OF S$ OF LAST DELIMITER#
          ULASTDELIMIT = 1; 
          # REFERENCE MODIFICATION HAS NOT BEEN ENCOUNTERED (YET) # 
          RMPRESENT = 0;
          RETURN; 
SUB68:  
#UNSTRING DELIMITED#
          S = S + 1;
          S$ = S$ + 1;
          XSTACK(S,$NULL);
          #UPDATE VALUE OF S$ FOR LAST DELIMITER - NEXT IN STACK# 
          ULASTDELIMIT = S$ + 1;
          RETURN; 
SUB69:  
#UNSTRING ALL#
          #OVERWRITE PREVIOUSLY GENERATED NULL ATOM#
          XSTACK(S,$ALL); 
          RETURN; 
SUB72:  
#UNSTRING CHECK IF DELIMITED# 
          #RETURN TRUE IF DELIMITED BY PHRASE PRESENT#
          IF ULASTDELIMIT NQ 1
          THEN TRUEFALSE = 1; 
          ELSE TRUEFALSE = 0; 
          RETURN; 
SUB67:  
#UNSTRING OPERAND#
          IF RMPRESENT EQ 1 THEN
         ERROR(TRIVIAL,479,TABLELINE,TABLECOLUMN);
          FIX1 = NONNUMID(4); 
          RETURN; 
SUB80:  
#UNSTRING LITERAL#
          SET(L$VCODE,LAT$,LATLENGTH,3);
          FIX1 = NONNUMLIT; 
          RETURN; 
SUB71:  
#UNSTRING RECEIVING FIELD#
          FIX1 = NONNUMID(3); 
          #CHECK FOR SCALING IN NUMERIC IDENTIFIER# 
          REG1 = TABLENAME; 
          IF GET(DN$TYPE,DNAT$,REG1) EQ NUMERIC 
          THEN BEGIN
               REG2 = GET(DN$POINT,DNAT$,REG1); 
               REG3 = GET(DN$NUMLEN,DNAT$,REG1);
               #CHECK FOR PIC 99PPP OR PIC PPP99 FOR EXAMPLE# 
               #NEGATIVE PT. LOC. OR PT. LOC. > NUMERIC LENGTH# 
               IF REG2 LS 0 OR REG2 GR REG3 
               THEN  ERROR(TRIVIAL,255,TABLELINE,TABLECOLUMN);
               END
          RETURN; 
SUB70:  
#UNSTRING EPILOGUE# 
          #REGISTER USAGE#
               #REG1 : STACK S$ COUNTER#
               #REG2 : S FOR CURRENT DELIMITER,RECEIVING FIELD# 
               #REG3 : S FOR CURRENT RECEIVING FIELD FOR DELIMITER# 
               #REG4 : S FOR CURRENT COUNT FIELD# 
               #REG5 : SCRATCH ARGUMENT REGISTER# 
          #OUTPUT GLOBAL VERB ATOM# 
          NGSTACK(0); 
          #OUTPUT SENDING FIELD REFERENCE#
          NGSTACK(1); 
          #OUTPUT POINTER REFERENCE#
          NGSTACK(S - 1); 
          #OUTPUT TALLYING REFERENCE# 
          NGSTACK(S); 
          #CALCULATE NUMBER OF RECEIVING FIELDS#
          FIX1 = (S$ - 2 - ULASTDELIMIT)/3; 
          #GENERATE COUNT SUBVERB FOR RECEIVING FIELDS# 
          NGGTX(GSUBVERB,FIX1,RMPRESENT); 
          #GENERATE OVERFLOW LABEL REFERENCE AND SAVE LOCATION# 
          NGLABELREF((NEXTPNAT),0); 
          OVERFLOWLBL = PNATLENGTH; 
          #CHECK IF ANY DELIMITERS ARE PRESENT# 
          IF ULASTDELIMIT EQ 1
          THEN #REFERENCE TO DELIMITER SCAN IS UNNECESSARY# 
              TEMPATOM = GTX(GSUBVERB,0,0); 
          ELSE BEGIN
              TEMPATOM = GTX(GSUBVERB,1,0); 
               #GENERATE REFERENCE TO THIS LABEL# 
               TEMPATOM = GTX(GLABELREF,PNATLENGTH,0);
               #LOOP THRU DELIMITER PORTION OF STACK# 
               FOR REG1 = 3 STEP 2 UNTIL ULASTDELIMIT 
               DO BEGIN 
                    #OUTPUT SUBSCRIPTS FOR DELIMITER IF ANY#
                    REG2 = RETRIEVE(REG1);
                    #OUTPUT VERB# 
                    NG($DELIMITEDBY); 
                    #OUTPUT DELIMITER MODIFIER# 
                    NGSTACK(REG2 - 1);
                    #OUTPUT DELIMITER ITSELF# 
                    NGSTACK(REG2);
                    END 
               END
          #LOOP THRU RECEIVING FIELD PORTION OF STACK#
          FOR REG1 = ULASTDELIMIT + 1 STEP 3 UNTIL S$ - 4 
          DO BEGIN
               #OUTPUT SUBSCRIPTS FOR RECEIVING FIELD#
               REG2 = RETRIEVE(REG1); 
               #OUTPUT SUBSCRIPTS FOR DELIMITER RECEIVING FIELD#
               REG5 = REG1 + 1; 
               REG3 = RETRIEVE(REG5); 
               #OUTPUT SUBSCRIPTS FOR COUNT FIELD#
               REG5 = REG1 + 2; 
               REG4 = RETRIEVE(REG5); 
               #OUTPUT VERB FOR THIS CLAUSE#
               NG($INTO); 
               #OUTPUT RECEIVING FIELD REFERENCE# 
               NGSTACK(REG2); 
               #OUTPUT DELIMITER RECEIVING FIELD REFERENCE# 
               NGSTACK(REG3); 
               #OUTPUT COUNT FIELD REFERENCE# 
               NGSTACK(REG4); 
               NG(TEMPATOM);
               END
          RETURN; 
SUB74:  
#STOP LITERAL#
          #CHECK LEGALITY OF LITERAL# 
          REG1 = GET(PL$CODE,PLT$,LATTEMP); 
          REG2 = GET(PL$SIGNEDFLG,PLT$,LATTEMP);
          #CHECK FOR NONNUMERIC OR AN UNSIGNED INTEGER# 
          IF REG1 NQ PLTQUOTEDLIT AND 
             REG1 NQ PLTFGCONZERO AND 
            (REG1 NQ PLTINTLIT OR REG2 NQ 0)
             THEN ERROR(JOD,278,LINE$,COLUMN$); 
          #CONSTRUCT CGL DNAT ENTRY#
          C<00,13>STOPBUFFER = "PAUSE        "; 
          REG3 = 12;
          IF GET(PL$TYPE,PLT$,LATTEMP) EQ PLTPLUSILIT 
          THEN BEGIN
               C<13>STOPBUFFER = "+"; 
               REG3 = 13; 
               END
          IF GET(PL$TYPE,PLT$,LATTEMP) EQ PLTMINUSILIT
          THEN BEGIN
               C<13>STOPBUFFER = "-"; 
               REG3 = 13; 
               END
          REG4 = GET(PL$LENGTH,PLT$,LATTEMP); 
          IF REG4 GR 60 - REG3
          THEN BEGIN
               REG4 = 60 - REG3;
               END
          FOR REG1 = 1
          STEP 1
          UNTIL REG4
          DO BEGIN
             FIX1 = REG3 + REG1;
             C<FIX1>STOPBUFFER = PLTCHARACTER(LATTEMP,REG1);
             END
          FIX1 = FIX1 + 1;
          SET(PL$LENGTH,PLT$,LATTEMP,FIX1); 
          SET(PL$TYPE,PLT$,LATTEMP,PLTQUOTEDLIT); 
          SETPLST(LATTEMP,LOC(STOPBUFFER)); 
          SET(DN$TYPE,DNAT$,DNATLENGTH,GROUP);
          SET(DN$ITMLEN,DNAT$,DNATLENGTH,FIX1); 
          RETURN; 
SUB10:  
#INITIALIZE ROUTINE#
          VD; 
          #LSW = 0   MEANS SENDING FIELD IS A DATA ITEM#
          #LSW = 1   MEANS SENDING FIELD IS A LITERAL#
          #          (INCLUDING SPACE AND ZERO)#
          LSW = 1;
          INCOMPATIBLE = 0; 
          RETURN; 
SUB85:  
#INITIALIZE OPERAND ROUTINE#
          # ERROR IF INITIALIZE OF INVALID OPERAND #
          REG1 = GET(DN$TYPE,DNAT$,TABLENAME);
          IF REG1 EQ NONDATA THEN     # NON-DATA #
                  BEGIN 
                  FIX1 = 26;
                  ERROR(SEVERE,FIX1,LINE$,COLUMN$); 
                  END 
          #IF THE RECEIVING FIELD IS SUBSCRIPTED, REFCOUNTINDX# 
          #CONTAINS AN RCT ENTRY INDEX ... OTHERWISE, REFCOUNTINDX# 
          #CONTAINS ZERO ... IN EITHER CASE, WE WISH TO SAVE THIS#
          #VALUE IN PARALLEL WITH THE RECEIVING FIELD#
          B<30,15> REG1 = REFCOUNTINDX; 
          B<45, 15> REG1 = INITSNUMBER; 
          XCOMMONSTACK(S$,REG1);
          #IF THE RECEIVING FIELD IS SUBSCRIPTED, IDENTIFIER-2# 
          #HAS ALREADY COUNTED THE SUBSCRIPT CALCULATION EVEN#
          #THOUGH WE HAVE NOT USED IT YET ... WE MAY NOT USE IT AT# 
          #ALL ... WE MAY NEED IT MORE THAN ONCE ... WE MUST DECREMENT# 
          #THE VALUE IN THE RCT#
          IF REFCOUNTINDX NQ 0
          THEN BEGIN
               FIX1 = GET(RCT$ENTRY,RCT$,REFCOUNTINDX) - 1; 
               SET(RCT$ENTRY,RCT$,REFCOUNTINDX,FIX1); 
               END
          RETURN; 
SUB12:  
#INITIALIZE REPLACING NUMERIC#
          REPTYPE = NUMERIC;
          KEY2 = 6; 
          RETURN; 
SUB14:  
#INITIALIZE REPLACING ALPHABETIC# 
          REPTYPE = ALPHABET; 
          KEY2 = 2; 
          RETURN; 
SUB13:  
#INITIALIZE REPLACING ALPHANUM# 
          REPTYPE = ALPHNUM;
          KEY2 = 3; 
          RETURN; 
SUB15:  
#INITIALIZE REPLACING ALPHA EDIT# 
          REPTYPE = ALPHNUMED;
          KEY2 = 4; 
          RETURN; 
SUB16:  
#INITIALIZE REPLACING NUM EDIT# 
          REPTYPE = NUMERICEDIT;
          KEY2 = 4; 
          RETURN; 
SUB21:  
# INITIALIZE REPLACING BOOLEAN #
          REPTYPE = BOOLEAN;
          KEY2 = 7; 
          RETURN; 
SUB11:  
#INITIALIZE NO REPLACING# 
          #REPTYPE = 0 MEANS NO REPLACING#
          REPTYPE = 0;
          INITPROC; 
          RETURN; 
SUB17:  
#INITIALIZE REPLACING ROUTINE#
  
          #INITIALIZE ID-1   REPLACING ALPHABETIC            BY ID-3# 
          #INITIALIZE ID-1   REPLACING ALPHANUMERIC          BY ID-3# 
          #INITIALIZE ID-1   REPLACING NUMERIC               BY ID-3# 
          #INITIALIZE ID-1   REPLACING ALPHANUMERIC-EDITED   BY ID-3# 
          #INITIALIZE ID-1   REPLACING NUMERIC-EDITED        BY ID-3# 
  
          #SYNTAX RULE 2# 
  
          #THE CATEGORY OF THE DATA ITEM REFERRED TO BY ID-3 OR#
          #LITERAL MUST BE CONSISTENT WITH THE CATEGORY INDICATED#
          #BY THE PHRASE FOLLOWING THE WORD REPLACING AS DEFINED# 
          #IN THE MOVE STATEMENT# 
  
          #IN OTHER WORDS, IN THE FIRST INITIALIZE STATEMENT, ID-3# 
          #MUST BE SUCH THAT IT CAN BE MOVED TO AN ALPHABETIC DATA# 
          #ITEM#
  
          #THE MOVE STATEMENT USES XPP31 AND XPP32 TO COMPUTE TWO#
          #KEYS FROM WHICH IT CAN DETERMINE IF THE SENDING FIELD# 
          #IS CONSISTENT WITH THE RECEIVING FIELD ... WE HAVE#
          #ALREADY ESTABLISHED THE RECEIVING FIELD KEY (KEY2) ... # 
          #WE WILL USE XPP31 TO COMPUTE THE SENDING FIELD KEY#
  
          #ALTHOUGH NO LONGER OBVIOUS FROM ITS DECLARATION, MOVESTRING# 
          #IS A 14 BY 7 ARRAY OF BYTES CONTAINING ZEROS FOR CONSISTENT# 
          #MOVES AND AN APPROPRIATE ERROR MESSAGE FOR INCONSISTENT# 
          #MOVES ... INITIALIZE WILL USE MOVESTRING TO DETERMINE IF#
          #ITS MOVE IS CONSISTENT BUT WILL NOT USE THE MOVESTRING#
          #ERROR MESSAGES ... LATER ON, WE MAY DEFINE OUR OWN STRING# 
  
         #    KEY                                     DNAT TYPE # 
         #    0    ERROR TYPE                              5    # 
         #    1    GROUP                                   16   # 
         #         VARIABLE GROUP                          17   # 
         #    2    ALPHABETIC                              1    # 
         #         ALPHABETIC EDITED                       2    # 
         #    3    ALPHANUMERIC                            3    # 
         #    4    ALPHANUMERIC EDITED                     4    # 
         #    5    NUMERIC EDITED                          6    # 
         #    6    INTEGER NUMERIC                         7    # 
         #         INTEGER INTERNAL DECIMAL                9    # 
         #         INTEGER BINARY                          12   # 
         #    7    NON INTEGER NUMERIC                     7    # 
         #         EXTERNAL FLOATING POINT                 8    # 
         #         NON INTEGER INTERNAL DECIMAL            9    # 
         #         FLOATING POINT SHORT                    10   # 
         #         FLOATING POINT LONG                     11   # 
         #         NON INTEGER BINARY                      12   # 
  
         #    8    INTEGER LITERAL                              # 
         #    9    NUMERIC LITERAL                              # 
         #         FLOATING POINT LITERAL                       # 
         #    10   ZERO                                         # 
         #    11   SPACE                                        # 
         #    12   UPPER BOUND                                  # 
         #         LOWER BOUND                                  # 
         #         HI VALUE                                     # 
         #         LOW VALUE                                    # 
         #         QUOTE                                        # 
         #    13   QLIT                                         # 
         #    14   BOOLEAN                                      # 
  
          KEY1 = XPP31(STACK(S)); 
          IF KEY1 NQ 0
          THEN BEGIN
              REG1 = 7 * KEY1 + KEY2 - 8; 
               FIX1 = BYTE(MOVESTRING,REG1);
               IF FIX1 NQ 0 
               THEN BEGIN 
                    #THE SENDING ITEM IS NOT CONSISTENT WITH THE# 
                    #REPLACING TYPE INDICATED IN THE STATEMENT# 
                    ERROR(SEVERE,706,LINE(S),COLUMN(S));
                    INCOMPATIBLE = 1; 
                    END 
               END
          IF TCODE(S) EQ GLITREF
          THEN BEGIN
               #THE SENDING FIELD IS A LITERAL# 
               #DESTROY THE LAT AND DNAT ENTRIES CREATED BY THE#
               #LITERAL TABLE - WE WILL CREATE A NEW LAT FOR# 
               #EACH MOVE INCLUDING THE FIRST#
               INITALLBIT = GET(L$ALL,LAT$,LATLENGTH);
               LATLENGTH = LATLENGTH - 1; 
               DNATLENGTH = DNATLENGTH - 1; 
               #PRESERVE PLT POINTER# 
               INITLATTEMP = LATTEMP; 
               END
          ELSE BEGIN
               #THE SENDING FIELD IS AN IDENTIFIER# 
               #SAVE REFERENCE COUNT TABLE INDEX FOR REPLACER#
               SENDREFINDX = REFCOUNTINDX;
               #DECREMENT REF COUNT SINCE NOT USED YET# 
               IF REFCOUNTINDX NQ 0 
               THEN BEGIN 
                    FIX1 = GET(RCT$ENTRY,RCT$,REFCOUNTINDX) - 1;
                    SET(RCT$ENTRY,RCT$,REFCOUNTINDX,FIX1);
                    END 
               #SAVE SENDING FIELD ATOM#
               OPERAND1 = STACK(S); 
               #THE SENDING FIELD IS NOT LITERAL# 
               LSW = 0; 
               END
          #REMOVE SENDING FIELD FROM THE STACK# 
          S = S - 1;
          S$ = S$ - 1;
          #CALL INITPROC EVEN IF INCOMPATIBLE#
          #MORE DIAGNOSTICS ARE POSSIBLE# 
          INITPROC; 
          RETURN; 
          END #SET6#
          TERM
