*DECK SET7
USETEXT CCTTEXT 
USETEXT DNTEXT
USETEXT PPTEXT
    PROC SET7;
         CONTROL PACK;
          BEGIN 
  
      #----------------------------------------------------------------#
      #                                                                #
      # "INCLUDE" SOME COMMON DECKS                                    #
      #                                                                #
      #----------------------------------------------------------------#
  
*CALL ASSEMOP 
*CALL DPPPDDATA 
*CALL PPCOMMON2 
*CALL AUXTVALS
*CALL DNATVALS
*CALL FNATVALS
*CALL PLTVALS 
      CONTROL EJECT;
  
      #----------------------------------------------------------------#
      #                                                                #
      # GLOBAL DATA DECLARATIONS FOR SET7                              #
      #                                                                #
      #----------------------------------------------------------------#
  
         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, SUB44, SUB45, 
         SUB46, SUB47, SUB48, SUB49, SUB50, 
         SUB51, SUB52, SUB53, SUB54, SUB55, 
         SUB56, SUB57, SUB58, SUB59,SUB60,
         SUB61; 
      CONTROL EJECT;
  
      #----------------------------------------------------------------#
      #                                                                #
      # GLOBAL DEFINITIONS FOR SET7                                    #
      #                                                                #
      #----------------------------------------------------------------#
  
          DEF  RWREAD          #74#;
          DEF  RWRETURN        #162#; 
          DEF  RWOPEN          #71#;
          DEF  RWCLOSE         #102#; 
          DEF  RWSTART         #316#; 
          DEF  RWDELETE        #318#; 
          DEF  RWWRITE         #134#; 
          DEF  RWREWRITE       #322#; 
  
          DEF    COND1   #B<1,1>READCOND EQ 1#; 
          DEF    COND2   #B<2,1>READCOND EQ 1#; 
          DEF    COND3   #B<3,1>READCOND EQ 1#; 
          DEF    COND4   #B<4,1>READCOND EQ 1#; 
          DEF    COND5   #B<5,1>READCOND EQ 1#; 
          DEF    COND6   #B<6,1>READCOND EQ 1#; 
          DEF D815   #815#; 
          DEF D816   #816#; 
          DEF D827   #827#; 
          DEF D828   #828#; 
          DEF D829   #829#; 
          DEF D830   #830#; 
          DEF D831   #831#; 
          DEF D832   #832#; 
      CONTROL EJECT;
  
      PROC DEBUGFILL; 
          BEGIN 
          #IT FILLS DEBUG-ITEM WITH SPACES AND STORES THE#
          #STATEMENT LINE IN DEBUG-LINE.# 
          NGMOVE; 
          NGLITREF(DLATSPACE);
          NGDATAREF(DEBUGITEM); 
          NGMOVE; 
          LATTEMP=VERBLINE; 
          REG1=DEBUGLINE; 
          NG(CREATELDL(REG1,1));
          SET(L$VCODE,LAT$,LATLENGTH,2);
          NGDATAREF(DEBUGLINE); 
          END #DEBUGFILL# 
      CONTROL EJECT;
  
      PROC FILEDEBUG(ANS);
          BEGIN 
          ITEM ANS      I;
          ITEM   I      I;
          FIX1 = GET(DN$DEBUG,DNAT$,FILEADDRESS); 
          IF DEBUGFLAG EQ 1 AND FIX1 EQ 1 
          THEN BEGIN
               REG1=GET(DN$AUXREF,DNAT$,FILEADDRESS); 
               I=FINDAUX(AUXDEBUG,REG1);
               IF I EQ  0 
               THEN  ERROR(SEVERE,94,LINE(1),COLUMN(1));
               ELSE BEGIN 
                    DEBUGFILL;
                    NGMOVE; 
                    NGLITREF(GET(AX$LATPTR,AUX$,I));
                    NGDATAREF(DEBUGNAME); 
                    IF VERBCODE EQ RWREAD  OR  VERBCODE EQ RWRETURN 
                    THEN BEGIN
                         NG($MOVERECORD); 
                         NGGTX(GFILEREF,WR$F,0);
                         NGDATAREF(DEBUGCONTS); 
                         END
                    NG($PERFORM); 
                    FIX1 = GET(AX$DEBUGPROC,AUX$,I);
                    NGPROCREF(FIX1,0);
                    NGPROCREF(FIX1,0);
                    NGLABELREF((NEXTPNAT),0); 
                    NGLABELDEF(PNATLENGTH); 
                    ANS=1;
                    RETURN; 
                    END 
               END
          ANS=0;
          END #FILEDEBUG# 
      CONTROL EJECT;
  
      PROC DEBUGUSEPROC;
          BEGIN 
          #IT FILLS DEBUG-CONTENTS WITH THE LITERAL -USE PROC-# 
          DEBUGFILL;
          NGMOVE; 
          NGLITREF(DLATUSEPROC);
          NGDATAREF(DEBUGCONTS);
          END #DEBUGUSEPROC#
      CONTROL EJECT;
  
      FUNC LEFTMOST(P1,P2) I; 
  
      #----------------------------------------------------------------#
      #                                                                #
      # NAME                                                           #
      #     LEFTMOST                                                   #
      #                                                                #
      # INPUT                                                          #
      #     P1 - DNAT INDEX OF A DATA NAME                             #
      #     P2 - DNAT INDEX OF A DATA NAME                             #
      #                                                                #
      # DOES                                                           #
      #     RETURNS 1 IF DATA NAME WHOSE DNAT INDEX IS P1 IS THE       #
      #     LEFTMOST PART AND SUBORDINATE TO THE DATA NAME WHOSE       #
      #     DNAT INDEX IS P2, OTHERWISE RETURNS 0.                     #
      #                                                                #
      #----------------------------------------------------------------#
  
          BEGIN 
  
          ITEM P1            I; # FIRST INPUT PARAMETER                #
          ITEM P2            I; # SECOND INPUT PARAMETER               #
  
          LEFTMOST = 0; 
          IF GET(DN$MAJMSEC,DNAT$,P1) EQ GET(DN$MAJMSEC,DNAT$,P2) AND 
             GET(DN$SUBMSEC,DNAT$,P1) EQ GET(DN$SUBMSEC,DNAT$,P2) AND 
             GET(DN$BYTEOFFS,DNAT$,P1) EQ GET(DN$BYTEOFFS,DNAT$,P2) AND 
             P1 GR P2 
          THEN
              BEGIN 
              CONTROL IFEQ CB5$CDCS,"CDCS2";
              IF GET(FN$SSCHEMA,FNAT$,WR$F) EQ 1
              THEN
                  BEGIN 
                  IF GET(DN$SSMRKEY,DNAT$,P1) EQ 0
                  THEN
                      BEGIN 
                      # IN THE START STATEMENT, THE DATA NAME          #
                      # SPECIFIED IN THE KEY PHRASE IS A PARTIAL       #
                      # KEY BUT WAS NOT SPECIFICALLY DESIGNATED        #
                      # AS A LEGAL MAJOR KEY IN THE SUBSCHEMA.         #
                      ERROR(SEVERE,562,LINE$,COLUMN$);
                      END 
                  END 
              CONTROL FI; 
              LEFTMOST = 1; 
              END 
          RETURN; 
          END   #LEFTMOST#
      CONTROL EJECT;
  
      FUNC ALTKEY(P1,P2) I; 
          BEGIN 
          # RETURN 1 IF P1 IS AN ALTERNATE KEY                         #
          # RETURN 2 IF P1 IS THE LEFTMOST PART OF 1 ALTERNATE KEY     #
          # RETURN >2 IF P1 IS THE LEFTMOST PART OF MORE THAN 1 ALTER- #
          #           NATE KEY                                         #
          # RETURN 0 IF P1 IS NOT AN ALTERNATE KEY NOR THE LEFTMOST    #
          #          PART OF AN ALTERNATE KEY                          #
          ITEM  P1, P2; 
          ITEM   T1, T2, T3;
          T1 = GET(FN$ALTKPTR,FNAT$,P2);
          T3 = 0; 
          FOR $DUMMY$ = 0 WHILE T1 NQ 0 
          DO   BEGIN
               T2 = GET(AX$ALTKEY,AUX$,T1); 
               IF P1 EQ T2
               THEN BEGIN 
                    ALTKEY = 1; 
                    RETURN; 
                    END 
               IF LEFTMOST(P1,T2) EQ 1
               THEN T3 = T3 + 2;
               T1 = GET(AX$TNEXTPTR,AUX$,T1); 
               END
          ALTKEY = T3;
          IF GET(DN$TYPE,DNAT$,P1) NQ ALPHNUM AND STACK(4) NQ $KEYEQ
          THEN ERROR(JOD,71,LINE$,COLUMN$); 
          RETURN; 
          END   #ALTKEY#
      CONTROL EJECT;
  
      PROC WRITEGTEXT;
          BEGIN 
          IF DEBUGFLAG EQ 1 
          THEN DEBUGUSEPROC;
          IF WORD [0] EQ $WRITE 
          THEN REG1 = 5;
          ELSE REG1 = 3;
          IF WORD [0] EQ $READNEXT
             OR 
             WORD [0] EQ $READKEY 
          THEN REG1 = 2;
          FOR REG2 = 0 STEP 1 UNTIL REG1 DO 
              BEGIN 
              NG(WORD[REG2]); 
              END 
          END #WRITEGTEXT#
      CONTROL EJECT;
  
      PROC INVKEYGTEXT; 
          BEGIN 
               NG($INVALIDKEY); 
               NGGTX(GFILEREF,STACK(1),0);
               IF ENDADDRESS EQ 0 
               THEN ENDADDRESS=NEXTPNAT;
               NGLABELREF(ENDADDRESS,GFALSE); 
               NSFLAG = 1;
          END #INVKEYGTEXT# 
      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#
      CONTROL EJECT;
  
      FUNC SETUPNS I; 
          BEGIN 
          IF ENDADDRESS EQ 0
          THEN ENDADDRESS = NEXTPNAT; 
          NSFLAG = 1; 
          SETUPNS = ENDADDRESS; 
          RETURN; 
          END   #SETUPNS# 
      CONTROL EJECT;
  
      #----------------------------------------------------------------#
      #                                                                #
      # START OF EXECUTABLE CODE FOR PROCEDURE SET7                    #
      #                                                                #
      #----------------------------------------------------------------#
  
          GOTO SUB[SUB$]; 
  
