*DECK PQ
USETEXT CCTTEXT 
USETEXT DNTEXT
USETEXT PPTEXT
PROC PQ (P1,P2,P3,P4);
         BEGIN
         XREF FUNC STACK; 
         XREF FUNC LINE;
         XREF FUNC COLUMN;
         XREF FUNC TPOINTER;
         XREF FUNC TCODE; 
         XREF FUNC TSUBCODE;
         XREF FUNC PRIORITY;
         XREF FUNC ADDRESS; 
         XREF FUNC FORMULA; 
         XREF FUNC SUBJECT; 
         XREF FUNC OBJECT;
         XREF FUNC DEBUGELEMENT;
         XREF FUNC COMMONSTACK; 
         XREF FUNC BOOLSTACK; 
         XREF PROC  CSTPURGE; 
*CALL DPPPDDATA 
*CALL PPCOMMON2 
*CALL SPBT1 
*CALL AUXTVALS
*CALL DNATVALS
*CALL PLTVALS 
         XREF FUNC PLTCHARACTER C(1); 
         XREF FUNC BYTE;
         XREF FUNC GTX; 
         XREF FUNC DEC C(10); 
         XREF FUNC GETGT; 
           XREF PROC CSTCHECK;
          $BEGIN
          XREF
              BEGIN 
              ITEM BOOL$STK$TRC   B;   # BOOLEAN STACK TRACE           #
              ITEM FORM$STK$TRC   B;   # FORMULA STACK TRACE           #
              ITEM PRI$STK$TRC    B;   # PRIORITY STACK TRACE          #
              ITEM STACK$TRACE    B;   # MAIN STACK TRACE              #
              ITEM SUB$OBJ$TRC    B;   # SUBJECT/OBJECT STACK TRACE    #
              END 
  
          XREF
              BEGIN 
              PROC SUB$DMP;            # SUBJECT STACK DUMP            #
              PROC OBJ$DMP;            # OBJECT STACK DUMP             #
              PROC OUTPUT;             # OUTPUT TO LISTING FILE        #
              END 
          $END
         CONTROL EJECT; 
         # ----- COMMON DECLARATIONS FOR P AND Q ----- #
         ITEM P1; 
         ITEM P2; 
         ITEM P3; 
         ITEM P4; 
         ITEM R1, R2, R3, R4, R5, R6, R7, R8, R9, R10, R11; 
         ITEM CH1 C(1); 
         ITEM TYPE; 
         ITEM CODE; 
         ITEM POINTER;
         ITEM DP; 
         ITEM MESS; 
         ITEM K1; 
         ITEM K2; 
         ITEM E;
         ITEM LATDP;
         ITEM INDX; 
         ITEM TOTAL;
         ITEM FRACTION; 
         ITEM INTEGER;
         ARRAY NONNUMSTR [0:2]; 
         ITEM NONDUMMY U = [X"00 03 02 04 02 FF 02 0",
                            X"03 02 00 00 00 00 00 0",
                             X"00 00 04 04 00 03 03 0"];
         ARRAY [1:4] S(1);
         ITEM MESSAGE I =[164,261,174,256]; 
# ----- INTERNAL PROCEDURES -----#
FUNC ATTACHAUX2 (P1); 
         #ATTACH AUX ENTRY# 
         #P1 - DNAT POINTER#
         #THE NEW ENTRY GOES ON THE FRONT OF THE CHAIN# 
         BEGIN
         ITEM    P1;
         AUXTLENGTH = AUXTLENGTH + 1; 
         TEMP = GET(DN$AUXREF,DNAT$,P1);
         SET(DN$AUXREF,DNAT$,P1,AUXTLENGTH);
         SET(AX$TGROUP,AUX$,AUXTLENGTH,0);
         SET(AX$TNEXTPTR,AUX$,AUXTLENGTH,TEMP); 
         ATTACHAUX2 = AUXTLENGTH; 
         RETURN;
         END #ATTACHAUX2# 
# ----- END OF INTERNAL PROCEDURES -----# 
CONTROL EJECT;
# ----- MAIN LINE BEGINS HERE -----#
ENTRY PROC XPP2;
         #VD (VERB DESCRIPTION)#
         NG(GTX(GVERB,VALUE$,GVERBDES));
         NG(GTX(GSUBVERB,LINE$,COLUMN$)); 
          PREVIOUSLINE = VERBLINE;
         VERBLINE = LINE$;
         VERBCOLUMN = COLUMN$;
         VERBCODE = VALUE$; 
         MNUMBER = 0; 
         MD = 0;
         CSTCHECK;
         IF CCTIDBUG THEN   # THROW AWAY SUBSCRIPT OPTIMIZATION ACROSS #
             CSTPURGE;      # GTEXT VERB DEXC. FOR INTERACTIVE DEBUG   #
         RETURN;
ENTRY FUNC XPP3;
         #NEXT LAT# 
         BEGIN
         DNATLENGTH = DNATLENGTH + 1; 
         SET(DN$LEVEL,DNAT$,DNATLENGTH,LITLEVL);
         SET(DN$TYPE,DNAT$,DNATLENGTH,ERRTYPE); 
         LATLENGTH = LATLENGTH + 1; 
         SET(L$DNAT,LAT$,LATLENGTH,DNATLENGTH); 
         SET(L$PLT,LAT$,LATLENGTH,LATTEMP); 
         XPP3 = LATLENGTH;
         RETURN;
         END #XPP3# 
