*DECK SET8
USETEXT CCTTEXT 
USETEXT DNTEXT
USETEXT PPTEXT
    PROC SET8;
         CONTROL PACK;
          BEGIN 
*CALL DPPPDDATA 
*CALL PPCOMMON2 
*CALL SPBT1 
*CALL GETSET
*CALL DNATVALS
*CALL AUXTVALS
*CALL FNATVALS
*CALL PLTVALS 
*CALL FDLT
         ITEM  USINGLINE  U;
         ITEM  USINGCOL   U;
         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, SUB42, SUB43; 
          DEF  RECORDDNAT            #STACK(3)#;
          DEF  FILEDNAT              #STACK(2)#;
          DEF  SMCURRFNAT            #REG4#;
          DEF  SMAUXINDEX            #REG5#;
          DEF  SMAUXBASE             #REG6#;
          DEF  SMAUXLIMIT            #REG7#;
          DEF  SMDNATXHDR            #REG8#;
          #STACK LAYOUT FOR SORT VERB#
          DEF  SORTFILEDNAT          #STACK(1)#;
          DEF  SORTFILEFNAT          #STACK(2)#;
          DEF  KEYHDRDNAT            #STACK(3)#;
          DEF  USEHDRDNAT            #STACK(4)#;
          DEF  COLLATESEQ            #STACK(5)#;
          DEF  USINGFILE             #STACK(6)#;
          DEF  GIVINGFILE            #STACK(7)#;
          DEF  INPUTPROCOPT          #STACK(8)#;
          DEF  INPUTPROCSN1          #STACK(8)#;
          DEF  INPUTPROCSN2          #STACK(9)#;
          DEF  OUTPROCOPT            #STACK(10)#; 
          DEF  OUTPROCSN1            #STACK(10)#; 
          DEF  OUTPROCSN2            #STACK(11)#; 
          DEF  DUPLICATES           #STACK(12)#;
  
         CONTROL EJECT; 
PROC SECTEST (P1,P2); 
         #SECTEST IS CALLED FROM READ, WRITE, RELEASE, AND RETURN#
         #IT DIAGNOSES ILLEGAL REFERENCES TO SECONDARY STORAGE# 
         #P1 IS A STACK POINTER#
         #P2 IS ERROR MESSAGE NUMBER# 
         BEGIN
         ITEM P1, P2; 
         REG1 = TPOINTER(P1); 
         IF GET(DN$MAJMSEC,DNAT$,REG1) NQ SECSMSEC
         THEN RETURN; 
         REG2 = MOVERKEY(REG1); 
         IF REG2 NQ 0 AND 
            REG2 NQ 1 AND 
            REG2 NQ 3 
         THEN ERROR(SEVERE,P2,LINE(P1),COLUMN(P1)); 
         RETURN;
         END #SECTEST#
          PROC  SYSNAMETEST(ENTERFLAG); 
          ITEM  ENTERFLAG  B; 
         ITEM  SYSNTLERR B; 
         ITEM  SYSNTPROGNM  C(30);
         # SYSNAMETEST IS CALLED FROM CALL,CANCEL AND ENTER. IT 
           VERIFIES THAT A GIVEN PROGRAM/ROUTINE NAME WILL BE 
           ACCEPTABLE TO THE SYSTEM. THAT IS, THE NAME CONSISTS 
           OF A MAXIMUM OF SEVEN CHARACTERS WHICH ARE ALPHABETIC
           (EXCEPT SPACE), NUMERIC OR "-". DIAGNOSTICS ARE
           GENERATED FOR BAD NAMES BUT NO RECOVERY ACTION IS
           PERFORMED. 
         #
         BEGIN
         ITEM CH1 C(1); 
         # TEST FOR MAXIMUM LENGTH EXCEEDED # 
         REG1 = GET(PL$LENGTH,PLT$,LATTEMP);
         SYSNTLERR = FALSE; 
         IF REG1 GR 30
         THEN BEGIN 
              REG3 = 30;
              FOR REG2 = GET(PL$STRINGPTR,PLT$,LATTEMP) + 3 
                STEP 1 WHILE REG3 LS REG1 DO
                   BEGIN   # LOOK FOR TRAILING CHARS NOT BLANK #
                   IF REG1 LS REG3 + 10 
                   THEN 
                        REG4 = REG1 - REG3; 
                   ELSE 
                        REG4 = 10;  # NOT IN LAST WORD - USE FULL WORD #
                   C2 = GET(PLT$CHAR,PLTSTR$,REG2); 
                   IF C<0,REG4>C2 NQ "         "
                   THEN 
                        REG1 = 30;   # FOUND NON-BLANKS - TERMINATE#
                   REG3 = REG3 + 10;
                   END
              IF REG1 EQ 30 
              THEN
                   SYSNTLERR = TRUE;
              REG1 = 30;
              SET(PL$LENGTH,PLT$,LATTEMP,30); 
              END 
         SYSNTPROGNM = " ";   # BLANK OUT NAME #
         GETPLST(LATTEMP,LOC(SYSNTPROGNM));  # GET NAME # 
         # IGNORE ANY TRAILING BLANKS # 
         REG3 = REG1; 
         FOR REG2 = REG1 - 1 STEP -1 WHILE REG2 NQ 0 DO 
              BEGIN 
              IF C<REG2,1>SYSNTPROGNM EQ " "
              THEN
                   REG1 = REG1 - 1; 
              ELSE
                   REG2 = 1;  # TERMINATE LOOP - NON BLANK FOUND #
              END 
         IF REG3 NQ REG1
         THEN BEGIN   # SOME TRAILING BLANKS WERE REMOVED # 
              SET(PL$LENGTH,PLT$,LATTEMP,REG1); #CHANGE IN PLT# 
              END 
         IF REG1 GR 7 
         OR SYSNTLERR 
         THEN BEGIN 
              IF CCTFDL AND NOT ENTERFLAG 
              AND NOT SYSNTLERR 
              THEN BEGIN
                   FOR REG2 = 1 STEP 1 UNTIL CCTFDLTLEN DO
                        BEGIN   # SEARCH FOR NAME IN FDLT # 
                        XREF FUNC VIRTUAL;
                        # VIRTUAL MUST BE CALLED BECAUSE NORMAL PPARSER 
                          GET VIA SNAKES WILL NOT RETURN > 1 WORD # 
                        IF FDLTPROGNAME [VIRTUAL(FDLT$,REG2)] 
                          EQ SYSNTPROGNM
                             THEN 
                                  GOTO SYSNTPNOK;  # IN FDLT - NAME OK #
                        END 
                   END
              ERROR(ADVISORY,398,LINE$,COLUMN$);
              REG1 = 7; 
              # CHANGE PLT STRING LENGTH #
              SET(PL$LENGTH,PLT$,LATTEMP,7);
              END 
 SYSNTPNOK: 
         # VERIFY CHARACTERS A-Z,0-9 AND - #
         FOR REG2 = 0 STEP 1 UNTIL REG1 - 1 DO
              BEGIN 
              CH1 = C<REG2,1>SYSNTPROGNM; 
              IF CH1 EQ "+" OR
                CH1 EQ ":" OR 
                 CH1 EQ "/" OR
                 CH1 EQ " " OR
                 CH1 EQ "'" 
              THEN BEGIN
                   ERROR(ADVISORY,399,LINE$,COLUMN$); 
                   RETURN;
                   END
              END 
         IF C<0,1>SYSNTPROGNM LS "A" OR 
            C<0,1>SYSNTPROGNM GR "Z"
          THEN BEGIN
               ERROR(ADVISORY,399,LINE$,COLUMN$); 
               RETURN;
               END
         END #SYSNAMETEST#
          GOTO SUB[SUB$]; 
  