SUB11:  
#OPEN ROUTINE#
          IF DEBUGFLAG EQ 1  THEN DEBUGUSEPROC; 
          VD; 
          RETURN; 
OPENTEST: 
          IF GET(FN$RPTPTR,FNAT$,STACK(1)) NQ 0 
          THEN ERROR(SEVERE,355,LINE(1),COLUMN(1)); 
OPENGTEXT:  
          IF GET(FN$SSRELATN, FNAT$, STACK(1)) NQ 0 
          THEN BEGIN  # OPEN RELATION # 
               RELLIST = GET(FN$SSRSTLST, FNAT$, STACK(1)); # REL AREAS#
               END
          ELSE
               RELLIST = 0; 
OPRELRPT: 
          IF RELLIST NQ 0 
          THEN BEGIN  # A RELATION AREA IS TO BE PROCESSED #
               FIX1 = GET(AX$FDPTR, AUX$, RELLIST); 
               FIX1 = GET(DN$FNATPTR, DNAT$, FIX1); 
               XSTACK(1, FIX1);   # PUT IN ACTUAL FNAT #
               RELLIST = GET(AX$TNEXTPTR, AUX$, RELLIST); 
               END
          NG($OPEN);
          NGGTX(GFILEREF,STACK(1),0); 
          NGSTACK(2); 
          NGSTACK(4); 
          NGSTACK(5); 
          FILEDEBUG(ANS); 
          IF RELLIST NQ 0 
          THEN
               GOTO OPRELRPT;  # ANOTHER RELATION AREA TO DO #
          RETURN; 
SUB12:  
#OPEN INPUT REVERSED ROUTINE# 
          IF GET(FN$ORG,FNAT$,STACK(1)) NQ SEQUENTIAL 
          THEN  ERROR(SEVERE,356,LINE(1),COLUMN(1));
          XSTACK(4,$INPUT); 
          XSTACK(5,$REVERSED);
          GOTO OPENTEST;
SUB13:  
#OPEN INPUT ROUTINE#
          XSTACK(4,$INPUT); 
          XSTACK(5,$NULL);
          GOTO OPENTEST;
SUB14:  
#OPEN INPUT NO REWIND ROUTINE#
          IF GET(FN$SSCHEMA,FNAT$,WR$F) EQ 1
          THEN BEGIN
              ERROR(ADVISORY,563,LINE$,COLUMN$);
              END 
          IF GET(FN$ORG,FNAT$,STACK(1)) NQ SEQUENTIAL 
          THEN  ERROR(SEVERE,356,LINE(1),COLUMN(1));
          XSTACK(4,$INPUT); 
          XSTACK(5,$NOREWIND);
          GOTO OPENTEST;
SUB15:  
#OPEN OUTPUT ROUTINE# 
          XSTACK(4,$OUTPUT);
          XSTACK(5,$NULL);
          GOTO OP1; 
SUB16:  
#OPEN OUTPUT NO REWIND ROUTINE# 
          IF GET(FN$SSCHEMA,FNAT$,WR$F) EQ 1
          THEN BEGIN
               ERROR(ADVISORY,563,LINE$,COLUMN$); 
               END
          IF GET(FN$ORG,FNAT$,STACK(1)) NQ SEQUENTIAL 
          THEN  ERROR(SEVERE,356,LINE(1),COLUMN(1));
          XSTACK(4,$OUTPUT);
          XSTACK(5,$NOREWIND);
    OP1:  
          IF GET(FN$SSCHEMA,FNAT$,WR$F) EQ 1
          THEN BEGIN
                SET(FN$VOUTPUT,FNAT$,WR$F,1); 
                IF GET(FN$ALTKPTR,FNAT$,WR$F) NQ 0
                THEN CCTMIPOO[0] = TRUE;
                END 
          GOTO OPTTEST; 
SUB17:  
#OPEN EXTEND ROUTINE# 
          IF GET(FN$ORG,FNAT$,STACK(1)) NQ SEQUENTIAL 
          THEN  ERROR(SEVERE,357,LINE(1),COLUMN(1));
          XSTACK(4,$EXTEND);
          XSTACK(5,$NULL);
    OPTTEST:  
          IF GET(FN$OPTIONAL,FNAT$,WR$F) EQ 1 
          THEN ERROR(SEVERE,382,LINE(1),COLUMN(1)); 
          GOTO OPENGTEXT; 
SUB18:  
#OPEN I O ROUTINE#
          XSTACK(4,$IO);
          XSTACK(5,$NULL);
          IF GET(FN$OPTIONAL,FNAT$,WR$F) EQ 1 
          THEN ERROR(SEVERE,382,LINE(1),COLUMN(1)); 
          GOTO OPENTEST;
SUB1: 
#CLOSE ROUTINE# 
          IF DEBUGFLAG EQ 1  THEN DEBUGUSEPROC; 
          VD; 
          RETURN; 
CLOSETEST:  
          IF GET(FN$ORG,FNAT$,STACK(1)) NQ SEQUENTIAL 
          THEN ERROR(SEVERE,358,LINE(1),COLUMN(1)); 
CLOSEGTEXT: 
          IF GET(FN$SSRELATN, FNAT$, STACK(1)) NQ 0 
          THEN BEGIN         # CLOSE REALTION # 
               RELLIST = GET(FN$SSRSTLST, FNAT$, STACK(1)); # REL AREAS#
               END
          ELSE
               RELLIST = 0; 
CLRELRPT: 
          IF RELLIST NQ 0 
          THEN BEGIN  # A RELATION AREA IS TO BE PROCESSED #
               FIX1 = GET(AX$FDPTR, AUX$, RELLIST); 
               FIX1 = GET(DN$FNATPTR, DNAT$, FIX1); 
               XSTACK(1, FIX1);   # PUT IN ACTUAL FNAT #
               RELLIST = GET(AX$TNEXTPTR, AUX$, RELLIST); 
               END
          NGSTACK(4); 
          NGGTX(GFILEREF,STACK(1),0); 
          NGSTACK(2); 
          NGSTACK(5); 
          FILEDEBUG(ANS); 
          IF RELLIST NQ 0 
          THEN
               GOTO CLRELRPT;  # ANOTHER RELATION AREA TO DO #
          RETURN; 