ENTRY FUNC XPP4;
         #NEXT PNAT#
         BEGIN
         PNATLENGTH = PNATLENGTH + 1; 
         SET(PN$SEGMENTNO,PNAT$,PNATLENGTH,SEGMENT);
         XPP4 = PNATLENGTH; 
         RETURN;
         END #XPP4# 
ENTRY FUNC XPP5;
         #NEXT DNAT#
         BEGIN
         DNATLENGTH = DNATLENGTH +1;
         XPP5 = DNATLENGTH; 
         RETURN;
         END #XPP5# 
ENTRY FUNC XPP6;
         #NEXT AUX# 
         BEGIN
         AUXTLENGTH = AUXTLENGTH + 1; 
         XPP6 = AUXTLENGTH; 
         RETURN;
         END #XPP6# 
ENTRY FUNC XPP7;
         #NEXT TEMP#
         BEGIN
         DNATLENGTH = DNATLENGTH + 1; 
         SET(DN$LEVEL,DNAT$,DNATLENGTH,TEMPLEVL); 
         SET(DN$TYPE,DNAT$,DNATLENGTH,ERRTYPE); 
         XPP7 = DNATLENGTH; 
         RETURN;
         END #XPP7# 
ENTRY PROC XPP9 (P1); 
         #LOCAL TEMP# 
         #P1 - DNAT POINTER#
         BEGIN
         SET(DN$MAJMSEC,DNAT$,P1,TEMPMSEC); 
         SET(DN$LONGOFF,DNAT$,P1,CURRNTOFFSET); 
         R11 = GET(DN$ITMLEN,DNAT$,P1); 
         CURRNTOFFSET = CURRNTOFFSET + ((R11+9)/10)*10; 
         IF MAXOFFSET LS CURRNTOFFSET 
         THEN MAXOFFSET = CURRNTOFFSET; 
         RETURN;
         END #XPP9# 
ENTRY PROC XPP10 (P1);
         #GLOBAL TEMP#
         #P1 - DNAT POINTER#
         BEGIN
         SET(DN$MAJMSEC,DNAT$,P1,SREGMSEC); 
         # LEVEL MUST NOT BE TEMP IF MAJMSEC IS SREGMSEC #
         # OR PROC TAB GETS MESSED UP.    # 
         SET(DN$LEVEL,DNAT$,P1,77); 
         R2 = CCTMSECLEN[SREGMSEC]; 
         R2 = ((R2+9)/10)*10; 
         SET(DN$LONGOFF,DNAT$,P1,R2); 
         CCTMSECLEN[SREGMSEC] = R2 + GET(DN$ITMLEN,DNAT$,P1); 
         RETURN;
         END #XPP10#
ENTRY FUNC XPP11 (P1);
         #REMOVE# 
         #P1 - INDICATES WHERE TO PUT SUBSCRIPTS (IF ANY)#
         BEGIN
         $BEGIN 
         IF SUB$OBJ$TRC OR STACK$TRACE OR FORM$STK$TRC OR BOOL$STK$TRC
         THEN 
             OUTPUT(3," REMOVE CA","LLED  P1=",DEC(P1));
         $END 
         IF STACK(S) NQ SUBMARKER 
         THEN BEGIN 
              R3 = S; 
              S = S-1;
              END 
         ELSE BEGIN 
              R2 = STACK(S-1);
              FOR R1 = R2 
              STEP 1  UNTIL S-2 
              DO   BEGIN
                   SWITCH PP11SW PP11X0, PP11X1, PP11X2, PP11X3,
                          PP11X4, PP11X5, PP11X6; 
                   GOTO PP11SW[P1]; 
                   PP11X1: #P1 = 1 SUBSCRIPTS -> GTEXT# 
                           BEGIN
                           NG(STACK(R1)); 
                           TEST R1; 
                           END
                   PP11X2: #P1 = 2 SUBSCRIPTS -> FORMULA# 
                           BEGIN
                           FL = FL + 1; 
                           XFORMULA(FL,STACK(R1));
                           TEST R1; 
                           END
                   PP11X3: #P1 = 3 SUBSCRIPTS -> SUBJECT# 
                           BEGIN
                           SLENGTH = SLENGTH + 1; 
                           XSUBJECT(SLENGTH,STACK(R1)); 
                           TEST R1; 
                           END
                   PP11X4: #P1 = 4 SUBSCRIPTS -> OBJECT#
                           BEGIN
                           OLENGTH = OLENGTH + 1; 
                           XOBJECT(OLENGTH,STACK(R1));
                           TEST R1; 
                           END
                   PP11X5: #P1 = 5 SUBSCRIPTS -> SEARCH STACK#
                           BEGIN
                           SRLENGTH = SRLENGTH + 1; 
                           SEARCHSTACK[SRLENGTH] = STACK(R1); 
                           TEST R1; 
                           END
                   PP11X6: # P1 = 6 SUBSCRIPTS -> BOOLSTACK # 
                           BEGIN
                           BL = BL + 1; 
                           XBOOLSTACK (BL, STACK(R1));
                           TEST R1; 
                           END
                   PP11X0:  
                   END #END OF SUBSCRIPT MOVE OPERATION#
              S = R2-2; 
              R3 = R2-1;
              END 
         S$ = S$ - 1; 
         XPP11 = R3;
         $BEGIN 
         IF SUB$OBJ$TRC OR STACK$TRACE OR FORM$STK$TRC OR BOOL$STK$TRC
         THEN 
             BEGIN
             OUTPUT(2," REMOVE = ",DEC(R3));
             IF SUB$OBJ$TRC AND P1 EQ 3 THEN SUB$DMP; 
             IF SUB$OBJ$TRC AND P1 EQ 4 THEN OBJ$DMP; 
             END
         $END 
         RETURN;
         END #XPP11#