SUB1: 
#CANCEL ROUTINE#
          VD; 
          RETURN; 
SUB2: 
#CANCEL OPERAND#
          IF TCODE(S) EQ GDATAREF 
          THEN $DUMMY$ = NONNUMID(4); 
          ELSE BEGIN
               #A FIGURATIVE CONSTANT IS NOT PERMITTED HERE#
               IF GET(PL$FIGCON,PLT$,LATTEMP) NQ 0
               THEN  ERROR(SEVERE,173,LINE$,COLUMN$); 
               ELSE BEGIN 
                    # VERIFY SYSTEM ACCEPTABILITY IF NON NUMERIC #
                    IF NONNUMLIT NQ 0 
                  THEN  SYSNAMETEST(FALSE); 
                    END 
               END
               NG($CANCEL); 
               NGSTACK(S);
          RETURN; 
SUB3: 
#CALL ROUTINE#
          VD; 
          RETURN; 
SUB4: 
#CALL USING ID# 
          IF  STACK(S)  EQ SUBMARKER
          THEN S = STACK(S-1) - 1;
          I = TPOINTER(S);
          IF  GET(DN$TYPE,DNAT$,I) NQ ERRTYPE 
          THEN BEGIN
               FIX1 = GET(DN$LEVEL,DNAT$,I);
               IF FIX1 EQ 1 OR FIX1 EQ 77 
               THEN BEGIN 
                    PARAMCOUNT=PARAMCOUNT+1;
                    NG($PARAMETER); 
                    NGSTACK(S); 
                    END 
               ELSE  ERROR(SEVERE,886,TABLELINE,TABLECOLUMN); 
               END
          RETURN; 
SUB5: 
#CALL OPERAND#
          IF TCODE(S) EQ GDATAREF 
          THEN BEGIN
               $DUMMY$ = NONNUMID(4); 
               IF CCTFIPSLEVEL LS 3 
               THEN BEGIN 
                    # FIPS=3 SUPPORTS CALL IDENTIFIER # 
                    ERROR(TRIVIAL,699,LINE$,COLUMN$); 
                    END 
               IF NOT CCTFDL
               THEN BEGIN 
                    # THE FDL PARAMETER MUST BE SPECIFIED # 
                    # ON THE COBOL5 DIRECTIVE WHEN CALL IDENTIFIER #
                    # IS USED # 
                    ERROR(SEVERE,519,TABLELINE,TABLECOLUMN);
                    END 
               END
          ELSE BEGIN
               #A FIGURATIVE CONSTANT IS NOT PERMITTED HERE#
               IF GET(PL$FIGCON,PLT$,LATTEMP) NQ 0
               THEN  ERROR(SEVERE,173,LINE$,COLUMN$); 
               ELSE BEGIN 
                    # VERIFY SYSTEM COMPATIBLE NAME IF NON-NUMERIC #
                    IF NONNUMLIT NQ 0 
                 THEN  SYSNAMETEST(FALSE);
                    IF CCTFIPSLEVEL LS 2
                    THEN   # FIPS=2 SUPPORTS CALL LITERAL              #
                        BEGIN 
                        ERROR(TRIVIAL,416,LINE$,COLUMN$); 
                        END 
                    END 
               END
          NG($CALL);
          NGSTACK(S); 
          #GENERATE OVERFLOW LABEL REFERENCE AND SAVE LOCATION# 
          NGLABELREF((NEXTPNAT),0); 
          OVERFLOWLBL = PNATLENGTH; 
          G = G + 1;
          PARAMPATCH=G; 
          PARAMCOUNT=0; 
          RETURN; 