SUB3: 
#SIMPLE CLOSE ROUTINE#
          XSTACK(4,$CLOSE); 
          XSTACK(5,$NULL);
          GOTO CLOSEGTEXT;
SUB2: 
#CLOSE LOCK ROUTINE#
          IF GET(FN$SSCHEMA,FNAT$,WR$F) EQ 1
          THEN BEGIN
               ERROR(ADVISORY,564,LINE$,COLUMN$); 
               END
          XSTACK(4,$CLOSE); 
          XSTACK(5,$LOCK);
          IF CCTFIPSLEVEL LS 3 AND
             GET(FN$ORG,FNAT$,STACK(1)) EQ SEQUENTIAL 
          THEN BEGIN
               # FIPS = 3 SUPPORTS CLOSE SEQUENTIAL WITH LOCK # 
               ERROR(TRIVIAL,446,LINE$,COLUMN$);
               END
          GOTO CLOSEGTEXT;
SUB6: 
#CLOSE NO REWIND ROUTINE# 
          XSTACK(4,$CLOSE); 
          XSTACK(5,$NOREWIND);
          GOTO CLOSETEST; 
SUB4: 
#CLOSE REEL ROUTINE#
          XSTACK(4,$CLOSEREEL); 
          XSTACK(5,$NULL);
          GOTO CLOSETEST; 
SUB5: 
#CLOSE REEL REMOVE ROUTINE# 
          XSTACK(4,$CLOSEREEL); 
          XSTACK(5,$REMOVE);
          GOTO CLOSETEST; 
SUB61:  
# FIPS CLOSE FILE-NAME SERIES ROUTINE                                  #
          IF CCTFIPSLEVEL GR 3
          THEN
              BEGIN 
              RETURN; 
              END 
          ELSE
              BEGIN 
              REG1 = GET(DN$FNATPTR,DNAT$,VALUE$);
              REG2 = GET(FN$ORG,FNAT$,REG1);
              END 
          IF REG2 EQ INDEXED
          THEN
              BEGIN 
#             FIPS = 4 SUPPORTS THE CLOSE FILE-NAME SERIES FOR INDEXED #
#             FILE ORGANIZATIONS                                       #
              ERROR(TRIVIAL,D830,LINE$,COLUMN$);
              RETURN; 
              END 
          IF CCTFIPSLEVEL LS 3
          THEN
              BEGIN 
              IF REG2 EQ SEQUENTIAL 
              THEN
                  BEGIN 
#                 FIPS = 3 SUPPORTS THE CLOSE FILE-NAME SERIES FOR     #
#                 SEQUENTIAL FILE ORGANIZATIONS                        #
                  ERROR(TRIVIAL,D831,LINE$,COLUMN$);
                  RETURN; 
                  END 
              ELSE
                  BEGIN 
                  IF CCTFIPSLEVEL LS 2 AND REG2 EQ RELATIVE 
                  THEN
                      BEGIN 
#                     FIPS = 2 SUPPORTS THE CLOSE FILE-NAME SERIES FOR #
#                     RELATIVE FILE ORGANIZATIONS                      #
                      ERROR(TRIVIAL,D832,LINE$,COLUMN$);
                      END 
                  END 
              END 
          RETURN; 
SUB7: 
#DELETE ROUTINE#
          IF DEBUGFLAG EQ 1  THEN DEBUGUSEPROC; 
          VD; 
          RETURN; 
SUB59:  
#DELETE FILE ROUTINE# 
          NG($DELETE);
          NGGTX(GFILEREF,STACK(1),0); 
          NG($DFILE); 
          RETURN; 
SUB8: 
#DELETE RECORD ROUTINE# 
          FIX1 = GET(FN$ORG,FNAT$,STACK(1));
          IF FIX1 EQ SEQUENTIAL OR
             FIX1 EQ WORD$ADDR
          THEN  ERROR(SEVERE,359,LINE(1),COLUMN(1));
          NG($DELETE);
          NGGTX(GFILEREF,STACK(1),0); 
          RETURN; 
SUB9: 
#DELETE NO IMPERATIVE ROUTINE#
          NG($NULL);
          # THE INVALID KEY PHRASE MUST BE SPECIFIED FOR A DELETE      #
          # STATEMENT WHICH REFERENCES A FILE NOT IN SEQUENTIAL ACCESS #
          # MODE AND FOR WHICH AN APPLICABLE IO-DECLARATIVE IS NOT     #
          # SPECIFIED.                                                 #
          IF STACK(3) EQ 0  AND 
             IODECL EQ 0
          THEN BEGIN
               IF GET(FN$ACCESS,FNAT$,STACK(1)) NQ SEQUENTIAL 
               THEN  ERROR(JOD,361,LINE(1),COLUMN(1));
               END
          FILEDEBUG(ANS); 
          RETURN; 
SUB10:  
#DELETE INVALID KEY PROLOGUE# 
          NG($SINVALIDKEY); 
          IF GET(FN$ACCESS,FNAT$,STACK(1)) EQ SEQUENTIAL
          THEN  ERROR(SEVERE,360,LINE$,COLUMN$);
          FILEDEBUG(ANS);    #IN DELETE, DO DEBUG EVEN IF AN INVALID# 
                             #KEY HAPPENS.                          # 
          FILEADDRESS = 0;   #SUPPRESS CONDITIONAL DEBUG.           # 
          INVKEYGTEXT;
          RETURN; 
SUB33:  
#START ROUTINE# 
          IF DEBUGFLAG EQ 1  THEN DEBUGUSEPROC; 
          VD; 
          RETURN; 
SUB34:  
#START FILE ROUTINE#
          IF GET(FN$SSRELATN, FNAT$, STACK(1)) NQ 0 
          THEN BEGIN  # START RELATION - GET FIRST AREA (FILE ) IN REL #
               FIX1 = GET(FN$SSRSTLST, FNAT$, STACK(1));
               FIX2 = GET(AX$FDPTR, AUX$, FIX1);
               FIX2 = GET(DN$FNATPTR, DNAT$, FIX2); 
               CONTROL IFEQ CB5$CDCS,"CDCS1"; 
               XSTACK(1, FIX2); 
               CONTROL FI;
               END
         ELSE FIX2 = STACK(1);
          FIX1 = GET(FN$ORG,FNAT$,FIX2);
          IF FIX1 EQ SEQUENTIAL OR
             FIX1 EQ WORD$ADDR
          THEN  ERROR(SEVERE,362,LINE(1),COLUMN(1));
          IF GET(FN$ACCESS,FNAT$,FIX2) EQ RANDOM
          THEN  ERROR(SEVERE,363,LINE(1),COLUMN(1));
          XSTACK(4,$KEYEQ); 
          IF FIX1 EQ RELATIVE 
          THEN BEGIN
               IF CCTFIPSLEVEL LS 3 
               THEN BEGIN 
                    #FIPS=3 SUPPORTS THE START STATEMENT# 
                    ERROR(TRIVIAL,453,LINE(1),COLUMN(1)); 
                    END 
               FIX1 = GET(FN$RELKPTR,FNAT$,FIX2); 
               XSTACK(5,GTX(GDATAREF,FIX1,0));
               END
          ELSE  IF FIX1 EQ INDEXED  OR
                   FIX1 EQ DIRECT   OR
                   FIX1 EQ ACTUAL$KEY 
                THEN BEGIN
                     FIX1 = GET(FN$RECPTR,FNAT$,FIX2);
                     XSTACK(5,GTX(GDATAREF,FIX1,0));
                     END
          RETURN; 
SUB35:  
#START EQUALS ROUTINE#
          XSTACK(4,$KEYEQ); 
          RETURN; 
SUB36:  
#START GREATER ROUTINE# 
          XSTACK(4,$KEYGR); 
          RETURN; 
SUB37:  
#START NOT LESS ROUTINE#
          XSTACK(4,$KEYNOTLESS);
          RETURN; 