ENTRY FUNC XPP12 (P1);
         #RETRIEVE# 
         #P1 - S$ OF STACK GROUP DESIRED# 
         #NOTE - SUBSCRIPTS GO INTO THE GTEXT#
         BEGIN
         $BEGIN 
         IF STACK$TRACE THEN
             OUTPUT(3," RETRIEVE ","CALLED P1=",DEC(P1)); 
         $END 
         R1 = S$; 
         R2 = S;
         #SCAN BACK THROUGH THE STACK FOR THE CORRECT S$# 
         FOR $DUMMY$ = 0
         WHILE R1 NQ P1 
         DO   BEGIN 
              IF STACK(R2) EQ SUBMARKER 
              THEN R2 = STACK(R2-1) - 2;
              ELSE R2 = R2 - 1; 
              R1 = R1 - 1;
              END 
         #OUTPUT SUBS TO GTEXT IF ANY#
         IF STACK(R2) NQ SUBMARKER
         THEN BEGIN 
              XPP12 = R2; 
              RETURN; 
              END 
         R3 = STACK(R2-1);
         FOR R4 = R3
         STEP 1  UNTIL R2 - 2 
         DO   BEGIN 
              NG(STACK(R4));
              END 
         XPP12 = R3 - 1;
         $BEGIN 
         IF STACK$TRACE THEN OUTPUT(2," RETRIEVE=",DEC(R3-1));
         $END 
         RETURN;
         END #XPP12#
ENTRY PROC XPP14 (P1);
         #UNSTACK#
         #P1 - PRIORITY NUMBER# 
         BEGIN
         $BEGIN 
         IF STACK$TRACE THEN
             OUTPUT(6," UNSTACK  ","WITH  PRIO","RITY      ",DEC(P1), 
                 "       Z =",DEC(Z));
         $END 
         FOR $DUMMY$ = 0
         WHILE P1 LQ PRIORITY(Z)
         DO   BEGIN 
              SWITCH PP14SW 
                     ,
                     UNSTACKIF, 
                     ,
                     UNSTACKTHEN, 
                     UNSTACKOR, 
                     UNSTACKTHEN, 
                     UNSTACKNOT;
                     #NOTE - 2ND UNSTACKTHEN IS REALLY UNSTACKAND#
              GOTO PP14SW[PRIORITY(Z)]; 
              UNSTACKIF:  
                   BEGIN
                   Z = Z - 1; 
                   TEST $DUMMY$;
                   END
              UNSTACKTHEN:  
                   BEGIN
                   IF ORADDRESS EQ 0
                   THEN ORADDRESS = ADDRESS(Z); 
                   ELSE SET(PN$EQUATE,PNAT$,ADDRESS(Z),ORADDRESS);
                   Z = Z - 1; 
                   TEST $DUMMY$;
                   END
              UNSTACKOR:  
                   BEGIN
                   IF ANDADDRESS EQ 0 
                   THEN ANDADDRESS = ADDRESS(Z);
                   ELSE SET(PN$EQUATE,PNAT$,ADDRESS(Z),ANDADDRESS); 
                   Z = Z - 1; 
                   TEST $DUMMY$;
                   END
              UNSTACKNOT: 
                   BEGIN
                   NEGATION = 1;
                   Z = Z - 1; 
                   END
              END 
         $BEGIN 
         IF STACK$TRACE THEN OUTPUT(3," EXIT UNST","ACK W/  Z=",DEC(Z));
         $END 
         RETURN;
         END #XPP14#
ENTRY PROC XPP15 (P1);
         #OPERAND TEST (NUM-OP-CHECK)#
         #P1 - STACK LOCATION OF THE OPERAND# 
         BEGIN
         R1 = P1; 
         R2 = TPOINTER(R1); 
         IF TCODE(R1) EQ GLITREF
         THEN GOTO LITREF;
         #OPERAND IS A DATA REFERENCE#
         #IGNORE TEMPORARIES# 
         IF GET(DN$LEVEL,DNAT$,R2) EQ TEMPLEVL
         THEN RETURN; 
         #IGNORE IF ERROR TYPE# 
         R3 = GET(DN$TYPE,DNAT$,R2);
         IF R3 EQ ERRTYPE 
         THEN RETURN; 
         IF R3 LS LOWNUMOPERND OR 
            R3 GR HINUMOPERND 
         THEN BEGIN 
              #THIS OPERAND MUST BE NUMERIC#
              ERROR(SEVERE,81,LINE(R1),COLUMN(R1)); 
              RETURN; 
              END 
         IF R3 NQ NUMERIC AND 
            R3 NQ COMP4 AND 
            R3 NQ BINARY
         THEN RETURN; 
         TOTAL = GET(DN$NUMLEN,DNAT$,R2); 
         FRACTION = GET(DN$POINT,DNAT$,R2); 
         INTEGER = TOTAL - FRACTION;
         GOTO L1; 