SUB27:  
#PARAMETER EPILOGUE#
          SETGT(PARAMPATCH,GTX(GSUBVERB,PARAMCOUNT,GCOUNT));
          FOR I =PARAMPATCH+1 STEP 1 UNTIL G
          DO BEGIN
               IF GETGT(I) EQ $PARAMETER
               THEN BEGIN 
                    SETGT(I,GTX(GVERB,PARAMCOUNT,GPARAM));
                    PARAMCOUNT=PARAMCOUNT-1;
                    END 
               END
          RETURN; 
SUB39:  
# CALL NO ON OVERFLOW # 
          NG($NOOVERFLOW);
          NGLABELDEF(OVERFLOWLBL);
          RETURN; 
SUB6: 
#RELEASE ROUTINE# 
          VD; 
          RETURN; 
SUB7: 
#RELEASE RECORD SUBR# 
          XSTACK(3,VALUE$); 
          # IF THE RECORD-NAME IS UNDEFINED OR AMBIGUOUS RETURN # 
          IF GET(DN$TYPE,DNAT$,VALUE$) EQ ERRTYPE 
          THEN RETURN;
          IF GET(DN$LEVEL,DNAT$,TABLENAME) NQ 1 OR
             GET(DN$MAJMSEC,DNAT$,TABLENAME) NQ FDMSEC
          THEN GOTO ERR1; 
          REG1 = GET(DN$AUXREF,DNAT$,TABLENAME);
          REG1 = FINDAUX(FILENAME,REG1);
          IF REG1 EQ 0
          THEN GOTO ERR1; 
          WR$F = GET(AX$FNATPTR,AUX$,REG1); 
          IF WR$F EQ 0  OR
             GET(FN$ABORT,FNAT$,WR$F) EQ 1
          THEN BEGIN
               ERROR(PROPAGATED,365,LINE$,COLUMN$); 
               RETURN;
               END
          # IT APPEARS THAT THE RECORD NAME IS OK # 
          REG2=GET(AX$FDPTR,AUX$,REG1); 
          IF GET(DN$LEVEL,DNAT$,REG2) NQ SDDESCR
          THEN BEGIN
               XSTACK(1,0); 
               XSTACK(2,0); 
               ERROR(SEVERE,333,LINE$,COLUMN$); 
               END
          XSTACK(1,GTX(GFILEREF,GET(DN$FNATPTR,DNAT$,REG2),0)); 
          XSTACK(2,GTX(GDATAREF,VALUE$,0)); 
          S=3;
          #MATCH SPECS OF RELEASE STMT VS. SPBT#
          RETURN; 
    ERR1: 
          IF GET(DN$TYPE,DNAT$,TABLENAME) NQ ERRTYPE
          THEN ERROR(SEVERE,330,LINE$,COLUMN$); 
          XSTACK(1,0);
          XSTACK(2,0);
          S = 3;
          RETURN; 
SUB8: 
#RELEASE FROM ROUTINE#
          #CHECK ATTRIBUTES OF SF DN# 
          IF GET(DN$TYPE,DNAT$,TABLENAME) EQ ERRTYPE
          THEN RETURN;
          IF GET(DN$MAJMSEC,DNAT$,TABLENAME) EQ FDMSEC  AND 
             GET(DN$SUBMSEC,DNAT$,TABLENAME) EQ 
                 GET(DN$SUBMSEC,DNAT$,STACK(3)) 
          THEN  ERROR(TRIVIAL,340,TABLELINE,TABLECOLUMN); 
         SECTEST(4,354);
          NGMOVE; 
          NGSTACK(4); 
          NGSTACK(2); 
          RETURN; 
SUB9: 
#RELEASE EPILOGUE ROUTINE#
          NG($RELEASE); 
          NGSTACK(1); 
          NGSTACK(2); 
          RETURN; 
SUB10:  
#SORT ROUTINE#
          VD; 
          NG($SORT);
          XSTACK(5,$NULL);
          XSTACK(6,$NULL);
          XSTACK(7,$NULL);
          XSTACK(8,0);
          XSTACK(10,0); 
          XSTACK(12,$NULL); 
          XSTACK(1,0);
          XSTACK(2,0);
          IF GET(PN$DECLARATV,PNAT$,LASTPNDEF) EQ 1 
          THEN  ERROR(SEVERE,318,LINE$,COLUMN$);
          IF GET(PN$SORTPROC,PNAT$,LASTPNDEF) EQ 1
          THEN  ERROR(SEVERE,319,LINE$,COLUMN$);
          RETURN; 