SUB39:  
#START KEY ROUTINE# 
          IF GET(FN$SSRELATN, FNAT$, STACK(1)) NQ 0 
          THEN BEGIN  # START RELATION - GET FIRST AREA (FILE) IN REL # 
               FIX1 = GET(FN$SSRSTLST, FNAT$, STACK(1));
               FIX2 = GET(AX$FDPTR, AUX$, FIX1);
               FIX2 = GET(DN$FNATPTR, DNAT$, FIX2); 
               CONTROL IFEQ CB5$CDCS,"CDCS1"; 
               XSTACK(1, FIX2); 
               CONTROL FI;
               WR$F = FIX2;  #POINT TO PRIMARY FILE FOR CHECKS# 
               END
          REG4 = GET(FN$ORG,FNAT$,WR$F);
          IF REG4 EQ RELATIVE 
          THEN BEGIN
               IF VALUE$ NQ GET(FN$RELKPTR,FNAT$,WR$F)
              THEN BEGIN ERROR(SEVERE,364,LINE$,COLUMN$); 
               RETURN;
              END 
               END
          XSTACK(5,GTX(GDATAREF,VALUE$,0)); 
          REG1 = GET(FN$RECPTR,FNAT$,WR$F); 
          IF REG4 EQ INDEXED
          THEN BEGIN
               #IT CAN BE ANY KEY OR LEFTMOST PART OF ANY KEY#
               IF VALUE$ EQ REG1
               THEN RETURN; 
               IF ALTKEY(VALUE$,WR$F) EQ 1
               THEN RETURN; 
               IF LEFTMOST(VALUE$,REG1) EQ 1 AND
                  ALTKEY(VALUE$,WR$F) EQ 0
               THEN RETURN; 
               IF ALTKEY(VALUE$,WR$F) EQ 2 AND
                  LEFTMOST(VALUE$,REG1) EQ 0
               THEN RETURN; 
               ERROR(SEVERE,371,LINE$,COLUMN$); 
               RETURN;
               END
  
      # CASE OF DIRECT OR ACTUAL KEY FILE ORGANIZATIONS :              #
      #    LOOKING AT THE DATA NAME IN THE KEY PHRASE                  #
      #       (1) ERROR(344) IF IT'S THE PRIME KEY                     #
      #       (2) ERROR(372) IF IT'S NOT AN ALTERNATE KEY OR THE       #
      #           LEFTMOST PART OF AN ALTERNATE KEY                    #
  
          IF REG4 EQ DIRECT  OR 
             REG4 EQ ACTUAL$KEY 
          THEN
              BEGIN 
              IF VALUE$ EQ REG1 THEN
                  ERROR(SEVERE, 344, LINE$, COLUMN$); 
              ELSE IF ALTKEY(VALUE$, WR$F) NQ 1  AND
                      ALTKEY(VALUE$, WR$F) NQ 2 
                   THEN 
                       ERROR(SEVERE, 372, LINE$, COLUMN$);
              END 
          RETURN; 
SUB40:  
#START NO IMPERATIVE ROUTINE# 
          NG($START); 
          NGGTX(GFILEREF,STACK(1),0); 
          NG($NULL);
          NGSTACK(4); 
          NGSTACK(5); 
          # THE INVALID KEY PHRASE MUST BE SPECIFIED IN A START       # 
          # STATEMENT IF NO APPLICABLE IO-DECLARATIVE IS SPECIFIED.   # 
          IF STACK(3) EQ 0  AND 
             INPUTDECL EQ 0 AND 
             IODECL EQ 0
          THEN  ERROR(JOD,366,LINE(1),COLUMN(1)); 
          FILEDEBUG(ANS); 
          RETURN; 
SUB38:  
#START INVALID KEY# 
          FILEDEBUG(ANS);    #IN START, DO DEBUG EVEN IF AN INVALID#
                             #KEY HAPPENS.                         #
          FILEADDRESS = 0;   #SUPPRESS CONDITIONAL DEBUG.          #
          INVKEYGTEXT;
          RETURN; 
SUB41:  
#START GTEXT# 
          NG($START); 
          NGGTX(GFILEREF,STACK(1),0); 
          NG($SINVALIDKEY); 
          NGSTACK(4); 
          NGSTACK(5); 
          RETURN; 
SUB27:  
#REWRITE ROUTINE# 
          VD; 
          #SET UP GTEXT AS IN WRITE#
          WORD [0] = $REWRITE;
          WORD [1] = 0;                          # OR FILEREF # 
          WORD [2] = $NULL;                      # OR $SINVALIDKEY #
          WORD [3] = 0;                          # OR DNREF # 
          WR$F = 0; 
          WR$REC = 0; 
          RETURN; 
SUB30:  
#REWRITE RECORD ROUTINE#
          #ORGANIZATION MUST NOT BE WORD$ADDR#
          REG4 = GET(FN$ORG,FNAT$,WR$F);
          IF REG4 EQ WORD$ADDR
          THEN BEGIN
               ERROR(SEVERE,396,TABLELINE,TABLECOLUMN); 
               END
          IF CCTFIPSLEVEL LS 2 AND REG4 EQ RELATIVE 
          THEN BEGIN
               #FIPS=2 SUPPORTS PROCEDURE DIVISION REFERENCES # 
               # TO RECORD-NAMES DEFINED IN RELATIVE FILES. # 
               ERROR(TRIVIAL,817,TABLELINE,TABLECOLUMN);
               END
          IF CCTFIPSLEVEL LS 4 AND REG4 EQ INDEXED
          THEN BEGIN
               #FIPS=4 SUPPORTS REFERENCES TO RECORD-NAMES# 
               #DEFINED IN INDEXED FILES# 
               ERROR(TRIVIAL,818,TABLELINE,TABLECOLUMN);
               END
          RETURN; 
SUB31:  
#REWRITE NO IMPERATIVE ROUTINE# 
          #IF THERE IS NO DECLARATIVE, THEN ORGANIZATION MUST#
          #NOT BE INDEXED, ACTUAL$KEY, OR DIRECT.  IF IT IS  #
          #RELATIVE, THE ACCESS MUST NOT BE SEQUENTIAL.      #
          IF GET(FN$ERRPTR,FNAT$,WR$F) EQ 0 
             AND
             IODECL EQ 0
          THEN BEGIN
               REG1 = GET(FN$ORG,FNAT$,WR$F); 
               REG2 = GET(FN$ACCESS,FNAT$,WR$F);
               IF (REG1 EQ INDEXED OR 
                  REG1 EQ DIRECT       OR 
                  REG1 EQ ACTUAL$KEY   OR 
                  REG1 EQ RELATIVE ) AND
                  (REG2 EQ DYNAMIC  OR  REG2 EQ RANDOM) 
               THEN 
           REG3 = GET(FN$STATPTR,FNAT$,WR$F); 
           IF REG3 EQ 0 THEN
                   ERROR(JOD,369,VERBLINE,VERBCOLUMN);
               END
          WRITEGTEXT; 
          RETURN; 
SUB32:  
#REWRITE INVALID KEY# 
          WORD [2] = $SINVALIDKEY;
          #ORGANIZATION MUST NOT BE SEQUENTIAL,   IF ITS #
          #RELATIVE, THEN ACCESS MUST NOT BE SEQUENTIAL. #
          REG1 = GET(FN$ORG,FNAT$,WR$F);
          REG2 = GET(FN$ACCESS,FNAT$,WR$F); 
          IF REG1 EQ SEQUENTIAL      OR 
             REG1 EQ RELATIVE        AND
             REG2 EQ SEQACCESS
          THEN
              ERROR(SEVERE,370,VERBLINE,VERBCOLUMN);
          WRITEGTEXT; 
          NG($INVALIDKEY);
          NG(WORD[1]);
          IF ENDADDRESS EQ 0
          THEN ENDADDRESS = NEXTPNAT; 
          NSFLAG = 1; 
          NGLABELREF(ENDADDRESS,GFALSE);
          RETURN; 
SUB19:  
#READ ROUTINE#
          VD; 
          WORD [0] = $READNEXT;        # OR $READKEY OR $READSTART #
          WORD [1] = 0;                          # OR FILEREF # 
          WORD [2] = $NULL;            # OR $SINVALIDKEY OR $SATEND # 
          WORD [3] = 0;                # OR DNREF (KEYNAME) # 
          READCOND = 0;   #TURN OFF ALL SWITCHES# 
          READSTATUS = 2;   #2 IS OK, 1 MEANS AN ERROR #
          FORMAT = 0; 
          RETURN; 