LITREF: 
         #LITERAL OPERANDS COME HERE# 
         R3 = GET(L$PLT,LAT$,R2); 
         R11 = GET(PL$CODE,PLT$,R3);
         IF R11 EQ PLTQUOTEDLIT 
         THEN BEGIN 
              #THIS OPERAND MUST BE NUMERIC#
              ERROR(SEVERE,81,LINE(R1),COLUMN(R1)); 
              RETURN; 
              END 
         IF R11 NQ PLTINTLIT AND
         R11 NQ PLTNUMLIT 
         THEN RETURN; 
         #FIRST, ASSUME THIS IS AN INTEGER# 
         INTEGER = GET(PL$LENGTH,PLT$,R3);
         FRACTION = 0;
         IF R11 EQ PLTINTLIT
         THEN GOTO L1;
         #WE ASSUMED WRONGLY, THIS IS A NUMERIC LITERAL#
         R4 = GET(PL$LENGTH,PLT$,R3); 
         FOR I = 1
         STEP 1 
         UNTIL R4 
         DO BEGIN 
            IF PLTCHARACTER(R3,I) EQ CCTDECPOINT[0] 
            THEN GOTO L2; 
            END 
         L2:  
         INTEGER = I - 1; 
         FRACTION = R4 - I; 
L1: 
         IF ICOMPOSITE LS INTEGER 
         THEN ICOMPOSITE = INTEGER; 
         IF FCOMPOSITE LS FRACTION
         THEN FCOMPOSITE = FRACTION;
         RETURN;
         END #XPP15#
ENTRY PROC XPP16 (P1);
         #RESULT TEST#
         #P1 - STACK LOCATION OF THE OPERAND# 
         BEGIN
         I = TPOINTER(P1);
         TEMP = GET(DN$TYPE,DNAT$,I); 
         IF TEMP EQ ERRTYPE 
         THEN RETURN; 
         IF TEMP LS LOWNUMRESULT OR TEMP GR HINUMOPERND 
         THEN  ERROR(SEVERE,82,LINE(P1),COLUMN(P1));
         ELSE BEGIN 
              #CALCULATE COMPOSITE OF OPERANDS FOR RECEIVING FIELDS#
              TOTAL = GET(DN$NUMLEN,DNAT$,I); 
              FRACTION = GET(DN$POINT,DNAT$,I); 
              INTEGER = TOTAL - FRACTION; 
              IF ICOMPOSITE2 LS INTEGER 
              THEN ICOMPOSITE2 = INTEGER; 
              IF FCOMPOSITE2 LS FRACTION
              THEN FCOMPOSITE2 = FRACTION;
              END 
         RETURN;
         END #XPP16#
ENTRY PROC XPP17 (P1);
         #NON ZERO LIT# 
         #P1 - STACK LOCATION OF THE LITERAL# 
         BEGIN
         R1 = TPOINTER(P1); 
         R2 = GET(L$PLT,LAT$,R1); 
         R3 = GET(PL$CODE,PLT$,R2); 
         R4 = GET(PL$LENGTH,PLT$,R2); 
         IF R3 NQ PLTFGCONZERO
         THEN BEGIN 
              FOR I = 1 STEP 1 UNTIL R4 
              DO BEGIN
                 CH1 = PLTCHARACTER(R2,I);
                 IF CH1 EQ "0" OR CH1 EQ CCTDECPOINT[0] 
                 THEN TEST I; 
                 IF CH1 EQ "E"
                 THEN ERROR(SEVERE,880,LINE(P1),COLUMN(P1));
                 ELSE RETURN; #NON ZERO CHARACTER#
                 END
              END 
         #WE REACHED THE END WITHOUT BEING SAVED BY NON ZERO SAVIOR#
         ERROR(SEVERE,880,LINE(P1),COLUMN(P1)); 
         RETURN;
         END #XPP17#
ENTRY FUNC XPP18 (P1,P2); 
         #GET AUX#
         #P1 - DNAT POINTER#
         #P2 - AUX TYPE DESIRED#
         BEGIN
         R1 = GET(DN$AUXREF,DNAT$,P1);
         LOOP:  
         IF R1 EQ 0 
         THEN BEGIN 
              XPP18 = 0;
              RETURN; 
              END 
         R2 = GET(AX$TTYPE,AUX$,R1);
         R3 = GET(AX$SUBSLVL,AUX$,R1);
         R4 = GET(DN$SDEPTH,DNAT$,P1);
         IF R2 EQ P2  AND  R3 EQ R4 
         THEN BEGIN 
              XPP18 = R1; 
              RETURN; 
              END 
         R1 = GET(AX$TNEXTPTR,AUX$,R1); 
         GOTO LOOP; 
         END #XPP18#
ENTRY FUNC XPP19 (P1,P2); 
         #FIND AUX ENTRY# 
         #P1 - AUX TYPE DESIRED#
         #P2 - AUX TABLE INDEX# 
         BEGIN
         #WE DONT WISH TO DESTROY P2# 
         R2 = P2; 
         FOR $DUMMY$ = 0
         WHILE R2 NQ 0 AND GET(AX$TTYPE,AUX$,R2) NQ P1
         DO R2 = GET(AX$TNEXTPTR,AUX$,R2);
         XPP19 = R2;
         RETURN;
         END #XPP19#