SUB11:  
#SORT FILE ROUTINE# 
          #CHECK ATTRIBUTES OF DN#
          XSTACK(1,VALUE$); 
          XSTACK(2,0);
          # IF THE FILE-NAME IS UNDEFINED OR AMBIGUOUS RETURN # 
          IF GET(DN$TYPE,DNAT$,VALUE$) EQ ERRTYPE 
          THEN RETURN;
          IF GET(DN$LEVEL,DNAT$,VALUE$) NQ SDDESCR
          THEN ERROR(SEVERE,320,LINE$,COLUMN$); 
          ELSE BEGIN
               REG1=GET(DN$FNATPTR,DNAT$,VALUE$); 
               XSTACK(2,REG1);
               END
          NGGTX(GFILEREF,STACK(2),0); 
          RETURN; 
SUB12:  
#SORT KEY PROLOGUE ROUTINE# 
          #REQUEST NEXT DNAT# 
          REG1=NEXTDNAT;
          NGDATAREF(REG1);
          XSTACK(3,REG1); 
          #INITIALIZE THE DNAT HDR ENTRY FOR SORT KEY LIST# 
          SET(DN$TYPE,DNAT$,REG1,NONDATA);
          SET(DN$LEVEL,DNAT$,REG1,SORTKEYHDR);
          RETURN; 
SUB13:  
#SORT KEY ROUTINE#
          #CHECK ATTRIBUTES OF DN#
          # IF KEY IS UNDEFINED OR AMBIGUOUS RETURN # 
          REG1 =  GET(DN$TYPE,DNAT$,VALUE$);
          IF REG1 EQ ERRTYPE
          THEN RETURN;
          IF REG1 EQ COMP4
          THEN BEGIN
               # A COMP-4 ITEM CANNOT BE USED AS# 
               # A KEY IN A SORT OR MERGE STATEMENT#
               ERROR(SEVERE,28,LINE$,COLUMN$);
               RETURN;
               END
          #KEY DN MUST BE IN SORT FILE# 
          IF NOT(GET(DN$MAJMSEC,DNAT$,VALUE$) EQ FDMSEC AND 
                 GET(DN$SUBMSEC,DNAT$,VALUE$) EQ
                 GET(FN$SMSECNO,FNAT$,STACK(2)))
          THEN  ERROR(SEVERE,321,LINE$,COLUMN$);
          # DATA ITEMS USED AS KEYS IN A SORT OR MERGE STATEMENT #
          # MUST NOT BE TABLE ITEMS.                             #
          IF GET(DN$OCCURS,DNAT$,VALUE$) EQ 1  OR 
             GET(DN$SDEPTH,DNAT$,VALUE$) NQ 0 
          THEN ERROR(SEVERE,322,LINE$,COLUMN$); 
         REG2 = ATTACHAUX(KEYHDRDNAT);
         # KEY AUX ENTRIES ARE IN INVERSE ORDER # 
          #BUILD AUX ENTRY AT POINT TO SORT KEY DN# 
          SET(AX$TTYPE,AUX$,REG2,AUXSRTKEYTYP); 
          SET(AX$SKEYSEQ,AUX$,REG2,KEYFLAG);
          SET(AX$SKEYDNAT,AUX$,REG2,VALUE$);
          REG3=STACK(3);
          FIX1 = GET(DN$KEYCOUNT,DNAT$,REG3) + 1; 
          SET(DN$KEYCOUNT,DNAT$,REG3,FIX1); 
          RETURN; 
SUB14:  
#SORT KEY EPILOGUE ROUTINE# 
          RETURN; 
SUB40:  
#SORT DUPLICATES IN SEQUENCE ROUTINE# 
          XSTACK(12,$DUPLICATES); 
          RETURN; 
SUB15:  
#SORT COLLATING SEQUENCE ROUTINE# 
          IF GET(DN$TYPE,DNAT$,VALUE$) EQ ERRTYPE 
          THEN RETURN;
          IF GET(DN$LEVEL,DNAT$,VALUE$) NQ ALPHNAME 
          THEN BEGIN
               ERROR(SEVERE,305,LINE$,COLUMN$); 
               RETURN;
               END
          XSTACK(5,GTX(GDATAREF,VALUE$,0)); 
          RETURN; 
SUB16:  
#SORT INPUT SN1 ROUTINE#
          #CHECK ATTRIBUTES OF PN#
          # IF THE PROCEDURE IS UNDEFINED OR AMBIGUOUS RETURN # 
          IF VALUE$ EQ 0
          THEN RETURN;
          #IP PROC SHOULD BE SECTION NAME#
          IF  GET(PN$PROCKIND,PNAT$,VALUE$) EQ 0
          THEN  ERROR(SEVERE,309,LINE$,COLUMN$);
          XSTACK(8,VALUE$); 
          XSTACK(9,VALUE$); 
          RETURN; 
SUB17:  
#SORT INPUT SN2 ROUTINE#
          # IF THE PROCEDURE IS UNDEFINED OR AMBIGUOUS RETURN # 
          IF VALUE$ EQ 0
          THEN RETURN;
          XSTACK(9,VALUE$); 
          IF  GET(PN$PROCKIND,PNAT$,VALUE$) EQ 0
          THEN  ERROR(SEVERE,309,LINE$,COLUMN$);
          RETURN; 