SUB21:  
#READ FILE# 
          #SELECT PROPER VERB  AND FORMAT.# 
          #THIS MAY BE CHANGED IF A NEXT PHRASE OR A KEY PHRASE#
          #IS ENCOUNTERED.# 
          REG1 = GET(FN$ORG   ,FNAT$,WR$F); 
          REG2 = GET(FN$ACCESS,FNAT$,WR$F); 
          #SELECT $READNEXT IF ACCESS MODE IS SEQUENTIAL OR # 
          #A NEXT PHRASE EXISTS.                            # 
          IF REG2 EQ SEQACCESS
          THEN
              BEGIN 
              FORMAT = 1; 
              WORD [0] = $READNEXT; 
              GOTO RF1; 
              END 
          IF REG2 EQ RANDOM 
             OR 
             REG2 EQ DYNAMIC
          THEN
              FORMAT = 2; 
          IF READSTATUS EQ 1     #WILL BE NO GTEXT# 
          THEN RETURN;
          #IF ORGANIZATION IS RELATIVE OR WORD-ADDRESS      # 
          #SELECT $READSTART WHENEVER A KEY PHRASE EXISTS   # 
          #     ELSE SELECT $READKEY.                       # 
          IF REG1 EQ RELATIVE 
             OR 
             REG1 EQ WORD$ADDR
          THEN
              BEGIN 
              WORD [0] = $READKEY;
              GOTO RF1; 
              END 
          #IF ORGANIZATION IS INDEXED, DIRECT OR ACTUAL-KEY # 
          #SELECT $READSTART IF THERE ARE ALTERNATE KEYS    # 
          #       ELSE SELECT $READKEY.                     # 
          IF REG1 EQ INDEXED     OR 
             REG1 EQ DIRECT      OR 
             REG1 EQ ACTUAL$KEY 
          THEN
              BEGIN 
              IF GET(FN$ALTKPTR,FNAT$,WR$F) NQ 0
              THEN
                  BEGIN 
                  WORD [0] = $READSTART;
                  REG3 = GET(FN$RECPTR,FNAT$,WR$F); 
                  WORD [3] = GTX(GDATAREF,REG3,0);
                  END 
              ELSE
                  WORD [0] = $READKEY;
              END 
RF1:  
          WORD [1] = GTX(GFILEREF,WR$F,0);
          # SET COND1: THERE IS A USE PROCEDURE FOR INPUT,  # 
          #            I-O, OR THE FILE-NAME                # 
          IF(GET(FN$ERRPTR,FNAT$,WR$F) NQ 0 
             OR 
             INPUTDECL NQ 0 
             OR 
             IODECL NQ 0) 
          THEN
              B<1,1>READCOND = 1; 
          # SET COND5: DEBUGGING ON FILE-NAME IS REQUIRED.  # 
          IF DEBUGFLAG EQ 1 
             AND
             GET(DN$DEBUG,DNAT$,VALUE$) EQ 1
          THEN
              B<5,1>READCOND = 1; 
          RETURN; 
SUB23:  
#READ NEXT# 
          IF CCTFIPSLEVEL LS 3
          THEN BEGIN
               IF GET(FN$ORG,FNAT$,WR$F) EQ RELATIVE
               THEN BEGIN 
                    #FIPS=3 SUPPORTS READ NEXT RECORD#
                    ERROR(TRIVIAL,450,LINE$,COLUMN$); 
                    END 
               END
          #ILLEGAL IF ACCESS IS RANDOM# 
          REG1 = GET(FN$ACCESS,FNAT$,WR$F); 
          IF REG1 EQ RANDOM 
          THEN
              BEGIN 
              ERROR(SEVERE,397,LINE$,COLUMN$);
              READSTATUS = 1; 
              RETURN; 
              END 
          #IF ACCESS IS DYNAMIC, CHANGE FORMAT TO 1#
          IF REG1 EQ DYNAMIC
          THEN
              BEGIN 
              FORMAT = 1; 
              WORD [0] = $READNEXT; 
              END 
          RETURN; 
SUB20:  
#READ INTO# 
          # ERROR IF READ INTO INVALID OPERAND #
          REG1 = GET(DN$TYPE,DNAT$,TABLENAME);
          FIX1 = 0; 
          IF REG1 EQ INDXDATA THEN             # INDEX DATA # 
              FIX1 = 2; 
          ELSE
              BEGIN 
              IF REG1 EQ INDXNAME THEN         # INDEX-NAME # 
                  FIX1 = 5; 
              ELSE IF REG1 EQ NONDATA THEN     # NON-DATA # 
                  FIX1 = 26;
              END 
          IF FIX1 NQ 0 THEN 
              ERROR(SEVERE,FIX1,LINE$,COLUMN$); 
          #ERROR IF THERE ARE RECORDS OF DIFFERENT SIZES# 
          IF GET(FN$VRECLEN,FNAT$,WR$F) EQ 1
          THEN ERROR(JOD,389,TABLELINE,TABLECOLUMN);
          #ERROR IF THE INTO IDENTIFIER IS IN THE FILE# 
          REG1 = GET(FN$SMSECNO,FNAT$,WR$F);
          IF GET(DN$MAJMSEC,DNAT$,TABLENAME) EQ FDMSEC AND
             GET(DN$SUBMSEC,DNAT$,TABLENAME) EQ REG1
          THEN BEGIN
              ERROR(SEVERE,340,TABLELINE,TABLECOLUMN);
              READSTATUS = 1; 
              END 
          # SET COND3: THERE IS AN INTO PHRASE. THIS FLAG IS #
          #            ACTUALLY SET ONLY IF READSTATUS IS OK.#
          B<3,1>READCOND = READSTATUS - 1;
          #ONLY DEBUGGING ON THE INTO IDENTIFIER OR ITS # 
          #SUBSCRIPTS DEPENDS ON CONDITION 4. THIS IS   # 
          #DONE VIA A CALL FROM THE SYNTAX TABLES TO    # 
          #THE STATEMENT DEBUG ROUTINE AT THE CORRECT   # 
          #TIME SO WE DO NOT NEED TO SET CONDITION 4.   # 
          RETURN; 
SUB24:  
#READ KEYED#
          #ILLEGAL IF FORMAT 1 (ACCESS IS SEQUENTIAL OR NEXT APPEARED)# 
          #        OR ORGANIZATION IS RELATIVE OR WORD ADDRESS        # 
          REG1 = GET(FN$ORG,FNAT$,WR$F);
          IF FORMAT EQ 1
             OR 
             REG1 EQ RELATIVE 
             OR 
             REG1 EQ WORD$ADDR
          THEN
              BEGIN 
              ERROR(SEVERE,373,LINE$,COLUMN$);
              READSTATUS = 1; 
              RETURN; 
              END 
          #THE DATA NAME MUST BE A RECORD KEY#
          IF VALUE$ NQ GET(FN$RECPTR,FNAT$,WR$F)
          THEN
              BEGIN 
              #ITS NOT PRIME KEY, SEE IF ITS AN ALTERNATE KEY # 
              REG1 = GET(FN$ALTKPTR,FNAT$,WR$F);
              FOR $DUMMY$ = 0 WHILE REG1 NQ 0 DO
                  BEGIN 
                  IF GET(AX$TTYPE,AUX$,REG1) EQ ALTKEYNAME
                     AND
                     GET(AX$ALTKEY,AUX$,REG1) EQ VALUE$ 
                  THEN
                       BEGIN
                       IF GET(DN$OCCURS,DNAT$,VALUE$) EQ 1
                       THEN BEGIN 
                            #AN ALTERNATE RECORD KEY WHOSE DESCRIPTION# 
                            #CONTAINS THE OCCURS CLAUSE IS NON-STANDARD#
                            ERROR(JOD,466,LINE$,COLUMN$); 
                            END 
                       GOTO FOUNDKEY; 
                       END
                  REG1 = GET(AX$TNEXTPTR,AUX$,REG1);
                  END 
              ERROR(SEVERE,374,LINE$,COLUMN$);
              READSTATUS = 1; 
              RETURN; 
              END 
FOUNDKEY: 
          WORD [0] = $READSTART;
          WORD [3] = GTX(GDATAREF,VALUE$,0);
          # SET COND2: DEBUGGING ON KEYNAME IS REQUIRED.     #
          #            IMPLIES PRESENSE OF THE KEY PHRASE.   #
          IF DEBUGFLAG EQ 1  AND
             GET(DN$DEBUG,DNAT$,VALUE$) EQ 1
          THEN BEGIN
               TEMP1 = GET(DN$AUXREF,DNAT$,VALUE$); 
               TEMP1 = FINDAUX(AUXDEBUG,TEMP1); 
               IF GET(AX$DEBUGMODE,AUX$,TEMP1) EQ 1 
               THEN B<2,1>READCOND = READSTATUS - 1;
               END
          RETURN; 