ENTRY FUNC XPP20 (P1);
         #ATTACH AUX ENTRY# 
         #P1 - DNAT POINTER#
         #THE NEW ENTRY GOES ON THE FRONT OF THE CHAIN# 
         BEGIN
         AUXTLENGTH = AUXTLENGTH + 1; 
         TEMP = GET(DN$AUXREF,DNAT$,P1);
         SET(DN$AUXREF,DNAT$,P1,AUXTLENGTH);
         SET(AX$TGROUP,AUX$,AUXTLENGTH,0);
         SET(AX$TNEXTPTR,AUX$,AUXTLENGTH,TEMP); 
         XPP20 = AUXTLENGTH;
         RETURN;
         END #XPP20#
ENTRY FUNC XPP22 (ORIGIN, DESTINATION, MODE); 
         #TRANSFER CONTROL# 
         #KEY = 0 REGULAR PROCEDURE#
         #KEY = 1 DECLARATIVE PROCEDURE (NOT DEBUG)#
         #KEY = 2 DEBUG PROCEDURE#
         #KEY = 3 SORT PROCEDURE# 
         #MODE = 0 GO TO STATEMENT# 
         #MODE = 1 ALTER STATEMENT# 
         #MODE = 2 PERFORM STATEMENT# 
         #MODE = 3 PERFORM REGION#
         ITEM ORIGIN; 
         ITEM DESTINATION;
         ITEM MODE; 
         ITEM X B; #TWO DIFFERENT DECLARATIVES# 
         ITEM Y B; #TWO DIFFERENT DEBUGS# 
         ITEM W B; #TWO DIFFERENT SORTS#
         ARRAY [0:3,0:3] S(1);
         ITEM GOARRAY I 
         =[[000, 604, 607, 610] 
          [601, 000, 607, 611]
          [602, 605, 000, 612]
          [603, 606, 609, 000]];
         ARRAY [0:3,0:3] S(1);
         ITEM ALTERARRAY I
         =[[000, 616, 619, 622] 
          [613, 000, 619, 623]
          [614, 617, 000, 624]
          [615, 618, 621, 000]];
         ARRAY [0:3,0:3] S(1);
         ITEM PERFORMARRAY I
         =[[000, 627, 627, 632] 
          [000, 000, 000, 633]
          [625, 628, 000, 634]
          [626, 629, 631, 000]];
         ARRAY [0:3,0:3] S(1);
         ITEM REGIONARRAY I 
         =[[000, 638, 638, 641] 
          [635, 000, 639, 642]
          [635, 639, 000, 642]
          [637, 640, 640, 000]];
         BEGIN
         #CALCULATE THE TWO KEYS# 
         #DISREGARD UNDEFINED, AMBIGUOUS, ETC.# 
         IF ORIGIN EQ 0 OR DESTINATION EQ 0 
         THEN BEGIN 
              XPP22 = 0;
              RETURN; 
              END 
         K1 = 0;
         K2 = 0;
         IF GET(PN$DECLARATV,PNAT$,ORIGIN) EQ 1 
         THEN K1 = 1; 
         IF GET(PN$DECLARATV,PNAT$,DESTINATION) EQ 1
         THEN  K2 = 1;
         IF GET(PN$DEBUG,PNAT$,ORIGIN) EQ 1 
         THEN K1 = 2; 
         IF GET(PN$DEBUG,PNAT$,DESTINATION) EQ 1
         THEN K2 = 2; 
         IF GET(PN$SORTPROC,PNAT$,ORIGIN) EQ 1
         THEN K1 = 3; 
         IF GET(PN$SORTPROC,PNAT$,DESTINATION) EQ 1 
         THEN K2 = 3; 
         #NEXT - LOOK FOR THREE SPECIAL CASES#
         X = FALSE; 
         IF K1 EQ 1 AND K2 EQ 1 
         THEN BEGIN 
              IF GET(PN$PROCKIND,PNAT$,ORIGIN) EQ 1 
              THEN R3 = ORIGIN; 
              ELSE R3 = GET(PN$PREVSECTN,PNAT$,ORIGIN); 
              IF GET(PN$PROCKIND,PNAT$,DESTINATION) EQ 1
              THEN R4 = DESTINATION;
              ELSE R4 = GET(PN$PREVSECTN,PNAT$,DESTINATION);
              IF R3 NQ R4 
              THEN X = TRUE;
              END 
         Y = FALSE; 
         IF K1 EQ 2 AND K2 EQ 2 
         THEN BEGIN 
              IF GET(PN$PROCKIND,PNAT$,ORIGIN) EQ 1 
              THEN R3 = ORIGIN; 
              ELSE R3 = GET(PN$PREVSECTN,PNAT$,ORIGIN); 
              IF GET(PN$PROCKIND,PNAT$,DESTINATION) EQ 1
              THEN R4 = DESTINATION;
              ELSE R4 = GET(PN$PREVSECTN,PNAT$,DESTINATION);
              IF R3 NQ R4 
              THEN Y = TRUE;
              END 
         W = FALSE; 
         IF K1 EQ 3 AND K2 EQ 3 
         THEN BEGIN 
              #SORT PROCEDURES CAN OVERLAP EACH OTHER#
              #THEREFORE, WE MUST LOOK AT EACH SORT#
              #PROCEDURE IN THE SPBT AND DETERMINE IF#
              #THE ORIGIN IS IN THE RANGE WHILE THE#
              #DESTINATION IS NOT IN THE RANGE# 
              FOR R1 = 1
              STEP 1  UNTIL SPBTLENGTH
              DO   BEGIN
                   IF (ORIGIN GQ GET(SPBT$LOBOUND,SPBT$,R1) AND 
                   ORIGIN LQ GET(SPBT$HIBOUND,SPBT$,R1))
                   AND
                   (DESTINATION LS GET(SPBT$LOBOUND,SPBT$,R1) OR
                   DESTINATION GR GET(SPBT$HIBOUND,SPBT$,R1)) 
                   AND
                   (GET(SPBT$TYPE,SPBT$,R1) EQ 1 OR 
                   GET(SPBT$TYPE,SPBT$,R1) EQ 2)
                   THEN W = TRUE; 
                   END
              END 
         SWITCH MODESWITCH X0, X1, X2, X3;
         GOTO MODESWITCH [MODE];
         X0: BEGIN
             #CASE 1 = THE GO TO STATEMENT# 
             R1 = GOARRAY[K1,K2]; 
             IF Y 
             THEN R1 = 608; 
             IF W 
             THEN R1 = 600; 
             GOTO X4; 
             END
         X1: BEGIN
             #CASE 2 - THE ALTER STATEMENT# 
             R1 = ALTERARRAY[K1,K2];
             IF W 
             THEN R1 = 636; 
             IF Y 
             THEN R1 = 620; 
             GOTO X4; 
             END
         X2: BEGIN
             #CASE 3 - THE PERFORM STATEMENT# 
             R1 = PERFORMARRAY[K1,K2];
             IF W 
             THEN R1 = 630; 
             GOTO X4; 
             END
         X3: BEGIN
             #CASE 4 - THE PERFORMED REGION#
             R1 = REGIONARRAY[K1,K2]; 
             IF X 
             THEN R1 = 639; 
             IF W 
             THEN R1 = 641; 
             IF Y 
             THEN R1 = 639; 
             END
         X4:  
         IF R1 EQ 0 
         THEN BEGIN 
              XPP22 = 1;
              RETURN; 
              END 
  
 # NON-STANDARD COBOL DIAGNOSTICS -- SEVERITY = N IN DIAGTXT.          #
 # WE RETURN A VALUE OF 1 FOR XPP22 SO THAT GTEXT WILL BE PRODUCED     #
  
         IF R1 EQ 626  OR 
            R1 EQ 630  OR 
            R1 EQ 632 
         THEN 
             BEGIN
             ERROR(JOD, R1, VERBLINE, VERBCOLUMN);
             XPP22 = 1; 
             RETURN;
             END
  
         ERROR(SEVERE,R1,VERBLINE,VERBCOLUMN);
         XPP22 = 0; 
         RETURN;
         END #XPP22#