SUB18:  
#SORT INPUT SN EPILOGUE ROUTINE#
          #CHECK BOUNDS OF IP PROC VS.SPBT# 
          #CHECK SRT FN VS. REC.NAME USED BY RELEASE# 
          #IN SPBT ENTRY MATCHING THIS IP PROC# 
          RETURN; 
SUB19:  
#SORT USING ROUTINE#
          REG1=NEXTDNAT;
          XSTACK(4,REG1); 
          XSTACK(6,GTX(GDATAREF,REG1,0)); 
          #INITIALIZE DNAT HDR FOR USING FILESNAMES#
          SET(DN$TYPE,DNAT$,REG1,NONDATA);
          SET(DN$LEVEL,DNAT$,REG1,SORTUSINGHDR);
          RETURN; 
SUB28:  
#MERGE IO FILE SUBR#
          #MUST BE DN-REF TO A FILE#
          IF GET(DN$LEVEL,DNAT$,VALUE$) NQ FDDESCR
          THEN RETURN;
          ELSE BEGIN
               #FILE NAME MUST NOT BE REPEATED WITHIN MRG STMT# 
               IF GET(DN$USINGFNC,DNAT$,STACK(4)) NQ 0
               THEN BEGIN 
                    SMCURRFNAT=GET(DN$FNATPTR,DNAT$,VALUE$);
                    SMAUXBASE=GET(DN$AUXREF,DNAT$,STACK(4));
                    SMAUXLIMIT = GET(DN$USINGFNC,DNAT$,STACK(4)); 
                    FOR SMAUXINDEX = 1 STEP 1 UNTIL SMAUXLIMIT
                    DO BEGIN
                       FIX1 = GET(AX$FNFNAT,AUX$,SMAUXBASE);
                       IF FIX1 EQ SMCURRFNAT
                       THEN ERROR (SEVERE,327,LINE$,COLUMN$); 
                       SMAUXBASE = GET(AX$TNEXTPTR,AUX$,SMAUXBASE); 
                       END
                    END 
               RETURN;
               END
SUB24:  
#SORT GIVING FILE ROUTINE#
          IF GET(DN$LEVEL,DNAT$,VALUE$) EQ FDDESCR
          THEN BEGIN
               SMCURRFNAT=GET(DN$FNATPTR,DNAT$,VALUE$); 
               XSTACK(7,GTX(GFILEREF,SMCURRFNAT,0));
              XLINE(7,LINE$); 
              XCOLUMN(7,COLUMN$); 
               END
          GOTO SMIOFILECHK; 
SUB20:  
#SORT USING FILE ROUTINE# 
          #FALLING THRU#
SMIOFILECHK:  
          #CHK ATTRIBUTES OF FILE#
          IF GET(DN$LEVEL,DNAT$,VALUE$) EQ SDDESCR
          THEN BEGIN
               ERROR(SEVERE,310,LINE$,COLUMN$); 
               RETURN;
               END
          IF GET(DN$LEVEL,DNAT$,VALUE$) NQ FDDESCR  OR
             GET(DN$TYPE,DNAT$,VALUE$) EQ ERRTYPE 
          THEN BEGIN
               ERROR(SEVERE,316,LINE$,COLUMN$); 
               RETURN;
               END
          SMCURRFNAT=GET(DN$FNATPTR,DNAT$,VALUE$);
          IF STACK(2) NQ 0
          THEN BEGIN
               # CHECK IF THE FILES HAVE THE SAME RECORD LENGTH#
               IF GET(FN$ACCUMMAX,FNAT$,SMCURRFNAT) NQ
                  GET(FN$ACCUMMAX,FNAT$,STACK(2)) 
               THEN ERROR(SEVERE,311,LINE$,COLUMN$);
               END
          #SHOULD MULTIPLE FILE REEL RULE BE CHECKED# 
          IF GET(FN$MFILPOS,FNAT$,SMCURRFNAT) NQ 0 AND
             STACK(6)  NQ $NULL AND 
             GET(DN$USINGMFR,DNAT$,STACK(4)) EQ 1 
          THEN BEGIN
               SMAUXBASE=GET(DN$AUXREF,DNAT$,STACK(4)); 
                    SMAUXLIMIT = GET(DN$USINGFNC,DNAT$,STACK(4)); 
                    FOR SMAUXINDEX = 1 STEP 1 UNTIL SMAUXLIMIT
                    DO BEGIN
                       IF GET(AX$SMPLT,AUX$,SMAUXBASE) EQ 
                          GET(FN$DVCEPTR,FNAT$,SMCURRFNAT)
                       THEN ERROR (SEVERE,329,LINE$,COLUMN$); 
                       SMAUXBASE = GET(AX$TNEXTPTR,AUX$,SMAUXBASE); 
                       END
               IF GET(FN$DVCEPTR,FNAT$,SMCURRFNAT) EQ 
                  GET(FN$DVCEPTR,FNAT$,STACK(2))
               THEN  ERROR(SEVERE,329,LINE$,COLUMN$); 
               END
          #IF THE FILE ENTRY IN THE FNAT WAS CREATED BY THE  #
          #D-TRANSLATOR, SET THE FN$VOPEN, FN$VREAD AND      #
          #FN$VCLOSE FIELDS IN THE FNAT.                     #
          IF GET(FN$SSCHEMA,FNAT$,SMCURRFNAT) EQ 1
          THEN BEGIN
               SET(FN$VOPEN,FNAT$,SMCURRFNAT,1);
               SET(FN$VREAD,FNAT$,SMCURRFNAT,1);
               SET(FN$VCLOSE,FNAT$,SMCURRFNAT,1); 
               END
          RETURN; 