SUB22:  
#READ NO IMPERATIVE#
          #NON STANDARD ERROR IF NO DECLARATIVE#
          IF NOT (COND1)
          THEN
              BEGIN 
              IF FORMAT EQ 1
              THEN
                  ERROR(JOD,375,VERBLINE,VERBCOLUMN); 
              ELSE IF FORMAT EQ 2 
                   THEN 
                       ERROR(JOD,376,VERBLINE,VERBCOLUMN);
              END 
          GOTO READPART1; 
SUB25:  
#READ AT END# 
          REG1 = 2;      #ILLEGAL FORMAT# 
          REG2 = 377;    #ERROR NUMBER  # 
          TEMPATOM = $ATEND;
          WORD [2] = $SATEND; 
          GOTO READCOND6; 
SUB26:  
#READ INVALID KEY#
          REG1 = 1;      #ILLEGAL FORMAT# 
          REG2 = 378;    #ERROR NUMBER  # 
          TEMPATOM = $INVALIDKEY; 
          WORD [2] = $SINVALIDKEY;
READCOND6:  
          # SET COND6: THERE IS AN INVALID KEY OR AN AT END PHRASE# 
          IF FORMAT EQ REG1 
          THEN
              BEGIN 
              ERROR(SEVERE,REG2,LINE$,COLUMN$); 
              READSTATUS = 1;   #SUPPRESS FUTURE GTEXT# 
              RETURN; 
              END 
          B<6,1>READCOND = READSTATUS - 1;
READPART1:  
          IF READSTATUS EQ 1
          THEN
              RETURN; 
          WRITEGTEXT; 
          IF COND2
          THEN BEGIN
               #GENERATE GTEXT FOR THE DEBUGGING ON KEY NAME.     # 
               #THE KEY NAME IS THE TOP ELEMENT OF THE DEBUG STACK# 
               FIX1 = DEBUGELEMENT(DS); 
               DS = DS - 1; 
               ADR = B<30,15>FIX1;
               TEMP = GET(DN$AUXREF,DNAT$,ADR); 
               TEMP1 = FINDAUX(AUXDEBUG,TEMP);
               DEBUGFILL; 
               NGMOVE;
               FIX1 = GET(AX$LATPTR,AUX$,TEMP1);
               NGLITREF(FIX1);
               NGDATAREF(DEBUGNAME);
               NGMOVE;
               NGDATAREF(ADR);
               IF GET(AX$DEBUGCONV,AUX$,TEMP1) EQ 1 
               THEN NGDATAREF(DEBUGNUMCON); 
               ELSE NGDATAREF(DEBUGCONTS);
               NG($PERFORM);
               FIX1 = GET(AX$DEBUGPROC,AUX$,TEMP1); 
               NGPROCREF(FIX1,0); 
               NGPROCREF(FIX1,0); 
               NGLABELREF((NEXTPNAT),0);
               NGLABELDEF(PNATLENGTH);
               END
  
          IF COND3
          THEN                          # $IOSUCCESS     #
              BEGIN 
              NG($IOSUCCESS);           # FALSE BRANCH L1#
              READL1 = NEXTPNAT;        # MOVE RECORD PACKET# 
              NGLABELREF(READL1,GFALSE);
              #OUTPUT SUBSCRIPTS IF ANY#
              REG1 = REMOVE(1); 
              NG($MOVERECORD);
              NGGTX(GFILEREF,WR$F,0); 
              NGSTACK(REG1);
              SECTEST(4,351); 
              END 
          RETURN; 
SUB58:  
#READ GTEXT#
          IF READSTATUS EQ 1
          THEN RETURN;
          IF COND3 AND COND6 AND NOT( COND5)
          THEN
               BEGIN                    #GO TO NEXT SENTENCE# 
               NGGOTO;
               NGLABELREF((SETUPNS) ,0);
               END
          IF COND3
          THEN
              NGLABELDEF(READL1); 
          IF COND6
          THEN
              BEGIN 
              NG(TEMPATOM);                 #$ATEND OR $INVALIDKEY# 
              NGGTX(GFILEREF,WR$F,0); #FILE REF#
              END 
          IF COND6 AND NOT( COND5 ) 
          THEN                          #FALSE BRANCH NEXT SENTENCE#
              BEGIN 
              NGLABELREF((SETUPNS),GFALSE); 
              # AT THIS POINT, GTEXT IS COMPLETE #
              RETURN; 
              END 
          IF COND6 AND COND5
          THEN BEGIN                #TRUE BRANCH L2#
               NGLABELREF((NEXTPNAT),GTRUE);
               TEMP1 = PNATLENGTH;
               END
  
          IF COND5
          THEN                          #DEBUGGING ON FILE NAME#
              FILEDEBUG(ANS); 
  
          IF COND6 AND COND5
          THEN                          #GO TO NEXT SENTENCE# 
              BEGIN 
          NGGOTO; 
          NGLABELREF((SETUPNS),0);
  
                                        #LABEL DEF L2#
               NGLABELDEF(TEMP1); 
              END 
          RETURN; 
SUB52:  
#FILE NAME ROUTINE# 
          XLINE(1,LINE$); 
         XCOLUMN(1,COLUMN$);
          FILEADDRESS=VALUE$; 
          XSTACK(1,0);
          XSTACK(2,0);
          XSTACK(3,0);
          S = 3;
          S$ = 3; 
          IF VALUE$ EQ 0  THEN RETURN;
          FIX1 = GET(DN$LEVEL,DNAT$,VALUE$);
          IF FIX1 EQ SDDESCR
          THEN BEGIN
               ERROR(SEVERE,188,LINE$,COLUMN$); 
               RETURN;
               END
          IF FIX1 NQ FDDESCR
          THEN BEGIN
               ERROR(SEVERE,379,LINE$,COLUMN$); 
               RETURN;
               END
          WR$F = GET(DN$FNATPTR,DNAT$,VALUE$);
          IF WR$F EQ 0  OR
             GET(FN$ABORT,FNAT$,WR$F) EQ 1
          THEN BEGIN
               ERROR(PROPAGATED,365,LINE$,COLUMN$); 
               RETURN;
               END
          REG1 = GET(FN$ORG,FNAT$,WR$F);
          IF CCTFIPSLEVEL LS 2 AND REG1 EQ RELATIVE 
          THEN BEGIN
               #FIPS=2 SUPPORTS PROCEDURE DIVISION REFERENCES # 
               #TO RELATIVE FILES#
               ERROR(TRIVIAL,815,LINE$,COLUMN$);
               END
          IF CCTFIPSLEVEL LS 4 AND REG1 EQ INDEXED
          THEN BEGIN
               #FIPS=4 SUPPORTS PROCEDURE DIVISION REFERENCES # 
               #TO INDEXED FILES# 
               ERROR(TRIVIAL,816,LINE$,COLUMN$);
               END
          IF VERBCODE NQ RWOPEN  AND  VERBCODE NQ RWCLOSE 
          THEN BEGIN
               #REPORT FILES CANNOT BE USED IN THE I/O VERBS# 
               #WITH THE EXCEPTION OF OPEN AND CLOSE.       # 
               IF REPORTMODE EQ 0  AND
                  GET(FN$RPTPTR,FNAT$,WR$F) NQ 0
               THEN BEGIN 
                    ERROR(SEVERE,367,LINE$,COLUMN$);
                    RETURN; 
                    END 
                END 
          XSTACK(1,WR$F); 
          IF GET(FN$STATPTR,FNAT$,WR$F) EQ 0
          THEN XSTACK(2,$NULL); 
          ELSE BEGIN
               FIX1 = GET(FN$STATPTR,FNAT$,WR$F); 
               XSTACK(2,GTX(GDATAREF,FIX1,0));
               END
          IF GET(FN$ERRPTR,FNAT$,WR$F) EQ 0 
          THEN XSTACK(3,0); 
          ELSE BEGIN
               FIX1 = GET(FN$ERRPTR,FNAT$,WR$F);
               XSTACK(3,GTX(GPROCREF,FIX1,0));
               END
  
          #IF THE FILE ENTRY IN THE FNAT WAS CREATED BY THE          #
          #D-TRANSLATOR, SET THE APPROPRIATE BIT FIELDS IN THE FNAT  #
          #TO SHOW FOR THE GIVEN AREA WHICH I/O VERBS HAVE BEEN USED.#
  
          IF GET(FN$SSCHEMA,FNAT$,WR$F) EQ 1
          THEN BEGIN
               IF VERBCODE EQ RWOPEN
               THEN BEGIN 
                    SET(FN$VOPEN,FNAT$,WR$F,1); 
                    RETURN; 
                    END 
               IF VERBCODE EQ RWCLOSE 
               THEN BEGIN 
                    SET(FN$VCLOSE,FNAT$,WR$F,1);
                    RETURN; 
                    END 
               IF VERBCODE EQ RWSTART 
               THEN BEGIN 
                    SET(FN$VSEEKST,FNAT$,WR$F,1); 
                    RETURN; 
                    END 
          IF VERBCODE EQ RWDELETE 
          THEN BEGIN
               SET(FN$VDELETE,FNAT$,WR$F,1);
               RETURN;
               END
               IF VERBCODE EQ RWREAD
               THEN BEGIN 
                    SET(FN$VREAD,FNAT$,WR$F,1); 
                    RETURN; 
                    END 
               END
          RETURN; 