ENTRY PROC XPP24 (P1,P2); 
         #LITERAL DNAT# 
         #COPY RESULT FIELD DNAT INTO THE LITERAL DNAT# 
         #P1 - DNAT POINTER#
         #P2 - LATDP# 
         BEGIN
         COPYD4 (P1,P2);
         IF GET(DN$LEVEL,DNAT$,P2) EQ REFMODLEVEL 
         THEN BEGIN 
              SET(DN$BYTEOFFS,DNAT$,P2,0);
              END 
         SET(DN$LEVEL,DNAT$,P2,LITLEVL);
         RETURN;
         END #XPP24#
ENTRY FUNC XPP27; 
         #BRANCH TABLE DNAT#
         BEGIN
         DNATLENGTH = DNATLENGTH + 1; 
         SET(DN$TYPE,DNAT$,DNATLENGTH,NONDATA); 
         SET(DN$LEVEL,DNAT$,DNATLENGTH,BRTABLE);
         SET(DN$MAJMSEC,DNAT$,DNATLENGTH,GITMMSEC); 
         SET(DN$ITMLEN,DNAT$,DNATLENGTH,10);
         SET(DN$BYTEOFFS,DNAT$,DNATLENGTH,BRTBLCOUNT);
         BRTBLCOUNT = BRTBLCOUNT + 8; 
         XPP27 = DNATLENGTH;
         RETURN;
         END #XPP27#
ENTRY FUNC XPP28 (P1);
         #NON NUM ID# 
         #P1 - CODE (SEE BELOW)#
         #THIS ROUTINE CHECKS THE VALIDITY OF THE CURRENT IDENTIFIER# 
         #ACCORDING TO THE FOLLOWING VALUES OF P1       # 
         # 1  USAGE IS DISPLAY# 
         # 2  ELEMENTARY USAGE IS DISPLAY#
         # 3   USAGE IS DISPLAY WITH NO EDITING # 
         # 4  ALPHANUMERIC DATA ITEM# 
         #THE NONNUMSTR CONTAINS FOR EACH TYPE THE MAXIMUM VALUE# 
         #OF THE CODE PARAMETER FOR WHICH THE TYPE IS VALID. IF#
         #INVALID AN APPROPRIATE ERROR MESSAGE IS ISSUED.#
         # THERE IS NO CALL USING P1 = 2 #
         # VERIFY NONNUMSTR VALUE FOR GROUP AND # 
         # VGROUP BEFORE USING P1 = 2 .... TMH #
         # ALSO, IMS HAS DESCRIPTION OF NON NUM ID #
         BEGIN
         XPP28 = 0; 
         R2 = GET(DN$TYPE,DNAT$,TABLENAME); 
         R1 = BYTE(NONNUMSTR,R2); 
         IF R1 LS P1
         THEN BEGIN 
              ERROR(SEVERE,MESSAGE[P1],TABLELINE,TABLECOLUMN);
              RETURN; 
              END 
         IF R2 NQ ERRTYPE 
         THEN XPP28 = 1;
         RETURN;
         END #XPP28#