SUB42:  
#SORT USING FILE NON-STANDARD ROUTINE#
          IF GET(FN$ORG,FNAT$,SMCURRFNAT) NQ SEQUENTIAL 
          THEN BEGIN
               #THE USE OF A NON-SEQUENTIAL FILE# 
               #IN THE USING PHRASE OF THE SORT#
               #STATEMENT IS NON-STANDARD COBOL#
               ERROR(JOD,467,LINE$,COLUMN$);
               END
          RETURN; 
SUB43:  
#MERGE USING FILE ILLEGAL ROUTINE#
          IF GET(FN$ORG,FNAT$,SMCURRFNAT) NQ SEQUENTIAL 
          THEN BEGIN
               #THE USE OF A NON-SEQUENTIAL FILE# 
               #IN THE USING PHRASE OF THE MERGE# 
               #STATEMENT IS ILLEGAL# 
               ERROR(JOD,491,LINE$,COLUMN$);
               END
           RETURN;
SUB29:  
#SM BLD LIST FN SUBR# 
          #BUILD AUX LIST OF SRT MRG USING FILES# 
          SMCURRFNAT=GET(DN$FNATPTR,DNAT$,VALUE$);
         SMAUXINDEX = ATTACHAUX(USEHDRDNAT);
          SMDNATXHDR=STACK(4);
          FIX1 = GET(DN$USINGFNC,DNAT$,SMDNATXHDR) + 1; 
          SET(DN$USINGFNC,DNAT$,SMDNATXHDR,FIX1); 
          IF GET(FN$MFILPOS,FNAT$,SMCURRFNAT) NQ 0
          THEN BEGIN
               SET(DN$USINGMFR,DNAT$,SMDNATXHDR,1); 
               FIX1 = GET(FN$DVCEPTR,FNAT$,SMCURRFNAT); 
               SET(AX$SMPLT,AUX$,SMAUXINDEX,FIX1);
               END
          SET(AX$TTYPE,AUX$,SMAUXINDEX,AUXUSEFNTYPE); 
          SET(AX$FNFNAT,AUX$,SMAUXINDEX,SMCURRFNAT);
          RETURN; 
SUB21:  
#SORT OUTPUT SN1 ROUTINE# 
          # IF THE PROCEDURE IS UNDEFINED OR AMBIGUOUS RETURN # 
          IF VALUE$ EQ 0
          THEN RETURN;
          XSTACK(10,VALUE$);
          XSTACK(11,VALUE$);
          IF  GET(PN$PROCKIND,PNAT$,VALUE$) EQ 0
          THEN  ERROR(SEVERE,309,LINE$,COLUMN$);
          RETURN; 
SUB22:  
#SORT OUTPUT SN2 ROUTINE# 
          IF VALUE$ EQ 0
          THEN RETURN;
          XSTACK(11,VALUE$);
          IF  GET(PN$PROCKIND,PNAT$,VALUE$) EQ 0
          THEN  ERROR(SEVERE,309,LINE$,COLUMN$);
          RETURN; 
SUB23:  
#SORT OUTPUT SN EPILOGUE# 
          #CHECK BOUNDS OF OP PROC VS SPBT# 
          #CHECK SRT FN VS FILE NAME USED BY RETURN STMT IN#
          #SPBT ENTRY MATCHING THIS OP PROC#
          RETURN; 
SUB25:  
#SORT STMT EPILOGUE#
          IF TPOINTER(7) NQ 0 THEN
         BEGIN
         FIX1 = GET(FN$ORG,FNAT$,TPOINTER(7));
         #STACK[7] IS GIVING FILE GT FILEREF ATOM#
         IF FIX1 EQ DIRECT OR FIX1 EQ WORD$ADDR THEN
           BEGIN
           ERROR(SEVERE,644,LINE(7),COLUMN(7)); 
           RETURN;
           END
         ELSE 
         IF FIX1 NQ SEQUENTIAL THEN ERROR(JOD,643,LINE(7),COLUMN(7)); 
         #IF GIVING FILE IS INDEXED OR ACTUALKEY, MAJOR S/M KEY  #
         #MUST BE ASCENDING AND HAVE SAME OFFSET AND LENGTH AS THE# 
         #PRIME KEY FOR THE FILE.                                 # 
         IF FIX1 EQ INDEXED OR FIX1 EQ ACTUAL$KEY THEN
           BEGIN
           FIX1 = GET(FN$RECPTR,FNAT$,TPOINTER(7)); 
           FIX2 = GET(DN$AUXREF,DNAT$,STACK(3));
         FIX4 = FIX2; 
         FOR FIX4 = FIX4 WHILE FIX4 NQ 0 DO 
           BEGIN
           FIX3 = FIX4; 
           FIX4 = GET(AX$TNEXTPTR,AUX$,FIX4); 
           END
         FIX3 = GET(AX$SKEYDNAT,AUX$,FIX3); 
           IF GET(AX$SKEYSEQ,AUX$,FIX2) NQ 1   OR 
              GET(DN$WORDOFF,DNAT$,FIX1) NQ 
              GET(DN$WORDOFF,DNAT$,FIX3)       OR 
              GET(DN$ITMLEN,DNAT$,FIX1)  NQ 
              GET(DN$ITMLEN,DNAT$,FIX3)        THEN 
               BEGIN
               ERROR(SEVERE,645,LINE(7),COLUMN(7)); 
               RETURN;
               END
           END
         END
          NGSTACK(5); 
          NGSTACK(6); 
          NGSTACK(7); 
          NGSTACK(12);
          DPATCH=G+1; 
          IF STACK(8) NQ 0
          THEN BEGIN
               #SORT PERFORM IP ATOM# 
               NG($PERFORMIP);
               NGPROCREF(STACK(8),0); 
               NGPROCREF(STACK(9),0); 
               NGLABELREF((NEXTPNAT),0);
               NGLABELREF(0,0); 
               NGLABELDEF(PNATLENGTH);
               END
          IF STACK(10) NQ 0 
          THEN BEGIN
               #SORT PERFORM OP ATOM# 
               NG($PERFORMOP);
               NGPROCREF(STACK(10),0);
               NGPROCREF(STACK(11),0);
               NGLABELREF((NEXTPNAT),0);
               NGLABELREF(0,0); 
               NGLABELDEF(PNATLENGTH);
               END
          RETURN; 