SUB60:  
# FIPS OPEN FINE-NAME SERIES ROUTINE                                   #
          IF CCTFIPSLEVEL GR 3
          THEN
              BEGIN 
              RETURN; 
              END 
          ELSE
              BEGIN 
              REG1 = GET(DN$FNATPTR,DNAT$,VALUE$);
              REG2 = GET(FN$ORG,FNAT$,REG1);
              END 
          IF REG2 EQ INDEXED
          THEN
              BEGIN 
#             FIPS = 4 SUPPORTS THE OPEN FILE-NAME SERIES FOR INDEXED  #
#             FILE ORGANIZATIONS                                       #
              ERROR(TRIVIAL,D827,LINE$,COLUMN$);
              RETURN; 
              END 
          IF CCTFIPSLEVEL LS 3
          THEN
              BEGIN 
              IF REG2 EQ SEQUENTIAL 
              THEN
                  BEGIN 
#                 FIPS = 3 SUPPORTS THE OPEN FILE-NAME SERIES FOR      #
#                 SEQUENTIAL FILE ORGANIZATIONS                        #
                  ERROR(TRIVIAL,D828,LINE$,COLUMN$);
                  RETURN; 
                  END 
              ELSE
                  BEGIN 
                  IF CCTFIPSLEVEL LS 2 AND REG2 EQ RELATIVE 
                  THEN
                      BEGIN 
#                     FIPS = 2 SUPPORTS THE OPEN FILE-NAME SERIES FOR  #
#                     RELATIVE FILE ORGANIZATIONS                      #
                      ERROR(TRIVIAL,D829,LINE$,COLUMN$);
                      END 
                  END 
              END 
          RETURN; 
SUB28:  
#I O RECORD ROUTINE#
          IF GET(DN$LEVEL,DNAT$,TABLENAME) NQ 1 
             OR 
             GET(DN$MAJMSEC,DNAT$,TABLENAME) NQ FDMSEC
          THEN GOTO WERR1;
          REG1 = GET(DN$AUXREF,DNAT$,TABLENAME);
          REG1 = FINDAUX(FILENAME,REG1);
          IF REG1 EQ 0
          THEN GOTO WERR1;
          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
          REG3 = GET(FN$DNATPTR,FNAT$,WR$F);
          IF GET(DN$LEVEL,DNAT$,REG3) NQ FDDESCR
          THEN GOTO WERR1;
          #IT APPEARS THAT THE RECORD NAME IS OK #
          WR$REC = TABLENAME; 
          WORD [3] = GTX(GDATAREF,TABLENAME,0); 
          WORD [1] = GTX(GFILEREF,WR$F,0);
  
          #IF THE FILE ENTRY IN THE FNAT WAS CREATED BY THE          #
          #D-TRANSLATOR, SET THE APPROPRIATE BIT FIELDS IN THE FNAT  #
          #TO SHOW FOR THE GIVEN AREA WHICH OF THE VERBS WRITE OR    #
          #REWRITE HAVE BEEN USED.                                   #
          IF GET(FN$SSCHEMA,FNAT$,WR$F) EQ 1
          THEN BEGIN
               IF VERBCODE EQ RWWRITE 
               THEN BEGIN 
                    SET(FN$VWRITE,FNAT$,WR$F,1);
                    RETURN; 
                    END 
                IF VERBCODE EQ RWREWRITE
                THEN BEGIN
                     SET( FN$VREWRIT,FNAT$,WR$F,1); 
                     RETURN;
                     END
                END 
          RETURN; 
WERR1:  
          IF GET(DN$TYPE,DNAT$,TABLENAME) NQ ERRTYPE
          THEN
              ERROR(SEVERE,380,TABLELINE,TABLECOLUMN);
          RETURN; 
SUB42:  
#WRITE ROUTINE# 
          VD; 
          #SET UP DEFAULT GTEXT#            #ALTERNATE VALUES#
          WORD [0] = $WRITE;                     # OR $WRITEKEY # 
          WORD [1] = 0;                          # OR FILEREF # 
          WORD [2] = $NULL;                      # OR $SINVALIDKEY #
          WORD [3] = 0;                # OR DNREF (RECORD) #
          WORD [4] = $NULL;            # OR $AFTER OR $BEFORE # 
          WORD [5] = $NULL;            # OR DNREF OR LITREF # 
                                            #SYSNAME/$PAGE   #
          FORMAT = 1; 
          WR$F = 0;        #FNAT PTR# 
          WR$REC = 0;      #DNAT OF RECORD# 
          RETURN; 
SUB45:  
#WRITE RECORD#
          #CHANGE VERB TO $WRITEKEY UNLESS #
          # ORGANIZATION IS SEQUENTIAL  OR #
          # ORGANIZATION IS RELATIVE       #
          #  AND ACCESS IS SEQUENTIAL.     #
          REG4 = GET(FN$ORG,FNAT$,WR$F);
          IF REG4 NQ SEQUENTIAL 
          THEN BEGIN
               FORMAT = 2;
               IF REG4 NQ RELATIVE
                  OR
                  GET(FN$ACCESS,FNAT$,WR$F) NQ SEQACCESS
               THEN 
                   WORD [0] = $WRITEKEY;
               END
          IF CCTFIPSLEVEL LS 2 AND REG4 EQ RELATIVE 
          THEN BEGIN
               #FIPS=2 SUPPORTS PROCEDURE DIVISION REFERENCES # 
               # TO RECORD-NAMES DEFINED IN RELATIVE FILES. # 
               ERROR(TRIVIAL,817,TABLELINE,TABLECOLUMN);
               END
          IF CCTFIPSLEVEL LS 4 AND REG4 EQ INDEXED
          THEN BEGIN
               #FIPS=4 SUPPORTS REFERENCES TO RECORD-NAMES# 
               #DEFINED IN INDEXED FILES# 
               ERROR(TRIVIAL,818,TABLELINE,TABLECOLUMN);
               END
          RETURN; 
SUB29:  
#WRITE FROM#
            #WRITE FROM MUST REFERENCE IDENTIFIER#
            FIX1 = 0; 
            REG1 = GET(DN$TYPE,DNAT$,TABLENAME);
            IF REG1 EQ NONDATA THEN 
               FIX1 = 26; 
            IF FIX1 NQ 0 THEN 
               ERROR(SEVERE,FIX1,LINE$,COLUMN$);
          IF GET(DN$MAJMSEC,DNAT$,TABLENAME) EQ FDMSEC
             AND
             GET(DN$SUBMSEC,DNAT$,TABLENAME)  EQ
             GET(DN$SUBMSEC,DNAT$,WR$REC) 
          THEN
              ERROR(TRIVIAL,381,TABLELINE,TABLECOLUMN); 
          NGMOVE; 
          NGSTACK(S); 
          NG(WORD[3]);
          SECTEST(S,352); 
          S = S - 1;
          S$= S$- 1;
          RETURN; 
SUB43:  
#WRITE BEFORE#
          WORD [4] = $BEFORE; 
          GOTO WRITE1;
SUB44:  
#WRITE AFTER# 
          WORD [4] = $AFTER;