ENTRY FUNC XPP29; 
         #NON NUM LIT#
         #THIS FUNCTION VERIFIES THAT THE CURRENT LITERAL#
         #IS NON-NUMERIC AND NOT AN ALL LITERAL#
         #R1 - PLT TYPE#
         #R2 - LAT INDEX OF LITERAL#
         #R3 - DNAT INDEX OF COMPILER GENERATED LITERAL DNAT ENTRY# 
         BEGIN
         R1 = GET(PL$CODE,PLT$,LATTEMP);
         IF R1 NQ PLTQUOTEDLIT
         AND
         R1 NQ PLTFGCONZERO 
         THEN BEGIN 
              ERROR(SEVERE,173,LINE$,COLUMN$);
              XPP29 = 0;
              RETURN; 
              END 
         ELSE BEGIN 
              #CHECK FOR ALL LITERAL# 
              R2 = LATLENGTH; 
              IF GET(L$ALL,LAT$,R2) EQ 1
              THEN BEGIN
                   SET(L$ALL,LAT$,R2,0);
                   ERROR(TRIVIAL,163,LINE$,COLUMN$);
                   END
              #SET UP CGL DNAT ENTRY# 
              R3 = DNATLENGTH;
              R4 = GET(PL$LENGTH,PLT$,LATTEMP); 
              SET(DN$ITMLEN,DNAT$,R3,R4); 
              SET(DN$TYPE,DNAT$,R3,ALPHNUM);
              XPP29 = 1;
              RETURN; 
              END 
         END #XPP29#
ENTRY FUNC XPP31 (P1);
         #MOVE S KEY# 
         #P1 - GTEXT ATOM OF THE SENDING FIELD# 
         #THIS PROCEDURE TRANSLATES THE MOVE STATEMENT# 
         #SENDING FIELD INTO A KEY - THIS KEY IS LATER USED#
         #ALONG WITH THE RECEIVING FIELD KEY TO DETERMINE#
         #IF THE MOVE IS LEGAL - MOVESKEY WILL DIAGNOSE THE#
         #SENDING FIELD IF IT IS INDEX-DATA, INDEX-NAME, OR#
         #NON-DATA AND RETURN KEY = 0 - IF THE DATA TYPE IS#
         #DISPLAY NUMERIC, BINARY, OR INTERNAL DECIMAL THE KEY# 
         #DEPENDS UPON WHETHER THE DATA ITEM IS DESCRIBED TO BE#
         #AN INTEGER# 
         #    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 BIT                             19   # 
         #         BOOLEAN DISPLAY                         20   # 
         #         BOOLEAN LITERAL                              # 
         BEGIN
         ARRAY SENDKEYSTR [0:2];
               ITEM SENDKEYSTRI  U = [X"00 02 02 03 04 00 05 0",
                                      X"07 07 07 07 07 07 07 0",
                                       X"00 00 01 01 00 0E 0E 0"];
         #PICK UP DNAT OR LAT POINTER#
          R1 = B<36,15>P1;
          R2 = B<30,6>P1; 
         IF R2 EQ GLITREF  THEN GOTO LREF;
         #THE SENDING FIELD IS A DATA REFERENCE LOOK UP THE DATA TYPE#
         R2 = GET(DN$TYPE,DNAT$,R1);
         #GET THE KEY FROM SENDKEYSTR#
         K = BYTE(SENDKEYSTR,R2); 
         #SPECIAL CASE 7, 9, 12#
         IF R2 EQ 7 OR R2 EQ 9 OR R2 EQ 12
         THEN GOTO TESTINTEGER; 
         #DIAGNOSE INDEX-DATA, INDEX-NAME, NON-DATA#
         MESS = 0;
         IF R2 EQ 14  THEN MESS = 2;
         IF R2 EQ 15  THEN MESS = 5;
         IF R2 EQ 18  THEN MESS = 26; 
         IF MESS  NQ  0 
         THEN  ERROR(SEVERE,MESS,LINE(S),COLUMN(S));
         GOTO RETURNKEY;
TESTINTEGER:  
         IF GET(DN$POINT,DNAT$,R1)  LQ  0 
         THEN K = 6;
RETURNKEY:  
         XPP31 = K; 
         RETURN;
LREF: 
         #COME HERE IF THE SENDING FIELD IS A LITERAL#
         #EXTRACT THE PLT POINTER FROM LAT# 
         R2 = GET(L$PLT,LAT$,R1); 
         #IS IT FIGCON ZERO  #
         IF GET(PL$FIGZERO,PLT$,R2) EQ 1
         THEN BEGIN 
                 XPP31 = 10;
                 RETURN;
                 END
         #IS IT FIGCON SPACE  # 
         IF GET(PL$FIGSPACE,PLT$,R2) EQ 1 
         THEN BEGIN 
                XPP31 = 11; 
                RETURN; 
                END 
         #HOW ABOUT UPPER-BOUND, LOWER-BOUND,#
         #HI-VALUE, LOW-VALUE, OR QUOTE  #
         IF GET(PL$FIGCON,PLT$,R2) NQ 0 
         THEN BEGIN 
                XPP31 = 12; 
                RETURN; 
                END 
         #LOOK UP THE LITERAL TYPE# 
         PLTPTR = R2; 
         R3 = GET(PL$CODE,PLT$,PLTPTR); 
         IF R3  EQ  PLTQUOTEDLIT
         THEN BEGIN 
                XPP31 = 13; 
                RETURN; 
                END 
         IF R3 EQ PLTBOOLLIT
         THEN BEGIN 
              XPP31 = 14; 
              RETURN; 
              END 
         #ASSUME FLIT OR NLIT#
         K = 9; 
         IF R3  EQ  PLTINTLIT 
         THEN K = 8;
         XPP31 = K; 
         RETURN;
         END   #XPP31#