SUB26:  
#MERGE ROUTINE# 
          VD; 
          NG($MERGE); 
          XSTACK(5,$NULL);
          XSTACK(6,$NULL);
          XSTACK(7,$NULL);
          XSTACK(8,0);
          XSTACK(10,0); 
          XSTACK(12,$NULL); 
          XSTACK(1,0);
          XSTACK(2,0);
          IF GET(PN$DECLARATV,PNAT$,LASTPNDEF) EQ 1 
          THEN  ERROR(SEVERE,318,LINE$,COLUMN$);
          IF GET(PN$SORTPROC,PNAT$,LASTPNDEF) EQ 1
          THEN  ERROR(SEVERE,319,LINE$,COLUMN$);
          RETURN; 
SUB30:  
#TEST SPBT STATUS#
          REG1 = 1; 
          FOR $DUMMY$ = 0 WHILE REG1 LQ SPBTLENGTH AND REG1 NQ 0
          DO   BEGIN
               IF LINE$   EQ GET(SPBT$LINE,SPBT$,REG1) AND
                  COLUMN$ EQ GET(SPBT$COLUMN,SPBT$,REG1)
               THEN BEGIN 
                    # FORMERLY SPBT$STATUS (SET IN PPBEGIN) WAS CHECKED#
                    # FOR 1 AND FREEZFLAG SET 0 IF ON - DELETED SINCE  #
                    # THE ASSOCIATED DIAGS ARE NOW NON-ANSI            #
                    REG1 = 0; 
                    END 
               ELSE REG1 = REG1 + 1;
               END
          RETURN; 
SUB31:  
#ENTER ROUTINE# 
          VD; 
          RETURN; 
SUB32:  
#ENTER LITERAL NAME#
          #THE LITERAL MUST BE NONNUMERIC AND NOT A FIG CON#
          IF GET(PL$FIGCON,PLT$,LATTEMP) NQ 0 
          THEN BEGIN
               ERROR(SEVERE,173,LINE$,COLUMN$); 
               #CHANGE STACK ENTRY FOR LATER USE# 
               XSTACK(S,$NULL); 
               END
          ELSE BEGIN
               #NONNUMLIT WILL SET UP THE CGL DNAT ENTRY# 
               IF NONNUMLIT EQ 0
               THEN XSTACK(S,$NULL);
               END
          RETURN; 
SUB33:  
#ENTER SYS NAME#
          #BUILD ATOM IN STACK# 
          LATTEMP = VALUE$; 
          S = S + 1;
          XSTACK(S,GTX(GSYSREF,(NEXTLAT),0)); 
          XLINE(S,LINE$); 
          XCOLUMN(S,COLUMN$); 
          #FIX UP APPROPRIATE CGL DNAT ENTRY# 
          REG1 = GET(PL$LENGTH,PLT$,LATTEMP); 
          SET(DN$ITMLEN,DNAT$,DNATLENGTH,REG1); 
          SET(DN$TYPE,DNAT$,DNATLENGTH,NONDATA);
          RETURN; 