WRITE1: 
          IF FORMAT EQ 2
          THEN
              ERROR(SEVERE,383,LINE$,COLUMN$);
          SET(FN$WRTEADY,FNAT$,WR$F,1); 
          RETURN; 
SUB46:  
#WRITE ADV PAGE#
          WORD [5] = $PAGE; 
          RETURN; 
SUB47:  
#WRITE ADV IDENT# 
          IF TRUEFALSE EQ 1 
          THEN BEGIN
               #MNEMONIC NAME#
               IF CCTFIPSLEVEL LS 3 
               THEN BEGIN 
                    # FIPS=3 SUPPORTS WRITE BEFORE/AFTER #
                    # ADVANCING MNEMONIC-NAME # 
                    ERROR(TRIVIAL,821,TABLELINE,TABLECOLUMN); 
                    END 
               IF GET(FN$LINAGPTR,FNAT$,WR$F) NQ 0
               THEN BEGIN 
                    ERROR(SEVERE,394,TABLELINE,TABLECOLUMN);
                    RETURN; 
                    END 
               # VERIFY THAT MNEMONIC NAME IS # 
               # ASSOCIATED WITH A CARRIAGE   # 
               # CONTROL CHARACTER.           # 
               IF GET(DN$TYPE,DNAT$,TABLENAME) EQ ERRTYPE 
               THEN RETURN; 
               REG1 = GET(DN$IMPLPTR,DNAT$,TABLENAME);
               IF GET(PL$LENGTH,PLT$,REG1) NQ 1 
               THEN BEGIN 
                    ERROR(SEVERE,395,TABLELINE,TABLECOLUMN);
                    RETURN; 
                    END 
               WORD [5] = STACK(S); 
               RETURN;
               END
          #ELSE ITS A DNREF.  IT MUST BE AN UNSIGNED INTEGER# 
          IF CCTFIPSLEVEL LS 3
          THEN BEGIN
               # FIPS=3 SUPPORTS WRITE BEFORE/AFTER # 
               # ADVANCING IDENTIFIER LINES # 
               ERROR(TRIVIAL,822,TABLELINE,TABLECOLUMN);
               END
          TRUEFALSE = 1;
          REG1 = GET(DN$TYPE,DNAT$,TABLENAME);
          IF REG1 NQ NUMERIC
             AND
             REG1 NQ COMP1
                 AND
                 REG1 NQ COMP4
             OR 
             GET(DN$POINT,DNAT$,TABLENAME) GR 0 
             OR 
             GET(DN$SIGNGRP,DNAT$,TABLENAME) NQ 0 
          THEN ERROR(SEVERE,384,TABLELINE,TABLECOLUMN); 
          ELSE WORD [5] = STACK(S); 
          RETURN; 
SUB48:  
#WRITE ADV LIT ROUTINE# 
          PLTPTR=LATTEMP; 
          IF GET(PL$TYPE,PLT$,PLTPTR) NQ PLTUNSGNILIT AND 
             GET(PL$CODE,PLT$,PLTPTR) NQ PLTFGCONZERO 
          THEN  ERROR(SEVERE,385,LINE$,COLUMN$);
          ELSE BEGIN
               SET(DN$NUMLEN,DNAT$,DNATLENGTH,7); 
          SET(DN$ITMLEN,DNAT$,DNATLENGTH,10); 
          SET(DN$TYPE,DNAT$,DNATLENGTH,BINARY); 
               WORD [5] = STACK(S); 
               END
          RETURN; 
SUB51:  
#WRITE INVALID KEY# 
          WORD [2] = $SINVALIDKEY;
          #ORGANIZATION MUST NOT BE SEQ. #
          IF FORMAT NQ 2
          THEN BEGIN
               ERROR(SEVERE,387,LINE$,COLUMN$); 
               RETURN;
               END
          WRITEGTEXT; 
          NG($INVALIDKEY);
          NG(WORD[1]);
          IF ENDADDRESS EQ 0
          THEN ENDADDRESS = NEXTPNAT; 
          NSFLAG = 1; 
          NGLABELREF(ENDADDRESS,GFALSE);
          RETURN; 
SUB50:  
#WRITE EOP# 
          IF GET(FN$LINAGPTR,FNAT$,WR$F) EQ 0 
          THEN BEGIN
               ERROR(SEVERE,388,LINE$,COLUMN$); 
               RETURN;
               END
          WRITEGTEXT; 
          NG($EOP); 
          IF ENDADDRESS EQ 0
          THEN ENDADDRESS = NEXTPNAT; 
          NSFLAG = 1; 
          NGLABELREF(ENDADDRESS,GFALSE);
          RETURN; 
SUB49:  
#WRITE NO EOP#
          #IF FILE IS NOT SEQUENTIAL, THERE MUST BE    #
          #A DECLARATIVE SINCE THERE IS NO INVALID KEY #
          IF FORMAT EQ 2
          THEN BEGIN
               IF GET(FN$ERRPTR,FNAT$,WR$F) EQ 0
                  AND 
                  OUTPUTDECL EQ 0 
                  AND 
                  IODECL     EQ 0 
                  AND 
                  EXTENDDECL EQ 0 
               THEN  ERROR(JOD,386,VERBLINE,VERBCOLUMN);
               END
          WRITEGTEXT; 
          RETURN; 
SUB53:  
#RETURN ROUTINE#
          VD; 
          RETURN; 
SUB54:  
#RETURN FILE ROUTINE# 
          XSTACK(2,VALUE$); 
          IF GET(DN$LEVEL,DNAT$,VALUE$) NQ SDDESCR
          THEN BEGIN
               ERROR(SEVERE,300,LINE$,COLUMN$); 
               XSTACK(1,0); 
               END
          ELSE BEGIN
               WR$F = GET(DN$FNATPTR,DNAT$,VALUE$); 
               IF WR$F EQ 0 OR
                  GET(FN$ABORT,FNAT$,WR$F) EQ 1 
               THEN BEGIN 
                    ERROR(PROPAGATED,365,LINE$,COLUMN$);
                    RETURN; 
                    END 
          XSTACK(1,WR$F); 
               END
          S=2;
          S$=1; 
          FILEADDRESS=VALUE$; 
          NG($RETURN);
          NGGTX(GFILEREF,STACK(1),0); 
          NG($RETURNATEND); 
          RETURN; 
SUB55:  
#RETURN INTO PROLOGUE ROUTINE#
          NGPROCREF((NEXTPNAT),GTRUE);
          K=PNATLENGTH; 
          RETURN; 
SUB56:  
#RETURN INTO ID ROUTINE#
          IF GET(FN$VRECLEN,FNAT$,WR$F) EQ 1
          THEN ERROR(JOD,339,TABLELINE,TABLECOLUMN);
          #ERROR IF THE INTO IDENTIFIER IS IN THE FILE# 
          REG1 = GET(FN$SMSECNO,FNAT$,WR$F);
          IF GET(DN$MAJMSEC,DNAT$,TABLENAME) EQ FDMSEC AND
             GET(DN$SUBMSEC,DNAT$,TABLENAME) EQ REG1
          THEN ERROR(SEVERE,340,TABLELINE,TABLECOLUMN); 
          NG($MOVERECORD);
          NGGTX(GFILEREF,STACK(1),0); 
          NGSTACK(3); 
         SECTEST(3,353);
          FILEDEBUG(ANS); 
          XSTACK(1,$GOTO);
          IF ENDADDRESS EQ 0
          THEN ENDADDRESS = NEXTPNAT; 
          NSFLAG=1; 
          XSTACK(2,GTX(GPROCREF,ENDADDRESS,0)); 
          XSTACK(3,GTX(GVERB,K,GLABEL));
          RETURN; 
SUB57:  
#RETURN NO INTO ROUTINE#
          IF ENDADDRESS EQ 0
          THEN ENDADDRESS = NEXTPNAT; 
          NSFLAG=1; 
          NGPROCREF(ENDADDRESS,GFALSE); 
          PERFMPATCH=G; 
          FILEDEBUG(ANS); 
          IF ANS EQ 1 
          THEN BEGIN
               SETGT(PERFMPATCH,GTX(GPROCREF,(NEXTPNAT),GTRUE));
               NGGOTO;
               NGPROCREF(ENDADDRESS,0); 
               NGLABELDEF(PNATLENGTH);
               END
          RETURN; 
          END #SET7#
          TERM