ENTRY FUNC XPP32 (P1);
         #MOVE R KEY# 
         #P1 - DNAT POINTER#
         #THIS PROCEDURE TRANSLATES EACH MOVE STATEMENT#
         #RECEIVING FIELD INTO A KEY - THE KEY IS LATER USED# 
         #ALONG WITH THE SENDING FIELD KEY TO DETERMINE IF# 
         #THE MOVE IS LEGAL#
         #IF THE RECEIVING FIELD IS INDEX-NAME, INDEX-DATA, OR# 
         #OR NON-DATA, XPP32 WILL ISSUE A DIAGNOSTIC# 
         #IF THE RECEIVING FIELD IS ERROR-TYPE, NO DIAGNOSTIC#
         #IN EITHER CASE IF THE KEY = 0, NO FURTHER DIAGNOSTICS#
         BEGIN
         ARRAY RECKEYSTR [0:2]; 
               ITEM RECKEYSTRI  U = [X"00 02 02 03 04 00 05 0", 
                                     X"06 06 06 06 06 06 06 0", 
                                     X"00 00 01 01 00 07 07 0"];
         #LOOK UP THE DATA TYPE OF RECEIVING FIELD# 
          R1 = GET(DN$TYPE,DNAT$,P1); 
         #DETERMINE THE THE KEY FROM RECKEYSTR# 
         K = BYTE(RECKEYSTR,R1);
         #SPECIAL CASES ARE DNAT-TYPE 14, 15, 18# 
         MESS = 0;
         #INDEX-DATA# 
         IF R1 EQ 14  THEN MESS = 2;
         #INDEX-NAME# 
         IF R1 EQ 15  THEN MESS = 5;
         #NON-DATA# 
         IF R1 EQ 18  THEN MESS = 26; 
         IF MESS  NQ  0 
         THEN  ERROR (SEVERE,MESS,LINE(S),COLUMN(S)); 
         XPP32 = K; 
         RETURN;
         END   #XPP32#
ENTRY PROC RTEMP (P1,P2); 
         #RESULT TEMP ROUTINE#
         #WE ATTACH AN AUX ENTRY TO A TEMP EACH TIME# 
         #WE MOVE IT TO A RECEIVING FIELD ...       # 
         #P1 - DNAT PONTER OF THE TEMP# 
         #P2 - DNAT POINTER OF THE RECEIVING FIELD# 
         BEGIN
         IF GET(DN$TYPE,DNAT$,P1) EQ BOOLDSP
         THEN BEGIN 
              # NO RESULT TEMP FOR COMPUTE BOOLEAN #
              RETURN; 
              END 
         SET(DN$LEVEL,DNAT$,P1,RESULTTEMP); 
         R1 = ATTACHAUX2(P1); 
         SET(AX$TTYPE,AUX$,R1,AUXRESULTTMP);
         SET(AX$RECFIELD,AUX$,R1,P2); 
         RETURN;
         END #RTEMP#
ENTRY PROC XPP33(P1); 
         # NGSTACK #
         # P1 - STACK INDEX # 
         BEGIN
         NG(STACK(P1)); 
         RETURN;
         END #NGSTACK#
ENTRY PROC XPP34(P1); 
         # NGDATAREF #
         # P1 - DNAT POINTER #
         BEGIN
         NG(GTX(GDATAREF,P1,0));
         RETURN;
         END #NGDATAREF#
ENTRY PROC XPP35(P1); 
         # NGLITREF # 
         # P1 - LAT POINTER # 
         BEGIN
          NG(GTX(GLITREF,P1,0));
         RETURN;
         END #NGLITREF# 
ENTRY PROC XPP36(P1,P2);
         # NGPROCREF #
         # P1 - PNAT POINTER #
         # P2 - 0/GTRUE/GFLASE #
         BEGIN
         NG(GTX(GPROCREF,P1,P2)); 
         RETURN;
         END #NGPROCREF#
ENTRY PROC XPP37(P1,P2);
         # NGLABELREF # 
         # P1 - PNAT POINTER #
         # P2 - 0 / GTRUE / GFALSE #
         BEGIN
         NG(GTX(GLABELREF,P1,P2));
         RETURN;
         END #NGLABELREF# 
ENTRY PROC XPP38(P1); 
         # NGLABELDEF # 
         #P1 - PNAT POINTER # 
         BEGIN
         NG(GTX(GVERB,P1,GLABEL));
         RETURN;
         END
ENTRY PROC XPP39; 
         # NGMOVE # 
         BEGIN
         NG($MOVE); 
         RETURN;
         END #NGMOVE# 
ENTRY PROC XPP40; 
         # NGGOTO # 
         BEGIN
         NG($GOTO); 
         RETURN;
         END #NGGOTO# 
ENTRY PROC XPP41(P1,P2,P3); 
         # NGGTX #
         BEGIN
         NG(GTX(P1,P2,P3)); 
         END
         END #PQ# 
         TERM 