SUB34:  
#ENTER PROLOGUE#
          #GENERATE VERB ATOM ITSELF# 
          NG($ENTER); 
          #GENERATE ROUTINE NAME ATOM - LAST IN STACK#
          NGSTACK(S); 
          # VERIFY SYSTEM COMPATIBLE NAME # 
          SYSNAMETEST(TRUE);
          #DO WE HAVE A LANGUAGE NAME - S=2 IF YES# 
          IF S EQ 1 
          THEN BEGIN
               #ASSUME COMPASS SINCE NO LANGUAGE NAME#
               TEMPATOM = $NULL;
               #DIAGNOSE ABSENCE AS NON STANDARD# 
               IF REPORTMODE EQ 0 THEN
               ERROR(JOD,589,VERBLINE,VERBCOLUMN);
               END
          ELSE BEGIN
               #CHECK VALIDITY OF LANG NAME UNLESS PREVIOUS ERROR#
               IF STACK(1) NQ $NULL 
               THEN BEGIN 
                    #NO ERROR - GET INDEX AND LENGTH FOR NAME#
                    REG1 = GET(L$PLT,LAT$,TPOINTER(1)); 
                    REG2 = GET(PL$LENGTH,PLT$,REG1);
                    #ACCESS CHARACTER STRING ONLY IF RIGHT SIZE#
                    IF REG2 EQ 4 OR REG2 EQ 7 OR REG2 EQ 9
                    THEN GETPLST(REG1,LOC(C2)); 
                    #CHECK VARIOUS POSSIBILITIES FOR LANG NAME# 
                    IF REG2 EQ 7 AND C<0,7>C2 EQ "COMPASS"
                         THEN TEMPATOM = $NULL; 
                    ELSE IF REG2 EQ 9 AND C<0,9>C2 EQ "FORTRAN-R" 
                         THEN TEMPATOM = $FORTRANR; 
                    ELSE IF REG2 EQ 9 AND C<0,9>C2 EQ "FORTRAN-X" 
                         THEN TEMPATOM = $FORTRANX; 
                    ELSE IF REG2 EQ 4 AND C<0,4>C2 EQ "FTN5"
                         THEN TEMPATOM = $FTN5; 
                    ELSE BEGIN
                         #NOT A VALID LANG NAME - ASSUME COMPASS# 
                         ERROR(TRIVIAL,587,LINE(1),COLUMN(1));
                         TEMPATOM = $NULL;
                         END
                    END 
              END 
          #GENERATE LANGUAGE NAME SUBVERB ATOM# 
          NG(TEMPATOM); 
          #LEAVE ROOM FOR AND SAVE INDEX OF PARAMETER COUNT SUBVERB#
          G = G + 1;
          PARAMPATCH = G; 
          #INITIALIZE PARAMETER COUNTER#
          PARAMCOUNT = 0; 
          #RESET STACK SO ALL PARAMETERS IN STACK[1]# 
          S = 0;
          S$ = 0; 
          RETURN; 
SUB35:  
#ENTER LITERAL PARAM# 
          #SET VERB CODE TO FORCE LITERAL POOLING#
          SET (L$VCODE, LAT$, LATLENGTH, 3);
          #IF LITERAL IS NONUMERIC OR FIGCON SET IT UP FOR LPOOLER# 
          REG1 = GET(PL$CODE,PLT$,LATTEMP); 
          IF REG1 EQ PLTQUOTEDLIT OR REG1 EQ PLTFGCONZERO 
          THEN BEGIN
               #SAME ATTRIBUTES AS LITERAL ITSELF#
               REG2 = GET(PL$LENGTH,PLT$,LATTEMP);
               SET(DN$ITMLEN,DNAT$,DNATLENGTH,REG2);
               SET(DN$TYPE,DNAT$,DNATLENGTH,ALPHNUM); 
               END
          RETURN; 
SUB36:  
#ENTER REF PARAM# 
          #ASSUME WE HAVE NEITHER A PROC NOR A FILE REF#
          TRUEFALSE = 0;
          #CHECK FOR UNDEFINED OR AMBIGUOUS#
          IF VALUE$ NQ 0
          AND REPORTMODE EQ 0 
          THEN BEGIN
               #DO WE HAVE A PROCEDURE NAME OR A DATA NAME# 
               IF GET(IN$PROCNAME,INT$,IP$) EQ 1
               THEN BEGIN 
                    #BUILD PROCEDURE REF ATOM - RETURN TRUE#
                    TRUEFALSE = 1;
                    XSTACK(1,GTX(GPROCREF,VALUE$,0)); 
                    END 
               ELSE BEGIN 
                    #A DATA REF - RETURN TRUE IF WE HAVE A FILE NAME# 
                    USINGLINE = LINE$;
                    USINGCOL = COLUMN$; 
                    IF GET(DN$LEVEL,DNAT$,VALUE$) EQ FDDESCR
                    THEN BEGIN
                         #BUILD FILE REF ATOM - RETURN TRUE#
                         TRUEFALSE = 1; 
                         #GET CORRECT FNAT INDEX# 
                         REG1 = GET(DN$FNATPTR,DNAT$,VALUE$); 
                         XSTACK(1,GTX(GFILEREF,REG1,0));
                         END
                    END 
               END
          RETURN; 
SUB37:  
#ENTER ID PARAM#
          #ONLY INDEX NAMES ARE NOT ALLOWED AS PARAMETERS#
          IF GET(DN$TYPE,DNAT$,TABLENAME) EQ INDXNAME 
          THEN ERROR(SEVERE,588,TABLELINE,TABLECOLUMN); 
          RETURN; 
SUB38:  
#ENTER PARAMETER# 
          #INCREMENT PARAMETER COUNTER# 
          PARAMCOUNT = PARAMCOUNT + 1;
          #GENERATE PARAMETER VERB AND OPERAND# 
          NG($PARAMETER); 
          NGSTACK(1); 
          #RESET STACK FOR NEXT PARAMETER#
          S = 0;
          S$ = 0; 
          RETURN; 
 SUB41: 
 #USING VARIABLE SUB CHK# 
          IF USENGSUBVFLG EQ 1
          THEN
              BEGIN 
              ERROR(SEVERE,212,USINGLINE,USINGCOL); 
              ERRORFLAG = 1;
              END 
          RETURN; 
          END #SET8#
          TERM
