*DECK INTERPRE
USETEXT CCTTEXT 
USETEXT DBTEXT
PROC INTERPRETTER;
  BEGIN 
  CONTROL PACK; 
  
  # THIS PROC USES THE TOKENS PRODUCED BY CLASSIFIER AS INPUT 
    AND PRODUCES THE CTEXT AND RELATED TABLES SUCH AS THE DNT 
    AND THE PLT.
  # 
  # 
    THE STRUCTURE OF INTERPRETTER IS AS FOLLOWS:  
      1. INITIALIZATION.
      2. DO THE IDENTIFICATION DIVISION. (*)
      3. DO THE ENVIRONMENT DIVISION. (*) 
      4. DO THE DATA DIVISION. (*)
      5. DO THE PROCEDURE DIVISION. (*) 
      6. RESOLVE REFERENCES. (*)
      7. BUILD THE PNAT. (*)
      8. CLEAN-UP.
      ( THE * INDICATES THAT IT WAS PERFORMED BY A PROCEDURE CALL ) 
  
    THE CTEXT AND CCT PROCESSING OCCURS ONLY IN INTERPRETTER. ALL OTHER 
    TABLES AND TEXTS ARE HANDLED ONLY IN TBLPROCS ( EXCEPT ETEXT).
  
    PARSING IS DONE IN 2 WAYS:  
      1. EXECUTABLY, USUALLY FOR THINGS WHICH HAPPEN OFTEN( EG. DNDEFS).
      2. INTERPRETIVELY, USUALLY FOR THINGS WHICH HAPPEN LESS OFTEN 
         ( EG SORT STATEMENT ). 
    ALL INTERPRETIVE PARSING IS DONE BY THE ROUTINE CALLED SPECIALPARSE.
  
    PROCEDURE CTEXTBUILDER BUILDS A CTEXT ATOM.  IT IS EITHER OUTPUT
    TO THE CTEXT OR STACKED, DEPENDING ON THE SITUATION.  IF STACKED, 
    IT IS EITHER EVENTUALLY OUTPUT TO CTEXT OR DELETED. 
  # 
        COMMON CLACOM ; 
          BEGIN 
  
  
  ITEM NEXTCHCODE I, # CODE FOR CHAR IN NEXTCH #
       BUFFERCODE I, # CODE FOR CHAR IN BUFFER #
       PNSW       B, # SET ON IF NO ALPHABETIC CHARACTERS IN AN AW #
       POINTLOC   I, # POSITION OF DECIMAL POINT IN SAREA # 
       LIMIT      I; # MAX. ALLOWABLE NUMBER OF CHAR[S IN TOKEN#
          END 
  
          COMMON SSCOM; 
            BEGIN 
              ITEM NEXTCH    C(1);      # FIRST CHAR RETURNED # 
              ITEM BUFFER    C(1);      # SECOND CHAR RETURNED #
              ITEM LINENO    I;         # LINE NUMBER OF CHAR READ #
              ITEM COLNO     I;         # COLUMN NUMBER OF CHAR READ #
              ITEM RL        I;         # SIGNIFICANT RECORD LENGTH # 
              ARRAY  WSA[0:14];        #SOURCE LISTING BUFFER#
                ITEM BUF     C(0,0,10); 
           END
    # EXTERNAL ROUTINES CALLED BY INTERPRETTER #
  
    XREF BEGIN
           PROC DISPLAY;
           PROC CBLIST;       # OUTPUTS SOURCE LINE # 
              PROC  PUTDMSG; #DISPLAY ONLY MESSAGE ROUTINE# 
           FUNC DEC C(10);     # CONVERTS INTEGER TO CHARACTER #
              PROC BKSPSQ;   #BACKSPACE SQ FILE#
          # THE FOLLOWING 4 PROCS CREATE AN ENTRY IN A TABLE# 
          PROC AWRTBUILD; 
              FUNC  CMM$AGR;
              FUNC  CMM$ALV;
              PROC  CMM$GLV;
          PROC PLTBUILD;
          PROC PNTBUILD;
          PROC DECLPNT; 
          PROC DNTBUILD;
          PROC DNTEXTRA; # ALLOCATES DNT ENTRY #
          PROC PNTNAME; # PUTS NAME,LINE,COL IN NEW PNT ENTRY # 
          PROC PNTREMOVE; # REMOVE LAST PNT ENTRY MADE #
          PROC AWRTRESOLVE; # RESOLVE REFERENCES BEFORE PROCEDURE 
                              DIVISION IS STARTED # 
          PROC PDPNRESOLVE; # RESOLVE PROC. NAME REFERENCES # 
          PROC PDDNRESOLVE; # RESOLVE DATA  NAME REFERENCES # 
          PROC INITTBLPROCS; # INITIALIZE ABOVE ROUTINES #
              PROC  INITRWINFOVE; 
     PROC  DNTSCP;
          PROC CORRESOLVE;    #RESOLVE REFERENCE IN CORRESPONDING#
          PROC   INITFINDPAIR  ; # INITIALIZE FINDPAIR FUNCTION # 
          PROC   FINDPAIR  ; # FINDS NEXT PAIR OF CORRESP. ITEMS #
         PROC SPBTBUILD; # ADDS AN ENTRY TO THE SPBT #
         PROC CRLITATOM; #CREATES A LIT ATOM FOR THE DEBUGG. FACILITY#
      # STORES THE PROC NAME USED IN AN ALTER STAT. INTO THE PLT# 
         PROC  ALTERLIT;
         PROC REDEFRESOLVE; #USED TO RESOLVE REDEFINES REF #
          PROC STOREPRGID; #STORES THE PROGRAM-ID INTO THE PLT# 
         PROC PNATBUILD; # BUILD SKELETON PNAT #
      PROC REPLDON; # FREE REPLACE STMTS CMM BLOCKS # 
          PROC STORALLPROCS; #STORES ALL PROCEDURE NAMES INTO THE PLT#
          PROC OUTPUT;       # OUTPUTS ITS ARGS AFTER CONCAT #
              FUNC  VIRTUAL;
          PROC TMSPLIT; 
         END
  
          # DEFINITION OF ERROR MESSAGE GENERATION MACRO #
      XREF BEGIN
          ITEM  PLTSTRQUOTE;
             ITEM QUOTE C(1); # REAL QUOTE MARK # 
            ITEM CURSIGN  C(1);  #REAL CURRENCY SIGN# 
            ITEM DECPOINT C(1);  #REAL DECIMAL POINT# 
              ITEM  GROUP1FLAG; 
           END
  
          XREF
          BEGIN 
              PROC  DATECMP;           # PROCESS *DATE-COMPILED*       #
              PROC  SKIPCLASSIFY; 
              PROC  TKNCLASSIFY;
              PROC  INITGETCH;
              PROC  SSDIAGS;
              FUNC CMM$ALV I; 
              ITEM CSTATE;
          END 
  
      # DECLARE TEMPORARIES # 
  
          ITEM I,J,K,L,CH1 C(1) ; 
          ITEM  QUALIFPTR, QUALIFFLAGS      I;
          ITEM ENDDCLFLAG               I;
  
      # DECLARE SOURCE LINE IMAGE BOUNDARIES #
      XREF ITEM BMARGIN I;
  
      # DECLARATION OF TRACE SWITCHES # 
      $BEGIN
      XREF
        BEGIN 
          ITEM INDEBUG    B; # INTERPRETTER TRACE SWITCH #
          ITEM CLDEBUG    B; # CLASSIFIER TRACE SWITCH #
          ITEM GEDEBUG    B; # GETCH TRACE SWITCH # 
          ITEM OLDINDEBUG B; # SAVED INTERPRETTER TRACE SWITCH #
          ITEM OLDCLDEBUG B; # SAVED CLASSIFIER TRACE SWITCH #
          ITEM OLDGEDEBUG B; # SAVED GETCH TRACE SWITCH # 
        END 
      $END
  
      # DEFINE SOME USEFUL MACROS # 
      ITEM DUMMYQQZZ1;
      DEF ASLONGAS #FOR DUMMYQQZZ1=0 WHILE#;
      DEF DOFOREVER # FOR DUMMYQQZZ1=0 DO #;
  
      DEF SERR #2#;      # SEVERE ERROR CODE #
      DEF TERR #5#;      # TRIVIAL ERROR CODE # 
      DEF DERR #1#; 
      DEF PERR #3#; 
      DEF AERR #4#; 
      DEF JERR #6#; 
  
      DEF  D004  #004#; 
      DEF  D013  #013#; 
      DEF  D014  #014#; 
      DEF  D015  #015#; 
      DEF  D018  #018#; 
      DEF  D020  #020#; 
      DEF  D021  #021#; 
      DEF  D025  #025#; 
      DEF  D026  #026#; 
      DEF  D027  #027#; 
      DEF  D029  #029#; 
      DEF  D030  #030#; 
      DEF  D031  #031#; 
      DEF  D032  #032#; 
      DEF  D034  #034#; 
      DEF  D035  #035#; 
      DEF  D047  #047#; 
      DEF  D049  #049#; 
      DEF  D054  #054#; 
      DEF  D055  #055#; 
      DEF  D056  #056#; 
      DEF  D057  #057#; 
      DEF  D099  #099#; 
      DEF  D150  #150#; 
      DEF  D202  #202#; 
      DEF  D209  #209#; 
      DEF  D249  #249#; 
      DEF  D321  #321#; 
      DEF  D322  #322#; 
      DEF  D402  #402#; 
      DEF  D404  #404#; 
      DEF  D405  #405#; 
  
    # DECLARE ITEMS WHICH CLASSIFIER SETS UP TO DESCRIBE
      THE TOKEN WHICH IT HAS ASSEMBLED
    # 
  
*CALL AWRT
*CALL PLT1
*CALL RAPLUSC 
  
  
          XREF
              BEGIN          # (DEFINED IN COPYDAT)                    #
              ITEM  CLATYPE      I;    # TYPE OF TOKEN                 #
              ITEM  CLAVALUE     I;    # AUXILIARY VALUE               #
              ITEM  CLACOLUMN    I;    # COLUMN OF FIRST CHARACTER     #
              ITEM  CLALINE      I;    # LINE OF FIRST CHARACTER       #
              ITEM  SIGNSW       B;    # IFF LIT IS SIGNED             #
              ITEM  SAREALENGTH  I;    # LENGTH OF TOKEN IN CHARACTERS #
              ARRAY STRINGAREA [0:25];
                  ITEM  SAREA        C(0, 0,10);
              END 
*CALL BUG020C$
  
 #        SAVE AREA FOR SPECIAL-NAMES PROCESSING OF IMPLEMNTOR/ALPHABET#
  
          ITEM   SV$CLATYPE        I; 
          ITEM   SV$CLAVALUE       I; 
          ITEM   SV$CLACOLUMN      I; 
          ITEM   SV$CLALINE        I; 
          ITEM   SV$SAREA0         C(10); 
          ITEM   SV$SAREA1         C(10); 
          ITEM   SV$SAREA2         C(10); 
          ITEM   SV$SAREALEN       I; 
          ITEM   SV$CLAS           B = FALSE;    # NO CLA-S SAVED # 
          ITEM   FND$IMP           B = FALSE;    # ALPHABET [IS]
                                       IMPLEMENTOR-NAME FLAG #
          ITEM   ABET$SEEN         B = FALSE;    # "ALPHABET <NAME> IS" 
                                       CLAUSE SEEN #
  
#     SAVE AREA FOR PERFORM PARSING                                    #
  
          ITEM   SAVEDTOKENS  B=FALSE; # FLAG FOR WHEN                 #
          ITEM   SVHX         I;       # SAVE ARRAY HIGH INDEX         #
          ITEM   SVLX         I;       # SAVE ARRAY LOW  INDEX         #
  
          ARRAY  SV$ARRAY [1:4] S(5); 
              BEGIN 
              ITEM  SV$SIGNSW    B(0,0,1);
              ITEM  SV$TYPE      I(0,1,5);
              ITEM  SV$COLUMN    I(0,6,18); 
              ITEM  SV$LINE      I(0,24,18);
              ITEM  SV$VALUE     I(0,42,18);
              ITEM  SV$0SAREA    C(1,0,60); 
              ITEM  SV$1SAREA    C(2,0,60); 
              ITEM  SV$2SAREA    C(3,0,60); 
              ITEM  SV$SALEN     I(4,42,18);
              END 
  
  # GIVE NAMES TO CLASSIFIER TOKEN CODES WHICH GO INTO CLATYPE# 
  
          STATUS TKNTYPE
*CALL TKNTYPE 
  
  
          DEF ILITTYPE       #TKNTYPE"ILIT"#; 
          DEF NLITTYPE       #TKNTYPE"NLIT"#; 
          DEF FLITTYPE       #TKNTYPE"FLIT"#; 
          DEF QLITTYPE       #TKNTYPE"QLIT"#; 
          DEF AWTYPE         #TKNTYPE"AW"#; 
          DEF OPTYPE         #TKNTYPE"OP"#; 
          DEF PUNCTYPE       #TKNTYPE"PUNC"#; 
          DEF RPTYPE         #TKNTYPE"RP"#; 
          DEF LPTYPE         #TKNTYPE"LP"#; 
          DEF REWDTYPE       #TKNTYPE"REWD"#; 
          DEF PICTYPE        #TKNTYPE"PIC"#;
          DEF EODTYPE        #TKNTYPE"EOD"#;
          DEF PNDEFTYPE      #TKNTYPE"PNDEF"#;
          DEF PNREFTYPE      #TKNTYPE"PNREF"#;
          DEF FIGCONTYPE     #TKNTYPE"FIGCON"#; 
          DEF SPECREGTYPE    #TKNTYPE"SPECREG"#;
          DEF PTDELIMTYPE    #TKNTYPE"PTDELIM"#;
          DEF BLITTYPE       #TKNTYPE"BLIT"#; 
  
*CALL RW
  
*CALL RWINFOV 
  
  
    DEF  USEUPSEMI  #CONTROL LIST#;   #THIS CAN BE USED AT THE END# 
                                      #OF A DEF TO USE UP THE SEMI# 
                                      #COLON AFTER THE CALL TO THE# 
                                      #DEF.                       # 
  
    $BEGIN
    DEF  TOKENTRACE 
  
#IF INDEBUG THEN OUTPUT(8," CLATYPE= ",DEC(CLATYPE)," CLAVALUE=",DEC( 
CLAVALUE)," CLALINE= ",DEC(CLALINE)," CLACOL=  ",DEC(CLACOLUMN));#; 
  
    XREF  PROC  ABORTSS;
  
    $END
  
   DEF GETPICTOKEN  # TKNCLASSIFY; $BEGIN IF CLATYPE NQ PICTYPE 
                                   THEN ABORTSS("PRPICTURE"); $END I=I#;
  
   DEF  GETTOKEN  #TKNCLASSIFY#;
  
    DEF SKIPTOAAREA  #SKIPCLASSIFY#;  #ADVANCE
                       UNTIL HIT START OF TOKEN IN AAREA #
  
    DEF NOTEOD #CLATYPE NQ EODTYPE# ; # NOT END OF FILE TOKEN # 
  
    ITEM IDDIVSTATUS  U; # STATUS WORD FOR PARSING IDENT. DIVISION #
    ITEM COMMENTENTRY B; # IGNORE TOKEN FLAG IN PARSING IDENT. DIV. # 
    ITEM PROGRAMID C(10); # HOLDS PROGRAM-ID #
          ITEM   COM$MSG C(20) =  "COMPILING SOME NAME "; 
                             #DISPLAY ONLY DAYFILE MESSAGE# 
          ITEM   $$DUMMY$$   I = 0;    #TERMINATE MESSAGE#
    XREF ITEM LISTID C(10); # LISTING HEADER ID # 
    XREF ITEM LISTHED C(80); # LISTING PAGE HEADER #
          XREF ITEM HOLDDATECMP B;
    XREF ITEM LISTDAT C(10); # LISTING CURRENT DATE # 
   ITEM  SSLINE  U  ;  # S-SCANNER LINE NO  # 
  
  
*CALL TABLNAMES 
*CALL WORKTABS
  
    # DDCTEXTBUILD
  
      BUILD CTEXT ATOM FOR DATA DIVISION ATOMS. FOR NOW AND 
      MAYBE FOREVER THIS IS THE SAME AS EDCTEXTBUILD. 
    # 
    DEF DDCTEXTBUILD         #EDCTEXTBUILD#;
  
    # PDCTEXTBUILD
  
      BUILD CTEXT ATOM FOR PROCEDURE DIVISION ATOMS. FOR NOW
      AND MAYBE FOREVER THIS IS THE SAME AS EDCTEXTBUILD. 
    # 
    DEF PDCTEXTBUILD         #EDCTEXTBUILD#;
  
    XDEF  BEGIN 
    ITEM CTTYPE   U,      # CTEXT TYPE FIELD FOR CURRENT ATOM#
         CTVALUE  U,      # VALUE FIELD FOR CURRENT ATOM #
         CTCOLUMN U,      # COLUMN FIELD FOR CURRENT ATOM # 
         CTKEY    U;      # FEY FIELD FOR CURRENT ATOM   #
  END 
  
    DEF  GETNEXTCTEXT     # CTEXTNEXT = CTEXTNEXT + 1 #;
    ITEM MUSTSAVECTXT  B; # SHOWS THAT CTEXT MUST BE STACKED #
    ITEM CTSP          I; # CTEXT STACK INDEX # 
          ITEM  CTSTACKSZ;
    XDEF  ITEM  CTEXTNEXT  U  ; # NEXT FREE CTEXT ENTRY INDEX  #
    ITEM REALCTEXT     U; # VIRTUAL CTEXT INDEX # 
    ITEM WHICHWORD     U; # WHICH PART WORD FOR CURRENT CTEXT ATOM #
  
*CALL CTEXT 
          BASED  ARRAY  CTEXTSTACK[0];
      BEGIN 
        ITEM  CTKEYSTACK  CT$KEY1;
        ITEM  CTCOLSTACK  CT$COL1;
        ITEM  CTTYPESTACK  CT$TYPE1;
        ITEM  CTVALUESTACK  CT$VALUE1;
        ITEM  CTSTACKATOM   CT$ATOM1; 
      END 
  
          ARRAY  SAVCTEXT;
              BEGIN 
              ITEM  SAVCTKEY  CT$KEY1;
              ITEM  SAVCTCOL  CT$COL1;
              ITEM  SAVCTTYP  CT$TYPE1; 
              ITEM  SAVCTVAL  CT$VALUE1;
              ITEM  SAVCTATM  CT$ATOM1; 
              END 
*CALL CTXTVALS
  
    # DEFINE A TRANSLATE VECTOR FROM CLASSIFIER TOKENS FOR
      SPECIAL REGISTERS TO CTEXT TYPES FOR THEM # 
  
    ARRAY SPECREGTTOC [0:11] S(2);
      BEGIN 
              ITEM  SPECREGRW U(0,0,60) = [RWLINECOUNTE,RWLINAGECOUN, 
             RWPAGECOUNTE,RWDEBUGITEM,RWDEBUGLINE,RWDEBUGNAME,
       RWDEBUGSUB1,RWDEBUGSUB2,RWDEBUGSUB3,RWDEBUGCONTE,RWDEBUGNUMER, 
             RWHASHEDVALU]; 
        ITEM CTSPECREG U(1,0,60)=[CTLINECOUNT,CTLINAGECOUN, 
             CTPAGECOUNT, CTDEBUGITEM,CTDEBUGITEM, CTDEBUGITEM, 
       CTDEBUGITEM,CTDEBUGITEM,CTDEBUGITEM,CTDEBUGITEM,CTDEBUGITEM, 
             CTHASHEDVALU]; 
      END 
  
    ITEM DEFINITION B, # INDICATES THAT THE AW IS A DEFN. # 
         LEVELINDSW   B, # INDICATES ILLEGAL LEVEL        # 
         INSPECIALNAM B, # INDICATES IN SPECIALNAMES PARA. #
         NOTVALUEOF B, # INDICATES NOT IN "VALUE OF" CLAUSE # 
         INFD B,     # IN AN FD DEFINITION #
         INRD B,     # IN AN RD DEFINITION #
         DELETESWITCH B; # INDICATES PARAGRAPH TO BE DELETED. # 
    XDEF
      BEGIN 
        ITEM FILLERSWITCH B; # INDICATES DEFN. WAS NAMELESS # 
        ITEM ILITISPNREF  B; # INDICATES UNSIGNED ILIT IS A PNREF # 
        ITEM FDLINAGE     U; # LAST FD WITH LINAGE CLAUSE # 
        ITEM LASTFD       U; # LAST FD SEEN # 
        ITEM LASTRD       U; # LAST RD SEEN # 
        ITEM AWISPNREF    B; # INDICATES THAT AN AW IS A PNREF #
        ITEM FDLINAMBIG B; # 1 IF MORE THAN 1 FD WITH LINAGE #
        ITEM DCLSWITCH B;    # INDICATES IF IN DECLARATIVES # 
        ITEM ALLOWLRGILIT B; # ILIT GR 18 DIGITS ALLOWED               #
      END 
  
    XREF
      BEGIN 
        ITEM LEVELNUMVALU U; # LEVEL NUMBER VALUE # 
        ITEM DNTNEXT U; # HOLDS INDEX OF NEXT FREE DNT ENTRY #
        ITEM PNTNEXT U; # HOLDS NEXT FREE PNT ENTRY INDEX # 
        ITEM PLTNEXT U; # HOLDS NEXT FREE PLTATTRIBUTE INDEX #
        ITEM PLSTNEXT U; # NEXT FREE PLTSRING  INDEX #
        ITEM AWRTNEXT U; # HOLDS INDEX OF NEXT FREE AWRT ENTRY #
        ITEM SPBTNEXT U; # HOLDS NEXT FREE SPBT INDEX # 
        ITEM INTNEXT U; # NEXT FREE INT ENTRY INDEX # 
        ITEM INTINDEX U; # HOLDS CURRENT INT INDEX #
        ITEM PICCOUNT U; # HOLDS NUMBER OF PICTURE LITERALS SEEN -
                       ALSO IS THE PAT POINTER #
        ITEM PDDNREFINDEX U; # HOLDS DNT INDEX FOR A DNREF #
        ITEM SEGNUMBER U; # HOLDS SEGMENT NUMBER #
        ITEM SECTSWITCH B; # INDICATES IF SECT. OR PARA. DEFN. #
        ITEM USEFORDEBUG B; # INDICATES IF PROC-NAME IS IN A
                              "USE FOR DEBUGGING" SECTION. #
        ITEM CODEAWRT U; # CODE FOR AWRT ENTRY #
        ITEM QUALAWRT U; # INDICATES IF ENTRY IS A QUALIFIER #
        ITEM IMMEAWRT U; # USED FOR IMPLICIT QUALIFIC. #
        ITEM SREGAWRT U; # CODE FOR SPECIAL REGISTERS # 
      END 
  
    ITEM DEBUGOBJLIST  U; #INDICATES IF NOT KNOWN IF DN OR PN REF#
                          #0 MEANS DEFINITELY KNOWN#
                          #1 MEANS "ENTER" USING LIST#
                          #2 MEANS "USE FOR DEBUGGING" LIST#
    ITEM ALLPROCSFLAG  B; #ON IF -ALL PROCEDURES- IS ENCOUNTERED# 
  
    # DECLARATION OF SOURCE PROGRAM DIVISION INDICATORS # 
  
    XDEF ITEM CURRENTDIV U;  # INDICATES CURRENT DIVISION # 
    ITEM NEWDIV          U;  # INDICATES POSSIBLE NEXT DIVISION # 
  
    DEF  INIDENTDIV      #CURRENTDIV EQ IDENTDIV#;
    DEF  INENVIRDIV      #CURRENTDIV EQ ENVIRDIV#;
    DEF  INDATADIV       #CURRENTDIV EQ DATADIV OR
                          CURRENTDIV EQ REPORTSEC#; 
    DEF  INREPORTSECT    #CURRENTDIV EQ REPORTSEC#; 
    DEF  INPROCDIV       #CURRENTDIV EQ PROCDIV#; 
    DEF LEVEL$1TO49      #(LEVELNUMVALU GR 0 AND LEVELNUMVALU LS 50)#;
    DEF  LEVLEL$1TO49    # LEVELNUMVALU GR 0 AND LEVELNUMVALU LS 50 #;
    DEF  LVL$1TO49$77    #(LEVEL$1TO49 OR LEVELNUMVALU EQ 77)#; 
  
    # DEFINITION OF DIVISION ORDINALS # 
  
    DEF  IDENTDIV        #1#; 
    DEF  ENVIRDIV        #2#; 
    DEF  DATADIV         #3#; 
    DEF  REPORTSEC       #4#; 
    DEF  PROCDIV         #5#; 
  
    # THE NEXT 2 ITEM ARE USED TO SAVE THE LINE AND COLUMN OF THE 
      START OF A REFERENCE. THE CTEXT ATOM MUST POINT TO THE START
      BUT AFTER HANDLING QUALIFICATION, THIS INFO WOULD OTHERWISE 
      BE LOST # 
  
    ITEM SAVEDCTLINE U; 
    ITEM SAVEDCTCOL  U; 
  
    XREF
      ARRAY DNTLEVELS[0:9] S(2); # USED BY DNTBUILD # 
        BEGIN 
          ITEM DNTLEVEL1 U(0,0,60); 
          ITEM DNTLEVEL2 U(1,0,60); 
        END 
      # THE ABOVE ARRAY IS MODIFIED WHEN LINK. OR W-S. SECTIONS 
        ARE RECOGNIZED #
  
    ITEM CORRESPFLAG B; # USED WHEN DOING "MOVE CORR" ETC.# 
  
  
    # THE FOLLOWING ARRAY IS USED TO CHECK THAT THE QLIT IN A 
      "CURRENCY SIG" CLAUSE IS LEGAL #
  
    ARRAY ILLEGALCUR [0:31];
      ITEM NOTCURSIGN C(0,0,1) = ["0","1","2","3","4","5","6",
           "7","8","9","A","B","C","D","L","P","R","S","V","X", 
           "Z"," ","*","+","-",".",",",";","(",")","/","="];
  
  
    XREF
      BEGIN # THESE 4 DCL"S USED BY SPBTBUILD # 
        ITEM SPLINE U,
             SPCOL  U,
             SPTYPE U,
             SPDNAT U;
      END 
  
CONTROL EJECT;
  
   CONTROL IFNQ CB5$CDCS,"NO";
    XREF FUNC LJZF  C(30) ; 
          XREF
          BEGIN 
              PROC  DDLSS;
              PROC  DDSUBSC;
              PROC  DDSELEC;
          END 
         CONTROL IFEQ CB5$CDCS,"CDCS1"; 
          XREF PROC DA$CLSB;
         CONTROL FI;
         CONTROL IFEQ CB5$CDCS,"CDCS2"; 
          ITEM IOSECTIONFLG B=FALSE;  #TRUE=I/O SECTION SEEN# 
          ITEM FILECTLFLAG B=FALSE;   #TRUE=FILE-CONTROL SEEN#
          ITEM SSFLAG B=FALSE;   #TRUE=SUB-SCHEMA IS CLAUSE SEEN# 
          ITEM CLALINESAVE I;   #SAVES CLALINE IN CDCSSELECTS#
          ITEM CLACOLSAVE I;   #SAVES CLACOLUMN IN CDCSSELECTS# 
          ITEM SUBSCHLINE I;   #SAVES SUB-SCHEMA LINE NUMBER# 
          ITEM SUBSCHCOLUMN I;   #SAVES SUB-SCHEMA COLUMN NUMBER# 
          ARRAY CDCSBUF [0] S(4); 
             BEGIN
             ITEM AREANAM C(0,0,30); #AREA/RELATION NAME# 
             ITEM ANAME7 C(0,0,7);  #FIRST 7 CHARS. OF AREANAM# 
             ITEM AREANAM0 C(0,0,10); #FIRST WORD OF AREANAM# 
             ITEM AREANAM1 C(1,0,10); #SECOND WORD OF AREANAM#
             ITEM AREANAM2 C(2,0,10); #THIRD WORD OF AREANAM# 
             ITEM ISITAREA U(3,0,15); #0=NAME IS RELATION, ELSE AREA# 
             END
          XREF
             BEGIN
             PROC DE$CLSB;
             PROC BUILDSAT; 
             ITEM DE$ARLL;
             END
          DEF DA$CLSB  #DE$CLSB#; 
         CONTROL FI;
     XDEF ITEM SUBFAIL I;    #COMMUNICATION FLAG WITH -DDSUBSC- AND 
                               -DDSELEC- IN -SSDBPR- OVERLAY# 
  
    XREF FUNC OCT C(40) ; 
          XDEF
      ITEM SELAREANAME C(30);  # NAME OF SELECTED AREA #
   CONTROL FI;
XDEF PROC CTOUTPUT; 
   CONTROL IFNQ CB5$CDCS,"NO";
          XDEF
     ITEM  USEDDL  B;    # SET TRUE IF -SUB-SCHEMA IS -  IS FOUND#
     ITEM RDFLAG B;          #SET TO INDICATE A -READ- VERB IN PROCESS# 
   CONTROL FI;
CONTROL NOLIST ;
CONTROL LIST; 
  
  # BEGINNING OF INTERNAL PROCEDURES #
  
  
  
  PROC SKIPCOMMAS;
    # THIS ROUTINE SKIPS OVER COMMAS AND SEMICOLONS, PUTTING
      OUT THEIR CTEXT ATOMS UNTIL A NON-SEMICOLON, NON-COMMA IS 
      REACHED.    # 
  
    BEGIN 
      $BEGIN
        IF INDEBUG THEN DISPLAY(2," SKIPCOMMAS CALLED.",0,19);
      $END
  
      DOFOREVER 
        BEGIN 
          IF CLATYPE NQ PUNCTYPE THEN # NOTHING TO SKIP OVER #
            RETURN; 
          IF CLAVALUE EQ "." THEN # NOTHING TO SKIP OVER #
            RETURN; 
          # MUST HAVE COMMA OR SEMI TO GET TO HERE #
          EDCTEXTBUILD; 
          CTOUTPUT; 
          GETTOKEN; 
        END # OF DOFOREVER #
  
    END # OF SKIPCOMMAS # 
CONTROL EJECT;
  
  PROC CTOUTPUT;
  
    # THIS ROUTINE RELEASES THE CTEXT ATOM FOR OUTPUT TO THE
      CTEXT FILE #
  
    BEGIN 
  
      IF MUSTSAVECTXT THEN
        STACKCTEXT; 
      ELSE
        BEGIN 
          $BEGIN
          IF INDEBUG THEN # PUT CTEXT IN LINE WITH PROGRAM #
        OUTPUT(8," CTTYPE = ",DEC(CTTYPE)," CTVALUE= ",DEC(CTVALUE),
               " CTCOL = ",DEC(CTCOLUMN)," CTKEY = ",DEC(CTKEY)); 
          $END
          WHICHWORD = CTEXTNEXT/2;
          IF  B<59,1>CTEXTNEXT NQ 0 
          THEN
              BEGIN 
              SAVCTKEY[0] = CTKEY;
              SAVCTCOL[0] = CTCOLUMN; 
              SAVCTTYP[0] = CTTYPE; 
              SAVCTVAL[0] = CTVALUE;
              END 
          ELSE BEGIN #2ND HALFWORD# 
               REALCTEXT = VIRTUAL(TABLETYPE"CTEXT$",WHICHWORD);
               CTEXTKEY2[REALCTEXT] = CTKEY;
               CTEXTTYPE2[REALCTEXT] = CTTYPE;
               CTEXTCOLUMN2[REALCTEXT] = CTCOLUMN;
               CTEXTVALUE2[REALCTEXT] = CTVALUE;
               CTEXTATOM1[REALCTEXT] = SAVCTATM[0]; 
               END
          GETNEXTCTEXT; 
        END 
  
    END # OF CTOUTPUT # 
CONTROL EJECT;
  
      PROC NEWLINEATOM; 
          BEGIN              # PUT OUT A NEW LINE ATOM #
          CTTYPE = CTDELIMITER; 
          CTVALUE = SSLINE; 
          CTKEY = 0;
          CTCOLUMN = 0; 
          CTOUTPUT; 
          END    # OF NEWLINEATOM # 
  
  
  
  
 #        EDCTEXTBUILD.....ALSO KNOW AS DDCTEXTBUILD AND PDCTEXTBUILD  #
  
  
  
      PROC EDCTEXTBUILD;
  
      # BUILD CTEXT ATOM FOR ENVIRONMENT DIV. ATOMS # 
  
      BEGIN 
  
        SWITCH EDCTEXTSW , EDILIT,EDNLIT,EDFLIT,EDQLIT,EDAW,
                           EDOP,EDPUNC,EDRP,EDLP,EDREWD,EDPIC,
                             EDEOD,EDPNDEF,EDPNREF,EDFIG,EDSPEC,,EDBLIT;
        $BEGIN
           IF INDEBUG THEN OUTPUT(2," EDCTXTSW=",DEC(CLATYPE)); 
        $END
  
          IF CLALINE NQ SSLINE THEN # STARTT OF NEWLINE # 
          BEGIN 
             SSLINE = CLALINE;
            NEWLINEATOM;
          END 
  
        GOTO EDCTEXTSW[CLATYPE];
  
  
      EDILIT: EDNLIT: EDFLIT: EDQLIT: EDFIG:  
         EDBLIT:  
        BEGIN # BUILD LITERAL CTEXT ATOM AND PLT ENTRY #
        CTTYPE = CTLITERAL; CTVALUE = PLTNEXT;
        CTCOLUMN = CLACOLUMN; CTKEY = 0;
        PLTBUILD; 
          RETURN; 
        END 
  
  
      EDPNDEF:  
        BEGIN 
        CTTYPE = CTPNDEF; CTVALUE = 0;
        CTCOLUMN = CLACOLUMN; CTKEY = 1;
          RETURN; 
        END 
  
  
      EDPNREF:  
        BEGIN 
          SSDIAGS(D321);
          RETURN; 
        END 
  
      EDAW:EDSPEC:  
        BEGIN  # BUILD DNREF CTEXT ATOM # 
          SSDIAGS(322); 
          RETURN; 
        END 
  
  
      EDOP: 
        BEGIN # BUILD APPROPRIATE CTEXT OPERATOR ATOM # 
        CTVALUE = 0;
        CTCOLUMN = CLACOLUMN; CTKEY = 0;
        IF CLAVALUE EQ "+" THEN CTTYPE = CTPLUS;
        ELSE IF CLAVALUE EQ "-" THEN CTTYPE = CTMINUS;
        ELSE IF CLAVALUE EQ "*" THEN CTTYPE = CTSTAR; 
        ELSE IF CLAVALUE EQ "/" THEN CTTYPE = CTSLASH;
        ELSE IF CLAVALUE EQ "<" THEN CTTYPE = CTLESSTHAN; 
        ELSE IF CLAVALUE EQ ">" THEN CTTYPE = CTGREATER;
        ELSE IF CLAVALUE EQ "=" THEN CTTYPE = CTEQUALS; 
                  ELSE IF CLAVALUE EQ ":" THEN CTTYPE = CTCOLON;
        ELSE CTTYPE = CTEXPONENT; 
          RETURN; 
        END 
  
  
      EDPUNC: 
        BEGIN # BUILD APPROP. CTEXT PUNCTUATION ATOM #
        IF CLAVALUE EQ "." THEN 
           BEGIN
             CTTYPE = CTPERIOD; CTVALUE = 0;
  
             CTCOLUMN= CLACOLUMN; 
             CTKEY = 1; 
           END
        ELSE
        BEGIN 
          CTTYPE = CTDELIMITER; CTCOLUMN = CLACOLUMN; 
          CTKEY = 0;
          IF CLAVALUE EQ "," THEN 
             CTVALUE = CTCOMMA; 
          ELSE
             CTVALUE = CTSEMICOLON; 
        END 
          RETURN; 
        END 
  
  
      EDRP: 
        BEGIN # RIGHT PARENTHESIS # 
        CTTYPE = CTRIGHTPAREN; CTVALUE = 0; 
        CTCOLUMN = CLACOLUMN; CTKEY = 0;
          RETURN; 
        END 
  
  
      EDLP: 
         BEGIN # LEFT PAREN # 
       CTTYPE = CTLEFTPAREN; CTVALUE = 0; 
       CTCOLUMN = CLACOLUMN; CTKEY = 0; 
          RETURN; 
         END
  
  
      EDREWD: 
        BEGIN 
        CTTYPE = CTRESERVEDWD; CTCOLUMN = CLACOLUMN; CTVALUE=CLAVALUE;
        # KEY ELEMENTS DEPEND UPON THE DIVISION THEY ARE IN # 
        # THERE IS NO IDENTIFICATION DIVISION CTEXT # 
        SWITCH KEYSWITCH ,CASEEND, EDKEY, DDKEY, RSKEY, PDKEY;
        $BEGIN
          IF INDEBUG THEN OUTPUT(2," DIV. NUM=",DEC(CURRENTDIV)); 
        $END
        GOTO KEYSWITCH[CURRENTDIV]; 
  
      EDKEY:  
        CTKEY = EDCTEXTKEY[CLAVALUE]; GOTO CASEEND; 
      DDKEY:  
        CTKEY = DDCTEXTKEY[CLAVALUE]; GOTO CASEEND; 
      RSKEY:  
        CTKEY = RSCTEXTKEY[CLAVALUE]; GOTO CASEEND; 
      PDKEY:  
        CTKEY = PDCTEXTKEY[CLAVALUE]; GOTO CASEEND; 
      CASEEND:  
          RETURN; 
        END 
  
  
      EDPIC:  
        BEGIN 
        PICCOUNT = PICCOUNT + 1; # ALSO IS THE PAT INDEX #
        PLTBUILD; # BUILD PLT ENTRY FOR PICTURE LITERAL  #
        CTTYPE = CTPICTURE; CTVALUE =PICCOUNT;
        CTCOLUMN = CLACOLUMN; CTKEY = 0;
          RETURN; 
        END 
  
  
      EDEOD:  
        BEGIN # END OF FILE # 
        CTTYPE = CTDELIMITER; 
        CTVALUE = CTENDOFFILE;
        CTCOLUMN = 12;
        CTKEY = 1;
       CCT1STCOMPIL[0] = TRUE;
          $BEGIN
          ABORTSS("EODCTEXT");
          $END
          RETURN; 
        END 
  
  
      RETURN; 
      END 
  
  
      PROC BUILDCTEXT(TYPE,VALUE,COL,KEY);
  
      # BUILD CTEXT ATOM EXPLICITLY FROM PARAMETERS # 
      BEGIN 
          ITEM   TYPE        U;    # TYPE OF CTEXT ATOM                #
          ITEM   VALUE       U;    # VALUE OF CTEXT ATOM               #
          ITEM   COL         U;    # COLUMN NUMBER FOR THE ATOM        #
          ITEM   KEY         U;    # KEY ELEMENT FIELD                 #
  
       IF  CLALINE NQ SSLINE THEN # START OF NEW LINE # 
          BEGIN 
             SSLINE = CLALINE;
            NEWLINEATOM;
          END 
  
  
        CTTYPE = TYPE;
        CTVALUE = VALUE;
        CTCOLUMN = COL; 
        CTKEY = KEY;
  
        RETURN; 
      END 
CONTROL EJECT;
  
    PROC STACKCTEXT;
      # PUT CTEXT ATOM INTO THE CTEXT STACK # 
  
      BEGIN 
        $BEGIN
          IF INDEBUG THEN OUTPUT(2,"STACKCTEXT"," CALLED.");
        $END
  
        CTSP = CTSP + 1;
          IF  CTSP GQ CTSTACKSZ 
          THEN
              BEGIN 
              CTSTACKSZ = CTSTACKSZ+50; 
              CMM$GLV(CTEXTSTACK,50);    #EXTEND TABLE# 
              END 
          CTTYPESTACK[CTSP] = CTTYPE; 
          CTVALUESTACK[CTSP] = CTVALUE; 
          CTCOLSTACK[CTSP] = CTCOLUMN;
          CTKEYSTACK[CTSP] = CTKEY; 
  
      END # OF STACKCTEXT # 
CONTROL EJECT;
  
    PROC UNSTACKCTEXT(PTR); 
      # PUT OUT  CTEXT ELEMENTS IN THE STACK FROM 0 TO PTR #
  
      ITEM PTR; 
  
      BEGIN 
        $BEGIN
          IF INDEBUG THEN OUTPUT(2,"UNSTACKCTE","XT CALLED.");
        $END
  
        FOR I = 0 STEP 1 UNTIL PTR DO 
          BEGIN 
          $BEGIN
              IF  INDEBUG  THEN 
                  OUTPUT( 10,"I =", DEC(I), "SCTTYPE =",
                      DEC(CTTYPESTACK[I]), "SCTVALUE=", DEC(CTVALUESTACK
                      [I]), "SCTCOL =", DEC(CTCOLSTACK[I]), "SCTKEY =", 
                      DEC(CTKEYSTACK[I]));
          $END
  
          WHICHWORD = CTEXTNEXT/2;
          IF  B<59,1>CTEXTNEXT NQ 0 
          THEN  SAVCTATM[0] = CTSTACKATOM[I]; 
          ELSE BEGIN #2ND HALFWORD# 
               REALCTEXT = VIRTUAL(TABLETYPE"CTEXT$",WHICHWORD);
          CTEXTATOM1[REALCTEXT] = SAVCTATM[0];
              CTEXTATOM2[REALCTEXT] = CTSTACKATOM[I]; 
               END
            GETNEXTCTEXT; 
          END 
  
      END # OF UNSTACKCTEXT # 
CONTROL EJECT;
  
    PROC DOQUALIFIERS;
      # THIS ROUTINE HANDLES THE QUALIFICATION FOR DATA NAME
        REFERENCES AND PROC. NAME REFERENCES. # 
  
      ITEM MOREQUALIFS B; 
      ITEM REFTYPE U; # TYPE PNREFTYPE OR AWTYPE OR SPECREGTYPE # 
  
      BEGIN 
          REFTYPE = CLATYPE;
          MOREQUALIFS = TRUE; 
          QUALIFPTR = 0;
          ASLONGAS MOREQUALIFS DO # PROCESS QUALIFIERS #
            BEGIN 
              IF SAVEDTOKENS
              THEN
                  BEGIN 
                  GETSAVEDTKN;
                  END 
              ELSE
                  BEGIN 
                  GETTOKEN; 
                  END 
              IF (CLATYPE EQ REWDTYPE) AND
                 (CLAVALUE EQ RWOF OR CLAVALUE EQ RWIN) THEN
                BEGIN # HAVE QUALIFIER #
              IF CCTFIPSLEVEL LS 3
              THEN BEGIN
                   #FIPS = 3 SUPPORTS QUALIFICATION#
                   SSDIAGS(D402); 
                   END
             IF QUALIFPTR LQ 59 
             THEN BEGIN 
                 IF CLAVALUE EQ RWOF
                 THEN B<QUALIFPTR,1> QUALIFFLAGS = 1; 
                 ELSE B<QUALIFPTR,1> QUALIFFLAGS = 0; 
                 QUALIFPTR = QUALIFPTR + 1; 
                 END
                  QUALAWRT = 1; # CODE FOR QUALIFIER #
                  IF SAVEDTOKENS
                  THEN
                      BEGIN 
                      GETSAVEDTKN;
                      END 
                  ELSE
                      BEGIN 
                      GETTOKEN; 
                      END 
                  IF CLATYPE NQ REFTYPE THEN # MISSING QUALIFIER# 
                    # OR QUALIFIER TO SPECIAL REGISTER #
                    IF REFTYPE EQ SPECREGTYPE AND CLATYPE EQ
                       AWTYPE THEN
                      BEGIN 
                        AWRTBUILD;
                      END 
                    ELSE
                      BEGIN 
                        SSDIAGS(D020);
                        MOREQUALIFS = FALSE;
                      END 
                  ELSE # PROCESS QUALIFIER #
                    BEGIN 
                      IF CLATYPE EQ SPECREGTYPE THEN
                        BEGIN 
                          IMMEAWRT = 0; 
                          # SET CODE FOR KIND OF SPEC. REG.#
                          FOR SREGAWRT=0 STEP 1 UNTIL 11 DO 
              IF  SPECREGRW[SREGAWRT] EQ CLAVALUE  THEN 
                              GOTO ESCAPE;
                           ESCAPE:  
                        END 
                      AWRTBUILD; # BUILD AWRT ENTRY # 
                    END 
                END 
              ELSE # END OF QUALIFIER LIST #
                BEGIN 
                  MOREQUALIFS = FALSE;
                END 
            END # OF QUALIFIER LOOP # 
  
      END # DOQUALIFIERS #
CONTROL EJECT;
  
    PROC DOREFERENCES;
      # HANDLE DATA OR PROC. REFERENCES IN PROGRAM #
      # THIS INCLUDES SPECIAL REGISTERS.# 
  
  
      BEGIN 
        $BEGIN
          IF INDEBUG THEN DISPLAY(2," DOREFERENCES CALLED.",0,21);
        $END
        INTINDEX = INTINDEX + 1;
        IF CLATYPE EQ PNREFTYPE THEN # HAVE PNREF # 
          BUILDCTEXT(CTPNREF,INTINDEX,CLACOLUMN,0); 
        ELSE # HAVE A DNREF OR SPEC. REG. # 
        IF CLATYPE EQ AWTYPE THEN 
        BEGIN 
          BUILDCTEXT(CTDNREF,INTINDEX,CLACOLUMN,0); 
          IF CCTFIPSLEVEL LS 3 AND
            (C<0,1>SAREA[0] LS "A" OR C<0,1>SAREA[0] GR "Z") THEN 
            SSDIAGS(401); 
          END 
        ELSE # HAVE A SPECIAL REGISTER #
          BEGIN 
            CODEAWRT = AWRTSPECREG; 
            IF INRD THEN IMMEAWRT = LASTRD; # FOR IMPLICIT
                                               QUALIFICATION# 
            ELSE
              IMMEAWRT = 0; 
            # BUILD THE CORRECT CTEXT ATOM #
  
            FOR SREGAWRT = 0 STEP 1 UNTIL 11 DO 
              IF  SPECREGRW[SREGAWRT] EQ CLAVALUE  THEN 
                GOTO ESCAPE;
            ESCAPE: 
           BUILDCTEXT(CTDELIMITER,CTSPECIALREG,0,0);
           CTOUTPUT;
            BUILDCTEXT(CTSPECREG[SREGAWRT],INTINDEX,CLACOLUMN,0); 
          END 
        CTOUTPUT; 
        QUALAWRT = 0; # NOT A QUALIFIER # 
        AWRTBUILD;
       CONTROL IFNQ CB5$CDCS,"NO";
        IF RDFLAG AND USEDDL THEN 
          BEGIN 
          C<0,10>SELAREANAME = SAREA[0];
          C<10,10>SELAREANAME = SAREA[1]; 
          C<20,10>SELAREANAME = SAREA[2]; 
          SUBFAIL = 3;  #EXPECTED STATUS FROM -DA$ARSB-#
          DDSELEC;           #ASCERTAIN IF A RELATION NAME, AND IF SO,
                              MAKE AN SAT ENTRY#
          RDFLAG = FALSE;    #CLEAR FLAG# 
          END 
       CONTROL FI;
          IF  NOT INSPECIALNAM  THEN
              DOQUALIFIERS;        # NO LEGAL QUALS IN SPECIAL-NAMES #
  
      END # DOREFERENCES #
CONTROL EJECT;
  
    FUNC ASCIITOBIN;
      # CONVERT ASCII CHAR. STRING INTO BINARY NUMBER # 
  
      ITEM I,J,K,L; 
  
      BEGIN 
        $BEGIN
        IF INDEBUG THEN 
          BEGIN 
            DISPLAY(2,STRINGAREA,0,SAREALENGTH);
            OUTPUT(2," SAREALEN=",DEC(SAREALENGTH));
          END 
        $END
        K = 0; # INITIALIZE RESULT #
        FOR L = 0 STEP 1 UNTIL SAREALENGTH - 1 DO 
          BEGIN 
            I = L/10; # WORD INDEX #
            J = L - I*10; # CHARACTER INDEX # 
            K = K*10 + (C<J,1>SAREA[I] - "0"); # CALCULATE DIGIT #
          END 
        $BEGIN
        IF INDEBUG THEN OUTPUT(2," BINARY = ",DEC(K));
        $END
        ASCIITOBIN = K; 
  
      END # ASCIITOBIN #
CONTROL EJECT;
  
    PROC DNDEFROUTINE;
      # PROCESS THE DATA NAME DEFINITION #
  
      BEGIN 
        IF FILLERSWITCH 
        THEN BEGIN
             BUILDCTEXT(CTFILLER,DNTNEXT,CLACOLUMN,0);
             END
        ELSE
           BUILDCTEXT(CTDNDEF,DNTNEXT,CLACOLUMN,0); 
        CTOUTPUT; 
        DNTBUILD; # BUILD DNT ENTRY # 
      FILLERSWITCH = FALSE; 
  
      END # OF DNDEFROUTINE # 
CONTROL EJECT;
  
    PROC DODATADEF; 
      # CALLED AFTER A LEGAL LEVEL INDICATOR SEEN TO PROCESS
        THE DEFINITION. # 
    # LEVEL NO. CTEXT IS ALWAYS FOLLOWED BY DNDEF WHEN A LEVEL NO. IS 
      FOLLOWED BY AN AW.  SINCE DATA-NAME OR FILLER OPTIONAL ON LEVEL 
      1 TO 49 AND 77 IF LEVEL NO. NOT FOLLOWED BY AW THEN CTEXT WILL
      BE LEVEL NO. FOLLOWED BY FILLER.  DPARSER EXPECTS THIS AND WILL 
      DIAGNOSE LEVEL NO. WHICH MUST BE FOLLOWED BY AW EI. CD FD 88 ETC.#
  
      BEGIN 
                  BUILDCTEXT(CTLEVELNUM,LEVELNUMVALU,CLACOLUMN,1);
                  CTOUTPUT; 
                  GETTOKEN; 
                  IF CLATYPE EQ AWTYPE THEN 
                    BEGIN 
                      DNDEFROUTINE; # PROCESS DEFINITION #
                      GETTOKEN; 
                    END 
                ELSE # PUT OUT FILLER CTEXT AND BUILD FILLER DNT ENTRY #
                    BEGIN 
                    FILLERSWITCH = TRUE;
                    DNDEFROUTINE; 
                    IF (CLATYPE EQ REWDTYPE) AND (CLAVALUE EQ RWFILLER )
                    THEN
                        BEGIN 
                        IF INREPORTSECT OR NOT LVL$1TO49$77 
                        THEN
                            BEGIN 
                            SSDIAGS(D013);
                            END 
                        GETTOKEN; 
                        END 
                    ELSE
                        BEGIN 
                        IF LVL$1TO49$77 AND NOT INREPORTSECT
                        THEN
                            BEGIN 
                            SSDIAGS(D249);
                            END 
                        END 
                    END 
  
      END # DODATADEF # 
          CONTROL EJECT;
      PROC PUT$ALPHBET; 
          BEGIN 
  
              $BEGIN
              IF  INDEBUG  THEN 
                  OUTPUT(2, "PUT$ALPHBE", "T CALLED");
              TOKENTRACE; 
              $END
          SV$CLATYPE == CLATYPE;
          SV$CLAVALUE == CLAVALUE;
          SV$CLACOLUMN == CLACOLUMN;
          SV$CLALINE == CLALINE;
          SV$SAREA0 == SAREA[0];
          SV$SAREA1 == SAREA[1];
          SV$SAREA2 == SAREA[2];
              $BEGIN
              TOKENTRACE; 
              $END
          LEVELNUMVALU = 55;       # SET ALPHABET-NAME #
          DNDEFROUTINE; 
  
          CLATYPE = SV$CLATYPE;    #RESTORE#
          CLAVALUE = SV$CLAVALUE; 
          CLACOLUMN = SV$CLACOLUMN; 
          CLALINE = SV$CLALINE; 
          SAREA[0] = SV$SAREA0; 
          SAREA[1] = SV$SAREA1; 
          SAREA[2] = SV$SAREA2; 
          SV$CLAS = FALSE;
  
          RETURN; 
          END 
          CONTROL EJECT;
      PROC PUT$IMPNAM;
          BEGIN 
          MUSTSAVECTXT = FALSE; 
              $BEGIN
              IF  INDEBUG  THEN 
                  OUTPUT(2, "PUT$IMPNAM", " CALLED"); 
              TOKENTRACE; 
              $END
          SV$CLATYPE == CLATYPE;
          SV$CLAVALUE == CLAVALUE;
          SV$CLACOLUMN == CLACOLUMN;
          SV$CLALINE == CLALINE;
          SV$SAREA0 == SAREA[0];
          SV$SAREA1 == SAREA[1];
          SV$SAREA2 == SAREA[2];
              $BEGIN
              TOKENTRACE; 
              $END
          CODEAWRT = AWRTDNREF;    # SET DNREF #
          DOREFERENCES; 
          CLATYPE = SV$CLATYPE;    #RESTORE#
          CLAVALUE = SV$CLAVALUE; 
          CLACOLUMN = SV$CLACOLUMN; 
          CLALINE = SV$CLALINE; 
          SAREA[0] = SV$SAREA0; 
          SAREA[1] = SV$SAREA1; 
          SAREA[2] = SV$SAREA2; 
          SV$CLAS = FALSE;
          MUSTSAVECTXT = TRUE;
          RETURN; 
          END 
          CONTROL EJECT;
      PROC CHKIMPS; 
  
          BEGIN 
              $BEGIN
              IF  INDEBUG  THEN 
                  OUTPUT(2, "CHKIMPS CA", "LLED");
              $END
          IF  SAREA [0] EQ "CDC-64"  THEN 
              BEGIN 
              FND$IMP = TRUE; 
              RETURN; 
              END 
          IF  SAREA [0] EQ "ASCII-64"  THEN 
              BEGIN 
              FND$IMP = TRUE; 
              RETURN; 
              END 
          IF  SAREA [0] EQ "EBCDIC"  THEN 
              BEGIN 
              FND$IMP = TRUE; 
              RETURN; 
              END 
          IF  SAREA [0] EQ "UNI"  THEN
              FND$IMP = TRUE; 
          RETURN; 
  
          END 
CONTROL EJECT;
  
  FUNC RWCOMMAND(CODE) B ;
    # IF THE CURRENT CLASSIFIER TOKEN IS A RESERVED WORD WITH 
      CODE "CODE" THEN DO CTEXT PROCESSING AND GET NEXT TOKEN # 
  
    ITEM CODE U;
  
    BEGIN 
      $BEGIN IF INDEBUG THEN DISPLAY(2," RWCOMMAND CALLED,",0,18);
      $END
      SKIPCOMMAS; 
      IF CLATYPE EQ REWDTYPE AND CLAVALUE EQ CODE THEN
        BEGIN 
          PDCTEXTBUILD; CTOUTPUT; GETTOKEN; RWCOMMAND = TRUE; 
        END 
      ELSE
        RWCOMMAND = FALSE;
  
    END # OF RWCOMMAND #
CONTROL EJECT;
          PROC SAVETOKEN; 
  
#     SAVE A TOKEN FOR PERFORM PARSING ON A STACK                      #
  
          BEGIN 
          SVHX = SVHX + 1;
              $BEGIN
              IF SVHX GR 4 THEN ABORTSS("SAVEDTOKEN");
              $END
          SV$SIGNSW[SVHX] = SIGNSW; 
          SV$TYPE[SVHX] = CLATYPE;
          SV$COLUMN[SVHX] = CLACOLUMN;
          SV$LINE[SVHX] = CLALINE;
          SV$VALUE[SVHX] = CLAVALUE;
          SV$0SAREA[SVHX] = SAREA[0]; 
          SV$1SAREA[SVHX] = SAREA[1]; 
          SV$2SAREA[SVHX] = SAREA[2]; 
          SV$SALEN[SVHX] = SAREALENGTH; 
          RETURN; 
          END 
  
  
          PROC GETSAVEDTKN; 
  
#     RETRIEVE TOKEN FROM BOTTOM OF STACK FOR PERFORM PARSING          #
  
          BEGIN 
              $BEGIN
              IF SVLX EQ 0 THEN ABORTSS("GETSVDTKN ");
              $END
          SIGNSW = SV$SIGNSW[SVLX]; 
          CLATYPE = SV$TYPE[SVLX];
          CLACOLUMN = SV$COLUMN[SVLX];
          CLALINE = SV$LINE[SVLX];
          CLAVALUE = SV$VALUE[SVLX];
          SAREA[0] = SV$0SAREA[SVLX]; 
          SAREA[1] = SV$1SAREA[SVLX]; 
          SAREA[2] = SV$2SAREA[SVLX]; 
          SAREALENGTH = SV$SALEN[SVLX]; 
          IF SVLX GQ SVHX 
          THEN
              BEGIN 
              SVLX = 1; 
              SVHX = 0; 
              SAVEDTOKENS = FALSE;
              END 
          ELSE
              BEGIN 
              SVLX = SVLX + 1;
              END 
          RETURN; 
          END 
CONTROL EJECT;
  
          PROC  SPECIALPARSE(RWSWITCH); 
          ITEM  RWSWITCH  S:SPRW; 
    BEGIN 
   #
      THIS PROCEDURE DOES THE INTERPRETIVE PARSING
                                                  # 
   # DECLARE PARSE LOOP ITEMS#
   ITEM I I, J I, P I;
     ITEM REDEFLINE U, REDEFCOL  U ;
   ITEM  NOLOOKDONE  B,  SORTSYN  B ; 
  ITEM SPBT1ST ;    # HOLDS THE 1ST PARA INFO IN SORT#
          ITEM SPBT2ND;  #HOLDS THE 2ND PN #
    ITEM  LOOKHIT B , TYPE U , LTARGET U ;
  DEF LOOKFOR(PTARGET,PTYPE,PNOTFOUND) #
       TYPE=PTYPE;  LTARGET=PTARGET;  LOOK; 
   IF NOT LOOKHIT THEN GOTO PNOTFOUND 
    # ; 
##
##
PROC LOOK ; 
BEGIN 
# TRY TO FIND THE  "TARGET" TOKEN. #
  SWITCH TYPESW 
    ,ILTYP,NLTYP,FLTYP,QLTYP,AWTYP,OPTYP,PCTYP,RPTYP
    ,LPTYP,RWTYP,PCTYP,EDTYP,PNTYP,PRTYP,FGTYP,SPTYP ;
    # SWITCH LIST ACCORDING TO THE CLASSIFIER TYPE  # 
# # 
    LOOKHIT = FALSE;
# # 
LOOKREP:  
# # 
    IF NOLOOKDONE THEN
      BEGIN 
        GETTOKEN;  NOLOOKDONE= FALSE; 
      END 
# # 
  
           # IGNORE COMMAS, JUST PRODUCE CTEXT# 
            IF CLATYPE EQ PUNCTYPE AND
               CLAVALUE EQ ","  THEN
               BEGIN
                 EDCTEXTBUILD; CTOUTPUT;
                 NOLOOKDONE = TRUE ;
                 GOTO LOOKREP ; 
              END 
  
  
    IF CLATYPE NQ TYPE THEN RETURN ;
# # 
# # 
     GOTO TYPESW[CLATYPE];
# # 
# # 
    NLTYP:FLTYP:QLTYP:AWTYP:  
     EDTYP:PNTYP:PRTYP:FGTYP:SPTYP:PCTYP: 
    # NO FURTHER CHECKS ARE POSSIBLE, # 
    #   THE CORRECT TYPE WAS FOUND . #
        NOLOOKDONE = TRUE  ;
          LOOKHIT = TRUE ; RETURN ; 
# # 
# # 
  
RPTYP:LPTYP:OPTYP:   # LEFT OR RIGHT PARENTHESIS OR OP   #
ILTYP:             #OR INTEGER LITERAL #
               LTARGET = CLAVALUE ; 
               GOTO CHECKVALUE; 
               # FORCE TEST TRUE,THEN GENERATE CTEXT #
  
# # 
# # 
RWTYP:    # THE CLASSIFIER RETURNED A RESRVD WD#
  
           GOTO CHECKVALUE ;
# # 
# # 
CHECKVALUE: 
  #VALID ONLY FOR RESERVED WORDS AND
      PUNCTUATION,  IE THINGS WITH
    VALUES .# 
# CHECK THAT THE CORRECT ITEM WITHIN "CLATYPE" WAS
    RETURNED BY CLASSIFIER  # 
  
      IF CLAVALUE EQ LTARGET THEN 
        BEGIN 
           LOOKHIT = TRUE ; 
        NOLOOKDONE = TRUE ; 
           EDCTEXTBUILD ; 
           CTOUTPUT;
        END 
  
          RETURN; 
  
END  # OF LOOK #
# # 
# # 
CONTROL EJECT;
  
  # THESE ROUTINES ARE USED TO PARSE THE IDENTIFICATION DIVISION #
  
  PROC IDDIVTEST((I));
    BEGIN 
    # THIS ROUTINE TESTS FOR DUPLICATED OR OUT OF ORDER 
      PARAGRAPHS IN THE IDENTIFICATION DIVISION. IT WILL
      GENERATE A DIAGNOSTIC IF THE PARAGRAPH IDENTIFIED BY
      PARAMETER I HAS NOT BEEN SEEN BEFORE OR IS NOT IN 
      THE CORRECT ORDER AS INDICATED BY ITS ORDINAL.
    # 
    ITEM I; 
  
    # HAS THIS ELEMENT ALREADY BEEN RECOGNIZED #
    IF B<I,1>IDDIVSTATUS EQ 1 THEN
      SSDIAGS(D029);
    ELSE
      BEGIN 
        # MARK THIS ELEMENT AS HAVING OCCURRED #
        B<I,1>IDDIVSTATUS = 1;
        # CHECK FOR OUT OF ORDER PARAGRAPH #
        IF B<I+1,7-I>IDDIVSTATUS NQ 0 THEN
         SSDIAGS(D030); 
      END 
    END # IDDIVTEST # 
  
  
  PROC IDDIVPERIOD; 
    BEGIN 
    # THIS ROUTINE TESTS FOR A PERIOD AS NEXT TOKEN IN
      THE SOURCE PROGRAM. IT DIAGNOSES IF NO PERIOD IS
      PRESENT OR IF THE NEXT TOKEN IS A PERIOD IN THE 
      A-AREA. 
    # 
  
    # SEARCH FOR THE REQUIRED PERIOD #
    LOOKFOR(".",PUNCTYPE,IDDIVPERIOD1); 
    GOTO IDDIVPERIOD2;
  IDDIVPERIOD1: 
    # PERIOD IS MISSING - GEN DIAGNOSTIC AND QUIT # 
    SSDIAGS(D027);
    RETURN; 
  IDDIVPERIOD2: 
    # PERIOD FOUND - MAKE SURE ITS IN THE B-AREA #
    IF CLACOLUMN LQ BMARGIN THEN
      SSDIAGS(D026);
  END # IDDIVPERIOD # 
CONTROL EJECT;
          SWITCH  PRODUCTIONSW:SPRW 
              PRTRACEON:     TRACEON, 
              PRTRACEOFF:    TRACEOFF,
              PRIDENTIFICA:  IDENTIFICA,
              PRPROGRAMID:   PROGRAMID, 
              PRAUTHOR:      AUTHOR,
              PRINSTALLATI:  INSTALLATI,
              PRDATEWRITTE:  DATEWRITTE,
              PRDATECOMPIL:  DATECOMPIL,
              PRSECURITY:    SECURITY,
              PRENVIRONMEN:  ENVIRONMEN,
              PRIS:          IS,
              PRDEBUGGING:   DEBUGGING, 
              PRCURRENCY:    CURRENCY,
              PRQUOTE:       QUOTE, 
              PRON:          ON,
              PRSOURCECOMP:  SOURCECOMP,
              PROBJECTCOMP:  OBJECTCOMP,
              PRFILECONTRO:  FILECONTRO,
              PRIOCONTROL:   IOCONTROL, 
              PROFF:         OFF, 
              PRSPECIALNAM:  SPECIALNAM,
              PRDECIMALPOI:  DECIMALPOI,
              PRINPUTOUTPU:  INPUTOUTPU,
              PRDATA:        DATA,
              PRFILE:        FILE,
              PRWORKINGSTO:  WORKINGSTO,
              PRLINKAGE:     LINKAGE, 
              PRCOMMUNICAT:  COMMUNICAT,
              PRREPORT:      REPORT,
              PRPROCEDURE:   PROCEDURE, 
              PRCONFIGURAT:  CONFIGURAT,
              PRALPHABNAME:  ALPHABET,
              PRRD:          RD,
              PRENTER:       ENTER, 
              PRFD:          FD,
              PRCD:          CD,
              PRSD:          SD,
              PRVALUE:       VALUE, 
              PRINDEXED:     INDEXED, 
              PRLINAGE:      LINAGE,
              PRREDEFINES:   REDEFINES, 
              PRCOMMONSTOR:  COMMONSTOR,
              PRSECONDARYS:  SECONDARYS,
              PRDECLARATIV:  DECLARATIV,
              PREND:         END, 
              PRALTER:       ALTER, 
              PRSORT:        SORT,
              PRMERGE:       MERGE, 
              PRSELECT:      SELECT,
              PRSUBSCHEMA:   SUBSCHEMA, 
              PRPERFORM:     PERFORM, 
              PRCORR:        CORR,
              PRRETURN:      RETURN,
              PRRELEASE:     RELEASE, 
              PRPICTURE:     PICTURE; 
  $BEGIN
    IF INDEBUG THEN DISPLAY(2,"SPECIALPARSE CALLED ",0,20); 
  $END
  
  # STACK UP CTEXT FOR CURRENT PARSING KEY WORD # 
  CTSP = -1;
  MUSTSAVECTXT = TRUE;
  EDCTEXTBUILD; 
  CTOUTPUT; 
  NOLOOKDONE = TRUE ; 
# # 
  #IDENTIFY THE FIRST WORD OF THE SPECIALLY PARSED PHRASE 
   AND BRANCH TO THE APPROPRIATE CODE TO COMPLETE PARSING.
  # 
          GOTO  PRODUCTIONSW[RWSWITCH]; 
PRTRACEON:  
# ******** #
              $BEGIN
              # ACTIVATE TRACE FROM STORED PARAMETER VALUES # 
              INDEBUG = INDEBUG$; 
              GOTO PREXIT;
              $END
PRTRACEOFF: 
# ******** #
              $BEGIN
              # DE-ACTIVATE THE TRACE FACILITY #
              INDEBUG = FALSE;
              # KEEP THE GOTO OUTSIDE OF DEBUG BRACKETS # 
              $END
              GOTO PREXIT;
PRIDENTIFICA: 
# ******** #
#    <IDENTIFICATION-DIV>:= RWIDENTIFICA RWDIVISION .  #
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2,"IDENT DIV. SEEN",0,15);
              $END
              # IS THIS ELEMENT IN THE A-AREA # 
              IF CLACOLUMN GR BMARGIN THEN
              SSDIAGS(D025);
              # SET FLAG FOR NO EXTRA TOKENS #
              COMMENTENTRY = FALSE; 
              # CHECK FOR DUPLICATE OR OUT OF ORDER HEADER #
              IDDIVTEST(0); 
              # CHECK FOR THE RESERVED WORD DIVISION #
              LOOKFOR(RWDIVISION,REWDTYPE,PRIDENT0);
              GOTO PRIDENT1;
PRIDENT0: 
              # DIVISION IS MISSING - GEN DIAGNOSTIC AND QUIT # 
               SSDIAGS(D054); 
              GOTO PREXIT;
PRIDENT1: 
              # DIVISION FOUND - MAKE SURE ITS IN THE B-AREA #
              IF CLACOLUMN LQ BMARGIN THEN
                SSDIAGS(D026);
              # TEST FOR REQUIRED PERIOD PUNCTATION # 
              IDDIVPERIOD;
              GOTO PREXIT;
PRPROGRAMID:  
# ******** #
              # IS THIS ELEMENT IN THE A-AREA # 
              IF CLACOLUMN GR BMARGIN THEN
                SSDIAGS(D025);
              # SET FLAG TO DISALLOW EXTRA TOKENS # 
              COMMENTENTRY = FALSE; 
              # TEST FOR DUPLICATE OR OUT OF ORDER PARAGRAPH #
              IDDIVTEST(1); 
              # TEST FOR THE REQUIRED PERIOD PUNCTUATION #
              IDDIVPERIOD;
              # SEARCH FOR THE PROGRAM NAME - TRY AN ASSIGNED WORD #
              LOOKFOR(0,AWTYPE,PRPROGID0);
              GOTO PRPROGID3; 
PRPROGID0:  
              # NO PROGRAM NAME - GEN DIAGNOSTIC AND QUIT # 
              SSDIAGS(D031);
              GOTO PREXIT;
PRPROGID3:  
              # PROGRAM NAME FOUND - MAKE SURE IN B-AREA #
              IF CLACOLUMN LQ BMARGIN THEN
              SSDIAGS(D031);
              # VALID PROGRAM NAME IS PRESENT # 
              # CHECK MAXIMUM SEVEN CHARACTER LENGTH FOR NAME # 
          IF  SAREALENGTH GR 7 AND NOT CCTFDL[0]   THEN 
                BEGIN 
                  SSDIAGS(D057);
                END 
              PROGRAMID = C<0,7>SAREA[0]; 
              # PUT NAME IN LISTING HEADER,CCT AND REDEFINE TITLE # 
              LISTID = PROGRAMID; 
          CBLIST(4,LISTHED,110);
          $BEGIN
          GOTO SKPGEJECT1;
          $END
          IF CCTSOURCLIST    # PREVENT HEADER WHEN NO SOURCE LISTING   #
          THEN
              BEGIN 
              CBLIST(3," ",1);   # PAGE EJECT AND PRINT HEADINGS       #
              END 
          $BEGIN
SKPGEJECT1: 
          $END
              CCTPROGRAMID[0] = PROGRAMID;
          CCTPROGRI0 =    SAREA[0]; 
          CCTPROGRI1 = SAREA[1];
          CCTPROGRI2 = SAREA[2];
                 #PUT NAME IN "COMPILING" MSG + DISPLAY IT# 
                 C<10,7>COM$MSG = PROGRAMID;
                  C<17,4>COM$MSG = 0;  #ZERO BYTE TO TERMINATE IT#
                 PUTDMSG(COM$MSG);
              # STORE PROGRAM NAME IN THE 1ST PLT ENTRY # 
              STOREPRGID(PROGRAMID);
              # TEST FOR REQUIRED PERIOD PUNCTUATION #
              IDDIVPERIOD;
              GOTO PREXIT;
PRAUTHOR: 
# ******** #
              I = 2;
              GOTO PRIDDIVCOMM; 
PRINSTALLATI: 
# ******** #
              I = 3;
              GOTO PRIDDIVCOMM; 
PRDATEWRITTE: 
# ******** #
              I = 4;
              GOTO PRIDDIVCOMM; 
PRDATECOMPIL: 
# ******** #
              HOLDDATECMP = TRUE; #PREVENT PRINTING OF DATE-COMPILED# 
              IF CCTFIPSLEVEL LS 3
              THEN BEGIN
                   #FIPS = 3 SUPPORTS DATE-COMPILED#
                   SSDIAGS(D404); 
                   END
              IF CLACOLUMN GR BMARGIN  THEN 
                  # (THIS ELEMENT MUST BEGIN IN THE A AREA.)           #
                 SSDIAGS(D025); 
              COMMENTENTRY = TRUE;
              IDDIVTEST(5);            # IF DUPLICATE OR OUT-OF-ORDER  #
                                       #   PARAGRAPH,  DIAGNOSE        #
#             SEARCH FOR REQUIRED PERIOD                               #
              LOOKFOR(".",PUNCTYPE,NODATECMPERD); 
              IF CLACOLUMN LQ BMARGIN 
              THEN   # PERIOD FOUND IN AMARGIN - DIAGNOSE              #
                  BEGIN 
                  SSDIAGS(D026);
                  END 
              COMMENTENTRY = FALSE; 
              NOLOOKDONE = FALSE; 
              DATECMP;                 # MODIFY PRINT LINES WITH DATE  #
#***#         GOTO PREXIT;             # GO CLEAN UP AND EXIT SPECIALP #
      NODATECMPERD: 
#             MISSING PERIOD FOLLOWING DATE-COMPILED DIAGNOSE          #
              SSDIAGS(D150);
              GOTO PREXIT;
PRSECURITY: 
# ******** #
              I = 6;
              # DROP THROUGH TO COMMON ID DIV CODE #
PRIDDIVCOMM:  
              # IS THIS ELEMENT IN THE A-AREA # 
              IF CLACOLUMN GR BMARGIN THEN
                SSDIAGS(D025);
              # SET FLAG FOR EXTRA COMMENT TOKENS # 
              COMMENTENTRY = TRUE;
              # CHECK FOR DUPLICATE OR OUT OF ORDER PARAGRAPH # 
              IDDIVTEST(I); 
              # CHECK FOR TERMINAL PERIOD ON A PARAGRAPH HEADER # 
              IDDIVPERIOD;
              NOLOOKDONE = FALSE; 
              GOTO PREXIT;
  
PRENVIRONMEN: 
# ******** #
#    <ENVIRONMENT-DIV>:= RWENVIRONMEN RWDIVISION #
              # ACCEPT ENVIRONMENT IN A-AREA OR ENVIRONMENT DIVISION #
              IF CLACOLUMN GR BMARGIN THEN
                BEGIN 
                  LOOKFOR(RWDIVISION,REWDTYPE,PREXIT);
                END 
              GOTO PREDSEM; 
PRCONFIGURAT: 
# ******** #
#    <CONFIGURATION-SEC>:= RWCONFIGURAT RWSECTION # 
              CONTROL IFEQ CB5$CDCS,"CDCS2";
              INSPECIALNAM = FALSE;      #TURN OFF SPEC-NAMES FLAG# 
              LOOKFOR(RWSECTION,REWDTYPE,PREXIT); 
              GOTO PREDSEM; 
              CONTROL FI; 
              # DROP THROUGH TO TEST FOR "SECTION" #
PRINPUTOUTPU: 
# ******** #
#    <INPUTOUTPUT-SEC>:= RWINPUTOUTPU RWSECTION # 
              INSPECIALNAM = FALSE;    # TURN OFF SPEC-NAMES FLAG # 
              LOOKFOR(RWSECTION,REWDTYPE,PREXIT); 
              CONTROL IFEQ CB5$CDCS,"CDCS2";
              IOSECTIONFLG = TRUE;   #I/O SECTION SEEN# 
              CONTROL FI; 
              # DROP THROUGH IF SECTION FOUND # 
PREDSEM:  
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2,"ENV. DIV. HEAD SEEN",0,20);
              $END
              #CHECK FOR BEGINNING OF A NEW DIVISION #
              NEWDIV = ENVIRDIV;
              GOTO PRNEWDIV;
  
PRIS:       # <MNEMONIC DEF > ::= RWIS AW # 
# ******** #
         IF INSPECIALNAM   THEN 
           BEGIN
             LOOKFOR(0,AWTYPE,PREXIT);
PRISAW:            # AN AW HAS BEEN FOUND # 
                   #SEMANTIC PROCESSING # 
              IF  SV$CLAS  THEN 
                  BEGIN 
                  CHKIMPS;   # CHECK FOR ALPHABET-NAME IS IMPLEMENTOR # 
                  IF  FND$IMP  THEN 
                      BEGIN  # GOT ONE #
                      CODEAWRT = AWRTDNREF; 
                      DOREFERENCES; 
                      FND$IMP = FALSE;
                      GOTO PREXIT;
                      END 
                  PUT$IMPNAM; 
                  END 
             LEVELNUMVALU = 55; 
             DNDEFROUTINE; #PROCESS AND BUILD CTEXT#
          END 
  
        GOTO PREXIT ; 
  
  
PRDEBUGGING:   #<DEBUG> ::= RWDEBUGGING RWMODE #
# ******** #
              LOOKFOR(RWMODE,REWDTYPE,PREXIT);
  
PRDBG:       #  RWMODE WAS FOUND ,CTEXT HAS BEEN BUILT #
              CCTDEBUGMODE[0] = TRUE ;
              GOTO PREXIT ; 
  
  
PRCURRENCY: 
# ******** #
#       <CURRENCY>   ::= RWCURRENCY RWSIGN RWIS QLIT #
                        #RRWCURRENCY RWIS QLIT        # 
                        #RWCURRENCY QLIT             #
  
        LOOKFOR(RWSIGN,REWDTYPE,PRCURIS); #OPTIONAL "SIGN" #
  
PRCURIS:  
        LOOKFOR(RWIS,REWDTYPE,PRCURQLT);  # OPTIONAL "IS " #
  
PRCURQLT: 
        LOOKFOR(0,QLITTYPE,PREXIT);   # QLIT MUST BE FOUND #
        EDCTEXTBUILD; 
        CTOUTPUT  ; 
  
       # THE CLAUSE IS VALID , NOW DO SEMANTIC WORK # 
  
  
              $BEGIN
                                IF INDEBUG THEN 
                              DISPLAY(2," CURRENCY SEEN",0,14); 
              $END
  
              # CHECK FOR LEGAL CURRENCY SIGN # 
  
              CH1 = C<0,1> SAREA[0]; # GET SIGN # 
              IF SAREALENGTH GR 1 THEN
              BEGIN 
                SSDIAGS(D015);
                GOTO NOTLEGALCUR; 
              END 
              ELSE # LENGTH OK, SEE IF CHARACTER IS OK #
                BEGIN 
                  FOR I = 0 STEP 1 UNTIL 31 DO
                    IF CH1 EQ NOTCURSIGN[I] THEN
                      BEGIN 
                        # NOT LEGAL - CURRENCY SIGN IS NOT CHANGED# 
                        SSDIAGS(D018);
                        GOTO NOTLEGALCUR; 
                      END 
  
                END 
  
              CURSIGN = CH1; # SAVE NEW CURRENCY IGN #
              CCTCURRSIGN[0] = CH1; 
            NOTLEGALCUR:  
  
  
  
  
              GOTO PREXIT;
PRQUOTE:  
# ******** #
           #<QUOTE>::= RWQUOTE RWIS RWAPOSTROPHE      # 
#                      RWQUOTE RWAPOSTROPHE      #
#                      RWQUOTE RWARE RWAPOSTROPHE     # 
  
  
            LOOKFOR(RWIS,REWDTYPE,PRQT1); # OPTIONAL "IS"#
             GOTO  PRQTAPOS;
  
PRQT1:  
             LOOKFOR(RWARE,REWDTYPE,PRQTAPOS); # OPTIONAL "ARE" # 
              # DROP THROUGH TO TEST FOR APOS # 
PRQTAPOS: 
             LOOKFOR(RWAPOSTROPHE,REWDTYPE,PREXIT); 
             # CLAUSE IS VALID .# 
  
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," QUOTE IS AP. SEEN",0,17); 
              $END
  
              # USE APOSTROPHE FOR QUOTE #
              QUOTE = O"70";
          PLT$CHAR[VIRTUAL(PLT$,PLTSTRQUOTE)] = QUOTE;
              # SET CCT FLAG AS WELL #
              CCTQUOTEAPOS[0] = TRUE; 
              GOTO PREXIT;
PRON: 
# ******** #
  
PROFF:  
# ******** #
  
#      <ON-OFF>::=RWON RWIS                     # 
#                 RWON RWSTATUS RWIS            # 
#                 RWOFF RWIS                    # 
#                 RWOFF RWSTATUS RWIS           # 
          IF  INSPECIALNAM  THEN   # IN SPECIAL-NAMES # 
              BEGIN 
              IF  SV$CLAS  THEN 
                  BEGIN 
                  PUT$IMPNAM;      # NO "IS MNEMONIC-NAME" CLAUSE#
                  END 
  
            LOOKFOR(RWSTATUS,REWDTYPE,PRON1); #OPTIONAL "STATUS" #
  
PRON1:  
            LOOKFOR(RWIS,REWDTYPE,PREXIT); #IS MUST BE FOUND #
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," ON/OFF STATUS SEEN.", 
                                        0,19);
              $END
  
              LEVELNUMVALU = 88;
              GETTOKEN; 
              IF CLATYPE EQ AWTYPE THEN # HAVE CONDITION NAME # 
                DNDEFROUTINE; 
              ELSE
                NOLOOKDONE = FALSE; 
  
  
          END 
  
              GOTO PREXIT;
  
PRSPECIALNAM: 
# ******** #
#      <SPECAILNAM>= RWSPECIALNAM              #
  
        INSPECIALNAM = TRUE ; 
  
        GOTO PREXIT ; 
  
  
PRDECIMALPOI: 
# ******** #
#    <DECIMALPOI>  = RWDECIMALPOI RWIS RWCOMMA   #
#                     RWDECIMALPOI RWCOMMA        # 
  
       LOOKFOR(RWIS,REWDTYPE,PRDECCOMM); # OPTIONAL "IS" #
  
PRDECCOMM:  
       LOOKFOR(RWCOMMA,REWDTYPE,PREXIT); #MANDATORY COMMA # 
           # PHRASE IS LEGAL #
$BEGIN
                                 IF INDEBUG THEN
                                DISPLAY(2," DECPOINT SEEN",0,14); 
              $END
  
  
              DECPOINT = ","; 
              CCTDECPOINT[0] = ","; 
              CCTDECPTCOMM[0] = TRUE; 
  
              GOTO PREXIT;
  
  
  
PRFILECONTRO: 
   CONTROL IFEQ CB5$CDCS,"CDCS2"; 
   FILECTLFLAG = TRUE;   #FILE-CONTROL SEEN#
   GOTO PROBJECTCOMP; 
   CONTROL FI;
PRIOCONTROL:  
   CONTROL IFEQ CB5$CDCS,"CDCS2"; 
   CDCSSELECTS;   #I/O SECTION SEEN, SO DO SELECTS# 
   CONTROL FI;
PRSOURCECOMP: 
PROBJECTCOMP: 
# ******** #
         $BEGIN 
                                IF INDEBUG THEN 
                                DISPLAY(2,"ENV. DIV. PARA SEEN",0,20);
         $END 
         INSPECIALNAM = FALSE ; 
         GOTO PREXIT ;
  
  
PRREPORT: 
# ******** #
#    <REPORT-SEC>:= RWREPORT RWSECTION #
              I= 2; 
              GOTO PRDDSEC; 
PRDATA: 
# ******** #
#    <DATA-DIV>:= RWDATA RWDIVISION # 
              INSPECIALNAM = FALSE;    # TURN OFF SPECIAL-NAMES FLAG #
              # ACCEPT DATA IN A-AREA OR DATA DIVISION #
              IF CLACOLUMN GR BMARGIN THEN
                BEGIN 
                  LOOKFOR(RWDIVISION,REWDTYPE,PREXIT);
                END 
               ELSE  LOOKFOR(RWDIVISION,REWDTYPE,PRDIVOK);
                # DIV IS OPTIONAL IF DATA IS BEFORE COL 11 #
         PRDIVOK: 
              I = 1;
              GOTO PRDDSEM1;
  
  
PRCOMMUNICAT: 
# ******** #
#    <COMMUNICATION-SEC>:= RWCOMMUNICAT RWSECTION # 
  
  
PRFILE: 
# ******** #
#    <FILE-SEC>:= RWFILE RWSECTION #
              I = 1;
              GOTO PRDDSEC; 
  
PRWORKINGSTO: 
# ******** #
#    <WORKINGSTORAGE-SEC>::= RWWORKINGSTO RWSEC # 
  
PRLINKAGE:  
# ******** #
#    <LINKAGE-SEC>:= RWLINKAGE RWSECTION #
  
PRCOMMONSTOR: 
# ******** #
#    <COMMONSTORAGE-SEC>:= RWCOMMONSTOR RWSECTION # 
  
PRSECONDARYS: 
# ******** #
#    <SECONDARYSTORAGE-SEC>:= RWSECONDARYS RWSECTION #
              I = 0;
              # FALL THROUGH #
  
PRDDSEC:  
              INSPECIALNAM = FALSE;    # TURN OFF SPECIAL-NAMES FLAG #
              LOOKFOR(RWSECTION,REWDTYPE,PREXIT); 
              # DROP THROUGH IF SECTION FOUND # 
PRDDSEM:  
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," DATA DIV. HEADER SEEN", 
                                        0,22);
              $END
              # MAKE DUMMY DNDEF ATOM AND DNT ENTRY FOR DP AND DA # 
              BUILDCTEXT(CTDNDEF,DNTNEXT,0,0);
              CTOUTPUT; 
              DNTEXTRA; 
PRDDSEM1: 
              # SET UP SECTION INFO FOR DNTBUILD #
              DNTLEVEL2[0] = (I+1)/2; 
              # CHECK FOR BEGINNING OF A NEW DIVISION # 
              IF I EQ 2 THEN
                NEWDIV = REPORTSEC; 
              ELSE
                NEWDIV = DATADIV; 
              GOTO PRNEWDIV;
  
  
  
PRPROCEDURE:  
# ******** #
#    <PROCEDURE-DIV>:= RWPROCEDURE RWDIVISION # 
              INSPECIALNAM = FALSE;    # TURN OFF SPECIAL-NAMES FLAG #
              # ACCEPT PROCEDURE IN A-AREA OR PROCEDURE DIVISION #
              IF CLACOLUMN GR BMARGIN THEN
                BEGIN 
                  LOOKFOR(RWDIVISION,REWDTYPE,PREXIT);
                END 
              # DROP THROUGH IF DIVISION FOUND #
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," PROC. DIV. HEADER SEEN",
                                        0,23);
              $END
              NEWDIV = PROCDIV; 
              # DROP THROUGH TO TEST FOR NEW DIVISION START # 
  
  
PRNEWDIV: 
              # HAVE WE ENTERED A NEW PROGRAM DIVISION #
              IF CURRENTDIV NQ NEWDIV THEN
                BEGIN 
                # TERMINATE THE PRECEDING DIVISION #
                SWITCH DIVEND ,IDEND,EDEND,DDEND,RSEND,PDEND; 
                GOTO DIVEND[CURRENTDIV];
                IDEND:  
                  GOTO STARTDIV;
                EDEND:  
                 CONTROL IFEQ CB5$CDCS, "CDCS2";
                  CDCSSELECTS;
                  CONTROL FI; 
                  CCTEDCTXLEN =  CTEXTNEXT - 1; 
                  CONTROL IFNQ CB5$CDCS,"NO"; 
                  IF USEDDL THEN
                      BEGIN 
                      MUSTSAVECTXT = FALSE; 
                      DDLSS;
                      SSLINE = CLALINE; 
                      END 
                  CONTROL FI; 
                  GOTO STARTDIV;
                DDEND:  
                  CCTDDCTXLEN =  CTEXTNEXT - 1; 
                  GOTO STARTDIV;
                RSEND:  
                  CCTRSCTXLEN =  CTEXTNEXT - 1; 
                  CCTPDCTXADDR = CTEXTNEXT; 
                  GOTO STARTDIV;
                PDEND:  
                STARTDIV: 
                # INITIATE THE NEW DIVISION # 
                SWITCH DIVBEG ,IDBEG,EDBEG,DDBEG,RSBEG,PDBEG; 
                GOTO DIVBEG[NEWDIV];
                IDBEG:  
                  GOTO RESETDIV;
                EDBEG:  
                  CCTEDCTXADDR = CTEXTNEXT; 
             CCTEDLINENUM = SSLINE; 
                  GOTO RESETDIV;
                DDBEG:  
                  CCTDDCTXADDR = CTEXTNEXT; 
             CCTDDLINENUM = SSLINE; 
                  INFD = FALSE; 
                  GOTO RESETDIV;
                RSBEG:  
                  CCTRSCTXADDR = CTEXTNEXT; 
             CCTRSLINENUM = SSLINE; 
                  INRD = FALSE; 
                  # CHANGE SOME OF THE DATA DIVISION PARSING KEYS # 
                  DDPARSEKEY[RWRD] = SPRW"RD";
                  DDPARSEKEY[RWFD] = 0; 
                  DDPARSEKEY[RWCD] = 0; 
                  DDPARSEKEY[RWSD] = 0; 
                  DDPARSEKEY[RWVALUE] = 0;
                  DDPARSEKEY[RWINDEXED] = 0;
                  DDPARSEKEY[RWREPORT] = 0; 
                  DDPARSEKEY[RWLINAGE] = 0; 
                  DDPARSEKEY[RWFILE] = 0; 
                  DDPARSEKEY[RWCOMMUNICAT] = 0; 
                  DDPARSEKEY[RWWORKINGSTO] = 0; 
                  DDPARSEKEY[RWLINKAGE] = 0;
                  DDPARSEKEY[RWCOMMONSTOR] = 0; 
                  DDPARSEKEY[RWSECONDARYS] = 0; 
                  CCTREPORTSEC[0] = TRUE; 
                  GOTO RESETDIV;
                PDBEG:  
                  CCTPDCTXADDR = CTEXTNEXT; 
             CCTPDLINENUM = SSLINE; 
                  CCTPDLITADDR = PLTNEXT; 
                  INFD = FALSE; 
                  INRD = FALSE; 
                 CONTROL IFNQ CB5$CDCS,"NO";
                  RDFLAG = FALSE; 
                 CONTROL FI;
                  # FINISH THE SCOPE PROCESSING OF THE DNT #
              DNTSCP; 
                RESETDIV: 
                # UPDATE CURRENT DIVISION INDICATOR # 
                CURRENTDIV = NEWDIV;
                # MAKE 1ST STACKED CTEXT ATOM A KEY ELEMENT # 
                # WATCH FOR A LINE NUMBER ATOM HOWEVER #
          IF  CTTYPESTACK[0] EQ CTDELIMITER 
          THEN
              CTKEYSTACK[1] = 1;
          ELSE
              CTKEYSTACK[0] = 1;
                END 
              GOTO PREXIT;
  
  
  
PRALPHABNAME: 
# ******** #
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," ALPHABETNAME SEEN.",0,19);
              $END
  
              LEVELNUMVALU = 55; # SAME AS MNEMONIC NAME #
          LOOKFOR(0,AWTYPE,PREXIT);   # GET ALPHABET-NAME              #
          DNDEFROUTINE; 
          ABET$SEEN = TRUE;  # ALPHABET CLAUSE SEEN                    #
          LOOKFOR(RWIS,REWDTYPE,PREXIT);   # SKIP PAST RWIS            #
  
          GOTO PREXIT;
  
  
PRRD: 
PRCD: 
PRFD: 
PRSD: 
# ******** #
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," FD SD CD OR RD SEEN.",
                                        0,21);
              $END
  
              # DELETE CTEXT ATOM FOR THE RESERVED WORD FROM THE
                STACK.  A LEVEL NUMBER ATOM IS GENERATED INST.# 
              CTSP = CTSP - 1;
  
              # ONLY RD[S RECOGNIZED IN REP. SECT. #
              IF CLAVALUE EQ RWRD THEN # HAVE RD #
                BEGIN 
                  LEVELNUMVALU = 54;
                  INRD = TRUE;
                  # SAVE SOME INFO IN CCT # 
                  CCTREPORTCUT = CCTREPORTCUT + 1;# RD COUNT #
                END 
              ELSE
                INRD = FALSE; 
              IF CLAVALUE EQ RWCD THEN # HAVE CD #
                BEGIN 
                  LEVELNUMVALU = 53; DEFINITION = TRUE; 
                END 
              IF CLAVALUE EQ RWSD THEN LEVELNUMVALU = 52; # SD #
              IF CLAVALUE EQ RWFD THEN  # FD #
                BEGIN 
                  LEVELNUMVALU = 51;
                  INFD = TRUE;
                END 
              ELSE
                INFD = FALSE; 
  
              DODATADEF ; # RETURNS LOOKING AT NEXT TOKEN # 
              IF LEVELNUMVALU EQ 53 THEN # HAVE CD #
              LEVELNUMVALU = 1; # SO ITEMS IN CD ARE
                                SUBORDINATE TO CD NAME# 
              NOLOOKDONE = FALSE; 
  
              GOTO PREXIT;
  
PRVALUE:  
# ******** #
   #   <VALUE-OF>::= RWVALUE RWOF # 
          LOOKFOR(RWOF,REWDTYPE,PREXIT);
     # CLAUSE WAS "VALUE OF "  #
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," VALUE OF SEEN.",0,15);
              $END
              # THIS IS PARSED SO THAT SOMETHING LIKE "01 A" IS 
                NOT TAKEN AS A DATA NAME DEFINITION POINT, WITH 
                THE PRECEEDING PERIOD MISSING. #
  
              NOTVALUEOF = FALSE; 
  
              GOTO PREXIT;
  
PRINDEXED:  
# ******** #
#      <INDEXED-BY>::= RWINDEXED RWBY   # 
#                      RWINDEXED        # 
  
        LOOKFOR(RWBY,REWDTYPE,PRINDBY); 
            # "BY" IS OPTIONAL #
          GETTOKEN ;
PRINDBY:  
#           MOVE PAST THE "BY"  # 
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," INDEXED BY SEEN.",
                                        0,17);
              $END
              ASLONGAS CLATYPE EQ AWTYPE DO # DO LIST OF DNDEF[S# 
                BEGIN 
                  LEVELNUMVALU = 56;
                  DNDEFROUTINE; 
                  # ALLOW FOR COMMA[S AND SEMICOLONS HERE # 
  
  
                  GETTOKEN; 
                  SKIPCOMMAS; 
                END 
  
              NOLOOKDONE = FALSE; 
  
  
  
              GOTO PREXIT;
  
  
PRLINAGE: 
# ******** #
#   <LINAGE>::= RWLINAGE   #
              $BEGIN
                                IF INDEBUG THEN 
                               OUTPUT(2," LINAGE SE","EN.");
              $END
              IF INFD THEN
                BEGIN 
                  IF FDLINAGE GR 0 THEN FDLINAMBIG = TRUE;
                  FDLINAGE = LASTFD;
                END 
  
              GOTO PREXIT;
  
  
PRREDEFINES:  
# ******** #
#  <REDEFINE>::= RWREDEFINE QAWREF   #
                  # THE REF. SHOULD BE UNQUALIFIED. IF IT IS , THEN 
                    RESOLVE THE REFERENCE IMMEDIATELY- OTHERWISE
                    LEAVE IT UNTIL THE END AS USUAL. D-PARSER WILL
                    DIAGNOSE ALL OTHER ERRORS # 
  
              $BEGIN
                                IF INDEBUG THEN 
                               OUTPUT(2,"REDEFINES","SEEN."); 
               $END 
  
             LOOKFOR(0,AWTYPE,PREXIT);
             CODEAWRT = AWRTDNREF;
             REDEFLINE = CLALINE; 
             REDEFCOL = CLACOLUMN;
             DOREFERENCES;
             NOLOOKDONE = FALSE;
              IF QUALAWRT EQ 1 THEN # THERE WERE QUALIFIERS#
                BEGIN 
                 INTERCEPTOR(REDEFCOL,REDEFLINE,D049,0);
                END 
                 ELSE 
                 BEGIN
                  # NO QUALIFIERS - IT IS IMPLICITLY THE LAST 
                    DEFINED ITEM WITH THAT NAME. CHANGE THE AWRT
                    ENTRY TO REFLECT THE FACT THAT THE RESOLUTION 
                    HAS BEEN DONE, IF THE REFERENCE IS OK#
                  REDEFRESOLVE; 
                END 
  
  
              GOTO PREXIT;
  
PRDECLARATIV: 
# ******** #
#   <DECLARATIVE>::= RWDECLARATIVE   #
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," DCL SEEN.",0,10); 
              $END
  
              DCLSWITCH = TRUE; 
              # CHECK FOR NEW DIVISION START #
              NEWDIV = PROCDIV; 
              GOTO PRNEWDIV;
  
PREND:  
# ******** #
#  <END-DECL>::= RWEND RWDECLARATIV  #
  
              LOOKFOR(RWDECLARATIV,REWDTYPE,PREXIT);
              # DECLARATIVE MUST BE FOUND # 
              $BEGIN
                                IF INDEBUG THEN 
                                DISPLAY(2," END DCL SEEN.",0,14); 
              $END
              DCLSWITCH = FALSE;
              USEFORDEBUG = FALSE;
              ENDDCLFLAG = 1; 
              CCTDCLUPPBND = PNTNEXT - 1; 
          IF  CTTYPESTACK[CTSP-1] EQ CTRESERVEDWD AND 
              CTVALUESTACK[CTSP-1] EQ RWEND 
          THEN
              CTTYPESTACK[CTSP-1] = CTENDDCL; 
              CTKEYSTACK[CTSP-1] = 1; 
              GOTO PREXIT;
  
PRALTER:  
# ******** #
# <ALTER-ST>::= RWALTER <ALTER-LI>  # 
# <ALTER-LI>::= <ALTER-PA>          # 
#               <ALTER-LI> <ALTER-PA> # 
# <ALTER-PA>::= <LABELREF> RWTO <LABELREF> #
#               <LABELREF> RWTO RWPROCEED RWTO <LABELREF> # 
          IF CCTDEBUGMODE[0]
          THEN BEGIN
               ASLONGAS INPROCDIV DO  #PARSE THE ALTER STATEMENT #
                 BEGIN
                 LOOKFOR(0,PNREFTYPE,PREXIT); 
                 SAVEDCTCOL = CLACOLUMN;
                 SAVEDCTLINE = CLALINE; 
                 CODEAWRT = AWRTPNREF;
                 DOREFERENCES;  #HANDLE QUALIFIERS - BUILD CTEXT# 
                 NOLOOKDONE = FALSE;
                 LOOKFOR(RWTO,REWDTYPE,PREXIT); 
                 LOOKFOR(RWPROCEED,REWDTYPE,PROCREF); 
                 LOOKFOR(RWTO,REWDTYPE,PROCREF);
           PROCREF: 
                 LOOKFOR(0,PNREFTYPE,PREXIT); 
                 SAVEDCTCOL = CLACOLUMN;
                 SAVEDCTLINE = CLALINE; 
                 CODEAWRT = AWRTPNREF;
                 DOREFERENCES;
                 NOLOOKDONE = FALSE;
                 ALTERLIT(QUALIFFLAGS); 
                 BUILDCTEXT(CTLITERAL,PLTNEXT-1,CLACOLUMN,0); 
                 CTOUTPUT;
                 END
               END
          GOTO PREXIT;
  
  
  
  
PRSORT: 
# ******** #
  
#  #
#   <SORT-ST>    ::= <SORTHEAD> <KEYLIST1> <INPUT-US> <OUTPUT-G>   #
#   <SORTHEAD>   ::= RWSORT <QAWREF> .                             #
#   <KEYLIST>    ::= <KEYLIST1> <COLL-CL>                          #
#                   <KEYLIST1>                                    # 
#   <KEYLIST1>   ::= <KEYLIST1> <KEY>                              #
#                   <KEY>                                         # 
#   <KEY>        ::= RWON <KEYDIRECT> RWKEY <QAW-LIST>             #
#                   RWON <KEYDIRECT> <QAW-LIST>                   # 
#                   <KEYDIRECT> RWKEY <QAW-LIST>                  # 
#                    <KEYDIRECT> <QAW-LIST>                        #
#   <KEYDIRECT>  ::= <RWASCENDING>  <RWDESCENDING>                # 
#   <COLL-CL>    ::= RWCOLLATING RWSEQUENCE RWIS <QAWREF>          #
#                   RWCOLLATING RWSEQUENCE <QAWREF>               # 
#                   RWSEQUENCE RWIS <QAWREF>                      # 
#                   RWSEQUENCE <QAWREF>                           # 
#  <QAW-LIST>  := <QA-LIST> <QAWREF>  <QAWREF>               #
  
          SORTSYN = TRUE ;
            # SET FLAG TO INDICATE SORT OR MERGE #
  
SORTANDMERGE:     # COMMON CODE FOR SORT/MERGE #
           CODEAWRT = AWRTDNREF ; 
            AWISPNREF=FALSE;
            ILITISPNREF=FALSE;
            LOOKFOR(0,AWTYPE,PREXIT); 
            # FILE-NAME MUST BE FOUND  #
            DOREFERENCES; NOLOOKDONE=FALSE; 
          SPDNAT = CTVALUESTACK[CTSP];
              # SAVE INFO. ON FILE-NAME # 
  
     SKEYLIST:  
            LOOKFOR(RWON,REWDTYPE,SKEYDIR); 
            #  OPTIONAL "ON"  # 
     SKEYDIR: 
            LOOKFOR(RWASCENDING,REWDTYPE,STRYDESC); 
            GOTO SKEDIRFD;
  
    STRYDESC: 
          LOOKFOR(RWDESCENDING,REWDTYPE,SENDKEYS);
          #  EXIT THE LOOP  IF NO DIRECTION FOUND # 
     SKEDIRFD:  
          # DIRECTION FOUND # 
          LOOKFOR(RWKEY,REWDTYPE,SKEYS);
          #OPTIONAL KEY # 
     SKEYS: 
          LOOKFOR(0,AWTYPE,SKEYLIST); 
          DOREFERENCES; NOLOOKDONE =FALSE;
          GOTO SKEYS ;
          # REPEAT UNTIL THE KEY-LIST IS #
          # EXHAUSTED THEN TRY FOR ANOTHER# 
          # KEY PHRASE #
  
SENDKEYS: 
          # END OF KEY SPECS. # 
          #WITH DUPLICATES IN ORDER PHRASE #
          LOOKFOR(RWWITH,REWDTYPE,SDUPLCATS); 
          # WITH IS OPTIONAL #
 SDUPLCATS: 
          LOOKFOR(RWDUPLICATES,REWDTYPE,SCOLLATING);
          #DUPLICATES IS OPTIONAL # 
          LOOKFOR(RWIN,REWDTYPE,SDUPLORDER);
          # IN IS OPTIONAL #
 SDUPLORDER:  
          LOOKFOR(RWORDER,REWDTYPE,SCOLLATING); 
          # ORDER IS OPTIONAL # 
        # END OF DUPLICATES PHRASE #
SCOLLATING: 
       # COLLATING PHRASE # 
         LOOKFOR(RWCOLLATING,REWDTYPE,SSEQU); 
         # COLLATING IS OPTIONAL #
SSEQU:  
         LOOKFOR(RWSEQUENCE,REWDTYPE,SIN);
         #SEQUENCE IS OPTIONAL #
         LOOKFOR(RWIS,REWDTYPE,SALPHNAM); 
         # "IS "  IS OPTIONAL # 
SALPHNAM: 
          LOOKFOR(0,AWTYPE,PREXIT); 
         # ALPHABET-NAME IS MANDATORY. #
          DOREFERENCES; NOLOOKDONE=FALSE; 
         # END OF COLLATING PHRASE #
  
#           MISS OUT CHECK FOR "INPUT" IN MERGE # 
            IF NOT SORTSYN THEN GOTO STRYUSE ;
  
     SIN: 
         # SPECIFICATION OF INPUT OR USING #
         LOOKFOR(RWINPUT,REWDTYPE,STRYUSE); 
        SPLINE=CLALINE; SPCOL=CLACOLUMN;
       SPTYPE = 1 ; 
        CODEAWRT=AWRTPNREF ;
         AWISPNREF=TRUE; ILITISPNREF=TRUE;
          #  INPUT FOUND,PROCEDURE SHOULD FOLLOW# 
         LOOKFOR(RWPROCEDURE,REWDTYPE,PREXIT);
         # PROCEDURE IS MANDATORY # 
          LOOKFOR(RWIS,REWDTYPE,SSECN); 
         # OPTIONAL "IS" #
SSECN:  
         # CHECK FOR SECTION-NAME # 
        CODEAWRT=AWRTPNREF ;
         AWISPNREF=TRUE; ILITISPNREF=TRUE;
          LOOKFOR(0,PNREFTYPE,PREXIT);
          # SECTION-NAME IS MANDATORY # 
          DOREFERENCES;  NOLOOKDONE=FALSE ; 
  
          # CHECK FOR "THROUGH" PHRASE #
          SPBT1ST = CTVALUESTACK[CTSP]; 
          SPBT2ND = SPBT1ST;
            # SAVE DEFN. OF 1ST PROC. NAME #
          LOOKFOR(RWTHROUGH,REWDTYPE,SORTSPBT); 
          #IF NOT ,OUTPUT FOLLOWS#
          LOOKFOR(0,PNREFTYPE,PREXIT);
          # THROUGH MUST BE FOLLOWED BY SEC-NAM # 
          DOREFERENCES;  NOLOOKDONE=FALSE ; 
          SPBT2ND = CTVALUESTACK[CTSP]; 
       #BUILD THE SPBT ENTRY WITH THE FIRST AND SECOND #
          # PROC.NAMES USED .IF NO "THROUGH"CLAUSE THEY # 
          # ARE THE SAME.      #
     SORTSPBT:     # BUILD THE SPBT ENTRY # 
          SPBTBUILD(SPBT1ST,SPBT2ND); 
        GOTO  SOPPH ;   # CHECK O/P PHRASE #
  
STRYUSE:        # CHECK FOR USING PHRASE #
        LOOKFOR(RWUSING,REWDTYPE,PREXIT); 
        #   USING  ELSE PROCEDURE ELSE ERROR #
  
INFILE:     # READ IN THE INPUT FILE NAME(S) #
        LOOKFOR(0,AWTYPE,SOPPH);
        # READ THE FILE LIST UNTIL O/P PHRASE # 
        DOREFERENCES; NOLOOKDONE=FALSE; 
        GOTO   INFILE ;   # REPEAT FOR FILE # 
  
  
SOPPH:    # SORT- OUTPUT-PHRASE # 
  
        # GIVING OR OUTPUT #
        LOOKFOR(RWOUTPUT,REWDTYPE,SGIV);
      SPLINE =CLALINE; SPCOL=CLACOLUMN; 
     SPTYPE= 2 ;
        LOOKFOR(RWPROCEDURE,REWDTYPE,PREXIT); 
       # PROC BECOMES MANDATORY # 
       CODEAWRT = AWRTPNREF ; 
       AWISPNREF=TRUE; ILITISPNREF=TRUE;
       LOOKFOR(RWIS,REWDTYPE,SNOIS);
        # "IS"  IS OPTIONAL # 
SNOIS:  
       LOOKFOR(0,PNREFTYPE,PREXIT); 
       # SECTION NAME # 
       DOREFERENCES; NOLOOKDONE =FALSE; 
          SPBT1ST = CTVALUESTACK[CTSP]; 
          SPBT2ND = SPBT1ST;
       LOOKFOR(RWTHROUGH,REWDTYPE,SPBTOP);
       #OPTIONAL THROUGH PHRASE # 
       LOOKFOR(0,PNREFTYPE,SPBTOP); 
       DOREFERENCES; NOLOOKDONE =FALSE; 
          SPBT2ND = CTVALUESTACK[CTSP]; 
  SPBTOP: 
          SPBTBUILD(SPBT1ST,SPBT2ND); 
  
       GOTO PREXIT ;
      # END OF OUTPUT PHRASE #
  
SGIV:   # TRY GIVING PHRASE # 
       LOOKFOR(RWGIVING,REWDTYPE,PREXIT); 
       CODEAWRT = AWRTDNREF;
        AWISPNREF=FALSE; ILITISPNREF=FALSE ;
       LOOKFOR(0,AWTYPE,PREXIT) ; 
       # FILE NAME #
       DOREFERENCES; NOLOOKDONE = FALSE ; 
      # END OF GIVING PHRASE #
       GOTO PREXIT ;
  
#         END OF SORT SYNTAX #
  
  
PRMERGE:  
# ******** #
              SORTSYN = FALSE; # NOT WHOLE SORT SYNTAX #
              GOTO SORTANDMERGE;
  
  
  
  
PRPERFORM:  
# ******** #
#         # 
        $BEGIN
             IF INDEBUG THEN
             DISPLAY(2,"PERFORM SEEN ",0,13); 
        $END
          SVHX = 0; 
          SVLX = 1; 
          ALLOWLRGILIT = TRUE;
          GETTOKEN; 
          ALLOWLRGILIT = FALSE; 
          NOLOOKDONE = FALSE; 
          IF CLATYPE EQ ILITTYPE
          THEN
              BEGIN 
              SAVETOKEN;
              GETTOKEN; 
              SAVETOKEN;
              GETSAVEDTKN;
              IF SV$TYPE[SVLX] EQ REWDTYPE AND SV$VALUE[SVLX] EQ RWTIMES
              THEN   # PERFORM ILIT TIMES.......                       #
                  BEGIN 
                  PDCTEXTBUILD; 
                  CTOUTPUT; 
                  GETSAVEDTKN;
                  GOTO PRPFXT;
                  END 
              END 
          ELSE   # NOT AN ILIT                                         #
              BEGIN 
              IF CLATYPE EQ AWTYPE
              THEN
                  BEGIN 
                  SAVETOKEN;
                  GETTOKEN; 
                  SAVETOKEN;
                  IF CLATYPE EQ REWDTYPE AND CLAVALUE EQ RWOF 
                  THEN   # PERFORM USER-NAME OF                        #
                      BEGIN 
                      ALLOWLRGILIT = TRUE;
                      GETTOKEN; 
                      ALLOWLRGILIT = FALSE; 
                      IF CLATYPE EQ ILITTYPE
                      THEN  # PERFORM USER-NAME OF ILIT(PNREF)         #
                          BEGIN 
                          CLATYPE = PNREFTYPE;
                          END 
                      IF CLATYPE EQ AWTYPE
                      THEN  # PERFORM USER-NAME OF USER-NAME           #
                          BEGIN 
                          SAVETOKEN;
                          GETTOKEN; 
                          SAVETOKEN;
                          IF ( CLATYPE EQ REWDTYPE AND (CLAVALUE EQ 
                              RWOF OR CLAVALUE EQ RWTIMES)) OR
                             (CLATYPE EQ LPTYPE)
                          THEN # PERFORM DATA-NAME OF DATA-NAME...TIMES#
                              BEGIN 
                              GETSAVEDTKN;
                              CODEAWRT = AWRTDNREF; 
                              SAVEDTOKENS = TRUE; 
                              DOREFERENCES; 
                              GOTO PRPFXT;
                              END 
                          SV$TYPE[SVHX-1] = PNREFTYPE;
                          END 
                      ELSE
                          BEGIN 
                          SAVETOKEN;
                          END 
                      END 
                  ELSE   # PERFORM USER-NAME.............              #
                      BEGIN 
                      IF (CLATYPE EQ REWDTYPE AND CLAVALUE EQ RWTIMES)
                         OR (CLATYPE EQ LPTYPE) 
                      THEN  # PERFORM USER-NAME.....TIMES              #
                          BEGIN 
                          GETSAVEDTKN;
                          SAVEDTOKENS = TRUE; 
                          CODEAWRT = AWRTDNREF; 
                          DOREFERENCES; 
                          GOTO PRPFXT;
                          END 
                      END 
                  GETSAVEDTKN;
                  END 
              ELSE
                  BEGIN 
                  GOTO PRPFXT;
                  END 
              END 
          CLATYPE = PNREFTYPE;
          CODEAWRT = AWRTPNREF; 
          SAVEDTOKENS = TRUE; 
          AWISPNREF = TRUE; 
          ILITISPNREF = TRUE; 
          DOREFERENCES; 
          LOOKFOR(RWTHROUGH,REWDTYPE,PRSINGLE); 
          LOOKFOR(0,PNREFTYPE,PRPFXT);
          CODEAWRT = AWRTPNREF; 
          DOREFERENCES; 
          NOLOOKDONE = FALSE; 
  
PRSINGLE: 
#         JUMP HERE IF NO " THROUGH B" PHRASE # 
#         LOOK FOR REPEAT COUNT # 
          ILITISPNREF=FALSE ; 
        IF CLATYPE EQ PNREFTYPE THEN # MAYBE AN ILIT# 
          BEGIN   # CHECK STRING FOR ILIT#
            ITEM TEMP , PTR, WDPTR ,CHPTR ; 
  
            FOR PTR=0 STEP 1 UNTIL SAREALENGTH-1 DO 
            BEGIN 
              WDPTR =PTR/10;
              CHPTR=PTR- (WDPTR*10);
              TEMP= C<CHPTR,1>SAREA[WDPTR]; 
              IF TEMP LS "0" OR TEMP GR "9" THEN
                BEGIN  # NOT AN ILIT #
                  CLATYPE= AWTYPE;
                  GOTO PRPFXT;
                END 
             END
  
#            DROP THROUGH TO HERE FOR AN ILIT # 
  
             CLATYPE = ILITTYPE ; 
             IF SAREALENGTH GR 18 THEN  #ILIT TOO LONG #
               BEGIN
                 SSDIAGS(D004); 
               END
        END 
#         REPEAT COUNT FOUND #
  
PRPFXT: 
          ILITISPNREF=FALSE;
          AWISPNREF = FALSE ; 
          GOTO PREXIT;
# # 
  
  
        PROC SUBSCRIPTION ; 
        BEGIN 
           # THIS PROCEDURE WILL EXAMINE THE INPUT ATOMS #
           # LOOKING FOR A SUBSCRIPT LIST . # 
           # IF ( IS FOUND A SUBSCRIPT LIST HAS BEGUN,  # 
           # CONTINUE UNTIL ) OR AN ERROR IN THE LIST IS FOUND #
           # IF AN ERROR IS FOUND , GO TO PREXIT. # 
  
           LOOKFOR(0,LPTYPE,ENDSUBSC);
           # SUBSCRIPT LIST FOUND . # 
       NEXTSUBSC: 
            LOOKFOR(0,AWTYPE,SUBINT); 
           #    IDENTIFIER FOUND #
           DOREFERENCES; NOLOOKDONE = FALSE ; 
           LOOKFOR(0,OPTYPE,NEXTSUBSC); 
           # CHECK IF THE ID IS INCREMENTED , ID+-INT # 
           #IF O/P FOUND LOOKFOR INTEGER# 
       SUBINT:     # JUMP TO HERE IF NO ID #
           LOOKFOR(0,ILITTYPE,TRYRP) ;
         GOTO NEXTSUBSC;
  
TRYRP:     # TEST FOR RIGHT PARENS #
         LOOKFOR(0,RPTYPE,PREXIT) ; 
         # ERROR EXIT IF NOT FOUND #
   ENDSUBSC:  # JUMP HERE IF NO SUBSCRIPTS #
         RETURN ; 
          END  # OF SUBSCRIPTION #
  
  
  
PRCORR: 
# ******** #
  
     ILITISPNREF=FALSE; 
     AWISPNREF=FALSE; 
  
        LOOKFOR(0,AWTYPE,PREXIT); 
          CODEAWRT = AWRTDNREF; 
          DOREFERENCES; NOLOOKDONE=FALSE; 
  
          I=0;
          CORRESOLVE(1,I);
          IF I EQ 0 THEN GOTO PREXIT ;
  
        SUBSCRIPTION; # PROCESS ANY SUBSCRIPT LIST #
  
  
        LOOKFOR(RWFROM,REWDTYPE,CORTRYTO);
        GOTO CORRTOFROM; #IF FROM IS FOUND #
CORTRYTO:     # TEST FOR "TO"  #
  
          LOOKFOR(RWTO,REWDTYPE,PREXIT);
  
CORRTOFROM:    # EITHER "TO" OR"FROM" WAS FOUND#
          LOOKFOR(0,AWTYPE,PREXIT); 
DESTFIELD:  # PROCCES THE DESTINATION FIELD # 
          DOREFERENCES; NOLOOKDONE =FALSE;
  
          I=0;
          CORRESOLVE(2,I);
          IF I EQ 0 THEN GOTO PREXIT ;
  
        SUBSCRIPTION; # PROCESS ANY SUBSCRIPTS #
        LOOKFOR(RWROUNDED,REWDTYPE,DSTNOTRD); 
         # "ROUNDED" IS OPTIONAL# 
     DSTNOTRD:      # JUMP TO HERE IF NOT-ROUNDED#
  
        I=CTSP  ; 
          IF  CTTYPESTACK[CTSP] EQ CTDELIMITER AND
              (CTVALUESTACK[CTSP] EQ CTCOMMA OR 
               CTVALUESTACK[CTSP] EQ CTSEMICOLON) 
          THEN
              BEGIN 
              UNSTACKCTEXT(CTSP-1); 
              CTSTACKATOM[0] = CTSTACKATOM[I];
              CTSP = 0 ;
           END
        ELSE
           BEGIN
             UNSTACKCTEXT(CTSP) ; 
             CTSP=-1 ;
           END
  
        MUSTSAVECTXT = FALSE ;
        BUILDCTEXT(CTRESERVEDWD,RWCORRSTART,0,0); 
       # CORRSTART ATOM # 
        CTOUTPUT; 
  
        INITFINDPAIR(I) ; 
        IF I EQ 1 THEN # FIND THE PAIRS # 
          BEGIN 
            FINDPAIR(J);
              ASLONGAS J EQ 1 DO
                BEGIN 
                  INTINDEX = INTINDEX +1 ;
                  BUILDCTEXT(CTDNREF,INTINDEX,0,0); 
                  CTOUTPUT ;
                  INTINDEX = INTINDEX +1 ;
                  BUILDCTEXT(CTDNREF,INTINDEX,0,0); 
                  CTOUTPUT; 
                  FINDPAIR(J);
                END 
          END 
  
        BUILDCTEXT(CTRESERVEDWD,RWCORREND,0,0); 
        CTOUTPUT; 
        MUSTSAVECTXT= TRUE ;
#        * * *  # 
#         END OF CORR  #
          LOOKFOR(0,AWTYPE,PREXIT); 
           # ANOTHER DESTINATION FIELD FOUND #
           GOTO DESTFIELD;
  
  
PRRETURN: 
# ******** #
                SPTYPE=4 ;
                GOTO PRRETREL ; 
  
  
PRRELEASE:  
# ******** #
                SPTYPE = 3 ;
  
PRRETREL: 
                SPLINE = CLALINE ;
                SPCOL = CLACOLUMN ; 
                $BEGIN
                               IF INDEBUG THEN
                                DISPLAY(2,"RETURN-RELEASE",0,14); 
                $END
#            LOOK FOR AN AWREF  # 
               LOOKFOR(0,AWTYPE,PREXIT);
               CODEAWRT = AWRTDNREF ; 
               DOREFERENCES;
               NOLOOKDONE= FALSE ;
               # BUILD SPBT ENTRY # 
          SPDNAT = CTVALUESTACK[CTSP];
               SPBTBUILD(0,0);
  
                GOTO PREXIT ; 
  
  
PRPICTURE:  
# ******** #
#           <PICTURE>::= RWPICTURE RWIS PICTURESTRING  #
#                        RWPICTURE PICTURESTRING .     #
# # 
#     HANDLE THE OPTIONAL "IS" , USE GETPICTOKEN #
  
          GETPICTOKEN;
          IF SAREALENGTH EQ 2 THEN
             IF C<0,2> SAREA[0] EQ "IS" THEN
               BEGIN
                # SKIP OVER THE IS #
                  GETPICTOKEN;
               END
  
#          THE PICTURE TPKEN IS NOW THE CURRENT TOKEN # 
  
          DDCTEXTBUILD; 
          CTOUTPUT; 
          GOTO PREXIT ; 
  
  
# # 
# # 
  
PRENTER:  
# ******** #
        $BEGIN
          IF INDEBUG THEN DISPLAY(2,"ENTER PARSE",0,11);
        $END
  
        NOLOOKDONE = FALSE ;
        GETTOKEN; 
        SKIPCOMMAS; 
        # NOW LOOKING AT LANG NAME OR ROUTINE NAME IF CORRECT SYNTAX #
        # CHECK FOR AN ASSIGNED WORD OR A LITERAL # 
        IF CLATYPE EQ AWTYPE
          THEN
          BEGIN # ASSIGNED WORD # 
            CODEAWRT = AWRTDNREF; 
            DOREFERENCES; 
            SKIPCOMMAS; 
          END 
        ELSE IF CLATYPE LQ QLITTYPE 
          THEN
          BEGIN # LITERAL # 
            PDCTEXTBUILD; # PUT OUT CTEXT AND GET NEXT TOKEN #
            CTOUTPUT; 
            GETTOKEN; 
            SKIPCOMMAS; 
          END 
        ELSE GOTO PREXIT;  #NEITHER SO QUIT#
        # THE SECOND ASSIGNED WORD OR LITERAL IS OPTIONAL # 
        IF CLATYPE EQ AWTYPE # FOLLOW SAME LOGIC AS ABOVE # 
          THEN
          BEGIN # ASSIGNED WORD # 
            CODEAWRT = AWRTDNREF; 
            DOREFERENCES; 
            SKIPCOMMAS; 
          END 
        ELSE IF CLATYPE LQ QLITTYPE 
          THEN
          BEGIN # LITERAL # 
            PDCTEXTBUILD; 
            CTOUTPUT; 
            GETTOKEN; 
            SKIPCOMMAS; 
          END # SINCE IT WAS OPTIONAL FALL THROUGH #
        # SHOULD BE LOOKING AT USING IF THERE IS ONE #
        IF CLATYPE EQ REWDTYPE AND CLAVALUE EQ RWUSING
          THEN
          BEGIN # USING: DON"T KNOW IF DNREFS OR PNREFS # 
            DEBUGOBJLIST = 1; 
            PDCTEXTBUILD; 
            CTOUTPUT; 
            GETTOKEN; 
          END 
        # THE TEXT HAS BEEN STACKED NOW OUTPUT IT # 
        GOTO PREXIT;
    CONTROL EJECT;
# # 
PRSUBSCHEMA:  
# ******** #
       CONTROL IFNQ CB5$CDCS,"NO";
        IF INSPECIALNAM THEN
          BEGIN 
            LOOKFOR(RWIS,REWDTYPE,PREXIT);
  
           GETTOKEN;  NOLOOKDONE = FALSE ;  # GET THE SUB-SCHEMA NAME#
           IF USEDDL THEN    #DUPLICATE -SUB-SCHEMA IS- CLAUSE# 
                BEGIN 
                 SSDIAGS(D209); 
                 GOTO PREXIT; 
                END 
                # SET SUB-SCHEMA NAME IN CCT #
                CCTSSNAME[0] = SAREA[0];  # SAVE THE SUBSCHEMA NAME # 
                CONTROL IFEQ CB5$CDCS,"CDCS2";
                SUBSCHLINE = CLALINE;    #SAVE FOR SELECT PROCESSING# 
                SUBSCHCOLUMN = CLACOLUMN; 
                CONTROL FI; 
                C<10,10>CCTSSNAME[0] = SAREA[1];
                C<20,10>CCTSSNAME[0] = SAREA[2];
                SUBFAIL = 0;  #SET TO INDICATE -OPEN- OF SS#
                ABET$SEEN = TRUE;      # JUST LIKE -ALPHABET- CLAUSE   #
  
               DDSUBSC;           # OPEN LIBRARY ,READ SSLIST # 
  
               CONTROL IFEQ CB5$CDCS,"CDCS2"; 
               IF SUBFAIL EQ 0 THEN SSFLAG = TRUE; #SUB-SCHEMA IS SEEN# 
               CONTROL FI;
               IF SUBFAIL EQ 1 THEN 
               BEGIN
                # THE SUB-SCHEMA CANNOT BE OPENED # 
  
                 GOTO PREXIT; 
               END
          USEDDL = TRUE;     #ALLOW -SELECT-S FROM SUBSCHEMA# 
         END
       CONTROL FI;
     GOTO PREXIT  ; 
# # 
# # 
  # # 
PRSELECT: 
# ***** # 
        LOOKFOR(RWOPTIONAL,REWDTYPE,SELOPT);
SELOPT:      # OPTIONAL IS OPTIONAL # 
          LOOKFOR(0,AWTYPE,PREXIT);  # AREA-NAME #
       CONTROL IFNQ CB5$CDCS,"NO";
  
        C<0,10>SELAREANAME = SAREA[0];
        C<10,10>SELAREANAME = SAREA[1]; 
        C<20,10>SELAREANAME = SAREA[2]; 
       CONTROL FI;
        CODEAWRT = AWRTDNREF; 
        DOREFERENCES;   # FILE-NAME # 
        NOLOOKDONE = FALSE; 
      CONTROL IFNQ CB5$CDCS,"NO"; 
       IF NOT USEDDL THEN GOTO  PREXIT;  # NO SUBSCHEMA # 
  
  
          SUBFAIL = 0;       #SET TO INDICATE -SELECT- OF AREA# 
          DDSELEC;  # LOOK IN THE LIBRARY FOR THIS FILE NAME #
                    # PUT THE NAME INTO THE SAT IF FOUND   #
      CONTROL FI; 
          GOTO PREXIT ; 
PREXIT: 
          # ONLY GEN CTEXT WHEN NOT IN IDENTIFICATION DIVISION #
          IF CURRENTDIV NQ IDENTDIV THEN
            BEGIN 
              IF  SV$CLAS  THEN 
                  BEGIN 
                  MUSTSAVECTXT = FALSE; 
                  PUT$ALPHBET;
                  END 
              UNSTACKCTEXT(CTSP); 
              MUSTSAVECTXT = FALSE; 
            END 
          IF NOLOOKDONE THEN
            BEGIN 
              GETTOKEN; 
              NOLOOKDONE = FALSE; 
            END 
          RETURN; 
# # 
     END # OF SPECIALPARSE #
CONTROL IFEQ CB5$CDCS,"CDCS2";
CONTROL EJECT;
  
  
PROC CDCSSELECTS; 
# 
CDCSSELECTS SIMULATES A SELECT STATEMENT FOR EACH AREA IN THE 
SUB-SCHEMA WHICH DOES NOT HAVE A SELECT STATEMENT FOR IT IN 
THE FILE-CONTROL PARAGRAPH. 
  
THE LINE NUMBER AND COLUMN NUMBER FROM THE SUB-SCHEMA IS CLAUSE ARE USED
FOR DIAGNOSTIC PURPOSES.
# 
BEGIN 
IF SSFLAG 
   THEN   #TRUE WHEN THERE IS A SUB-SCHEMA# 
      BEGIN 
 DDLFITBUF:  # OVERLAID BY DDLFIT SINCE CODE NOT USED AGAIN # 
      P<DDLFIT> = LOC(DDLFITBUF); 
      SSFLAG = FALSE;   #SO WE ONLY GO THRU THIS CODE ONCE# 
  
      #SAVE VALUES TO BE RESTORED LATER#
      CLALINESAVE = CLALINE;
      CLACOLSAVE = CLACOLUMN; 
  
      #INITIALIZE VALUES# 
      CLALINE = SUBSCHLINE; 
      CLACOLUMN = SUBSCHCOLUMN; 
      MUSTSAVECTXT = FALSE;      #NO NEED TO STACK CTEXT# 
  
      #GENERATE CTEXT FOR LINE NUMBER OF *SUB-SCHEMA IS* CLAUSE#
      BUILDCTEXT(CTDELIMITER,CLALINE,0,0);
      CTOUTPUT; 
  
      #CREATE *INPUT-OUTPUT SECTION.* LINE IF NONE ALREADY# 
      IF IOSECTIONFLG THEN GOTO IOSECTIONDUN; 
      BUILDCTEXT(CTRESERVEDWD,RWINPUTOUTPU,CLACOLUMN, 
                 EDCTEXTKEY[RWINPUTOUTPU]); 
      CTOUTPUT;      #CTEXT FOR *INPUT-OUTPUT*# 
  
      BUILDCTEXT(CTRESERVEDWD,RWSECTION,CLACOLUMN,
                 EDCTEXTKEY[RWSECTION]);
      CTOUTPUT;      #CTEXT FOR *SECTION*#
  
      BUILDCTEXT(CTPERIOD,0,CLACOLUMN,1); 
      CTOUTPUT;      #CTEXT FOR A PERIOD# 
  
      #CREATE *FILE-CONTROL.* LINE IF NONE ALREADY# 
      IOSECTIONDUN: 
      IF FILECTLFLAG THEN GOTO FILECTLDONE; 
      BUILDCTEXT(CTRESERVEDWD,RWFILECONTRO,CLACOLUMN, 
                 EDCTEXTKEY[RWFILECONTRO]); 
      CTOUTPUT;      #CTEXT FOR *FILE-CONTROL*# 
  
      BUILDCTEXT(CTPERIOD,0,CLACOLUMN,1); 
      CTOUTPUT;      #CTEXT FOR A PERIOD# 
# 
      NOW LOOP THROUGH THE AREAS IN THE SUB-SCHEMA LOOKING FOR AREAS
      WHICH LACK SELECT CLAUSES.
# 
      FILECTLDONE:  
      $BEGIN
      IF INDEBUG THEN 
         BEGIN
         DISPLAY(2,"IN PROC CDCSSELECTS",0,19); 
         OUTPUT(2," RLMLSTAD=",DEC(SBCWRLMLSTAD[1])); 
         OUTPUT(2,"  DE$ARLL=",DEC(DE$ARLL)); 
         END
      $END
  
      FOR I = 0 STEP 4 UNTIL DE$ARLL-1 DO 
         BEGIN
  
         #READ AREA DESCRIPTIONS INTO CDCSBUF#
         DE$GTSB(CDCSBUF,4,SBCWRLMLSTAD[1]+I);
  
         $BEGIN 
         IF INDEBUG THEN
            BEGIN 
            OUTPUT(2," AREANAM0=",AREANAM0);
            OUTPUT(2," AREANAM1=",AREANAM1);
            OUTPUT(2," AREANAM2=",AREANAM2);
            OUTPUT(2," ISITAREA=",DEC(ISITAREA)); 
            OUTPUT(2,"  DASTATE=",DEC(DASTATE));
            END 
         $END 
  
         IF DASTATE NQ 0
            THEN
               BEGIN
               INTERCEPTOR(CLACOLUMN,CLALINE,207,0);
               GOTO ALLDONE;
               END
  
         #ISITAREA=0 IF NAME IS RELATION, ELSE AREA.  DO NOT GENERATE 
          A SELECT CLAUSE FOR A RELATION, ONLY AREAS.#
         IF ISITAREA EQ 0 THEN GOTO SELECTDONE; 
  
         C<0,10>SELAREANAME = AREANAM0; 
         C<10,10>SELAREANAME = AREANAM1;
         C<20,10>SELAREANAME = AREANAM2;
  
            $BEGIN
            IF INDEBUG THEN 
               BEGIN
               OUTPUT(2,"  SELECT0=",C<0,10>SELAREANAME); 
               OUTPUT(2,"  SELECT1=",C<10,10>SELAREANAME);
               OUTPUT(2,"  SELECT2=",C<20,10>SELAREANAME);
               END
            $END
  
         #NOW BLANK-FILL AREANAM# 
         FOR J = 29 STEP -1 DO
            BEGIN 
            IF C<J>AREANAM NQ 0 THEN GOTO BLANKFILLED;
            C<J>AREANAM = O"55";      #INSERT BLANK#
            END 
  
         BLANKFILLED: 
            $BEGIN
            IF INDEBUG THEN 
               BEGIN
               OUTPUT(2," AREANAM0=",AREANAM0); 
               OUTPUT(2," AREANAM1=",AREANAM1); 
               OUTPUT(2," AREANAM2=",AREANAM2); 
               END
            $END
  
         #GENERATE SAT IF NEEDED# 
         BUILDSAT;
         IF SUBFAIL EQ -1 THEN GOTO SELECTDONE; 
         IF SUBFAIL EQ  1 THEN GOTO ALLDONE;
  
         #GET LFN FROM SUB-SCHEMA FIT FOR THIS AREA SO WE CAN GENERATE
          <IMPLEMENTOR-NAME-1> AND <IMPLEMENTOR-NAME-2>.# 
  
         #STEP 1 -- GET DATA CONTROL ENTRY# 
         DE$GTSB(DCA,DCASIZE,SBARDCONTRLA[1]);
  
         IF DASTATE NQ 0
            THEN
               BEGIN
               INTERCEPTOR(CLACOLUMN,CLALINE,208,0);
               GOTO SELECTDONE; 
               END
  
         #STEP 2 -- GET LFN FROM FIRST WORD OF FIT# 
         DE$GTSB(DDLFIT,1,DCFITWA+SBARDCONTRLA[1]); 
  
         IF DASTATE NQ 0
            THEN
               BEGIN
               INTERCEPTOR(CLACOLUMN,CLALINE,208,0);
               GOTO SELECTDONE; 
               END
  
         #NOW GENERATE A SELECT FOR THIS AREA#
         BUILDCTEXT(CTRESERVEDWD,RWSELECT,CLACOLUMN,
                    EDCTEXTKEY[RWSELECT]);
         CTOUTPUT;      #CTEXT FOR *SELECT*#
  
         SAREA[0] = AREANAM0; 
         SAREA[1] = AREANAM1; 
         SAREA[2] = AREANAM2; 
         INTINDEX = INTINDEX + 1; 
         BUILDCTEXT(CTDNREF,INTINDEX,CLACOLUMN,0);
         CTOUTPUT;      #CTEXT FOR <AREA-NAME># 
         QUALAWRT = 0;
         CODEAWRT = AWRTDNREF;
         AWRTBUILD;      #BUILD AN AWRT ENTRY#
  
         BUILDCTEXT(CTRESERVEDWD,RWASSIGN,CLACOLUMN,
                    EDCTEXTKEY[RWASSIGN]);
         CTOUTPUT;      #CTEXT FOR *ASSIGN*#
  
         BUILDCTEXT(CTRESERVEDWD,RWTO,CLACOLUMN,
                    EDCTEXTKEY[RWTO]);
         CTOUTPUT;      #CTEXT FOR *TO*#
  
         SAREA[0] = C<0,7>FITLFN;      #LFN FROM SUB-SCHEMA FIT#
         SAREA[1] = " ";
         SAREA[2] = " ";
  
         #NOW BLANK-FILL SAREA[0]#
         FOR J = 6 STEP -1 DO 
            BEGIN 
            IF C<J>SAREA[0] NQ 0 THEN GOTO ISBLANKFILLD;
            C<J>SAREA[0] = O"55";      #INSERT BLANK# 
            END 
  
         ISBLANKFILLD:  
         $BEGIN 
         IF INDEBUG THEN
            BEGIN 
            OUTPUT(2,"  CONTRLA=",DEC(SBARDCONTRLA[1]));
            OUTPUT(2,"  DCFITWA=",DEC(DCFITWA));
            OUTPUT(2,"   FITLFN=",FITLFN);
            OUTPUT(2," SAREA[0]=",SAREA[0]);
            END 
         $END 
  
         IF SAREA[0] EQ AREANAM0 THEN GOTO NEEDLITERAL; 
  
         INTINDEX = INTINDEX + 1; 
         BUILDCTEXT(CTDNREF,INTINDEX,CLACOLUMN,0);
         CTOUTPUT;      #CTEXT FOR <IMPLEMENTOR-NAME-1>#
         AWRTBUILD;     #BUILD AN AWRT ENTRY# 
         GOTO FINISHSELECT; 
  
         NEEDLITERAL: 
         CLATYPE = QLITTYPE;
         SAREALENGTH = J + 1;  #LENGTH OF <IMPLEMENTOR-NAME-1># 
         BUILDCTEXT(CTLITERAL,PLTNEXT,CLACOLUMN,0); 
         PLTBUILD;
         CTOUTPUT;      #CTEXT FOR <IMPLEMENTOR-NAME-1>#
  
         FINISHSELECT:  
         CLATYPE = QLITTYPE;
         SAREALENGTH = J + 1;  #LENGTH OF <IMPLEMENTOR-NAME-2># 
         BUILDCTEXT(CTLITERAL,PLTNEXT,CLACOLUMN,0); 
         PLTBUILD;
         CTOUTPUT;      #CTEXT FOR <IMPLEMENTOR-NAME-2>#
  
         BUILDCTEXT(CTPERIOD,0,CLACOLUMN,1);
         CTOUTPUT;      #CTEXT FOR A PERIOD#
  
         SELECTDONE:  
         END
  
      #RESTORE VALUES#
      ALLDONE:  
      CLALINE = CLALINESAVE;
      CLACOLUMN = CLACOLSAVE; 
      END 
  
RETURN; 
END 
  
CONTROL FI; 
  CONTROL EJECT;
  
  PROC DOIDENTDIV;
  
    # THIS PROC PROCESSES THE IDENTIFICATION DIVISION # 
  
    # THE IDENTIFICATION DIVISION IS PROCESSED AND THE NEXT DIVISION
      INDICATOR IS SET. ERROR MESSAGES ARE GENERATED FOR MISSING OR 
      DUPLICATED PARAGRAPHS,IMPROPER PROGRAM NAME AND ILLEGAL TOKENS. 
      UPON TERMINATION, CONTROL LEAVES DOIDENTDIV WITH THE START
      OF THE HEADER OF THE NEXT PART OF THE PROGRAM AS THE CURRENT
      TOKEN.
    # 
    BEGIN 
      $BEGIN IF INDEBUG THEN DISPLAY(2," DOIDENTDIV CALLED.",0,19); 
      $END
  
        # ACCESS THE FIRST PROGRAM TOKEN AND THEN LOOP UNTIL THE
          END OF THE DIVISION IS RECOGNIZED. ALL TOKENS EXCEPT
          THOSE IN THE B-AREA OF COMMENT ENTRY PARAGRAPHS ARE 
          EXAMINED AS POTENTIAL NEW HEADERS OF SOME SORT OR 
          AS DIAGNOSABLE ERRORS. IDSWITCH BRANCHES TO THE 
          APPROPRIATE PLACE DEPENDING ON WHAT KIND OF TOKEN WAS 
          ENCOUNTERED.
        # 
        GETTOKEN; 
        # START UP LOOKING AT ALL TOKENS #
        COMMENTENTRY = FALSE; 
        # INITIALIZE IDENTIFICATION DIVISION STATUS WORD #
        IDDIVSTATUS = 0;
        ASLONGAS INIDENTDIV DO # LOOP THRU IDENTIFICATION DIVISION #
        BEGIN 
  
        # IGNORE ALL TOKENS IN B-AREA OF COMMENT PARAGRAPHS # 
        # THE B-AREA TEST IS NECESSARY IN CASE SPECIALPARSE 
          HAPPENED TO RETURN A TOKEN IN THE A-AREA WHICH MUST 
          BE EXAMINED AS A POTENTIAL NEW PARAGRAPH. 
        # 
        IF CLACOLUMN GR BMARGIN AND COMMENTENTRY THEN 
          BEGIN 
            SKIPTOAAREA;
            GETTOKEN; 
          END 
  
        # BRANCH TO APPROPRIATE CODE DEPENDING ON TOKEN TYPE #
        SWITCH IDKEYSWITCH ,IDILIT,IDNLIT,IDFLIT,IDQLIT,IDAW, 
                            IDOP,IDPUNC,IDRP,IDLP,IDREWD,IDPIC, 
          IDEOD,IDPNDEF,IDPNREF,IDFIG,IDSPEC,,IDBLIT; 
        GOTO IDKEYSWITCH[CLATYPE];
  
        IDILIT: IDNLIT: IDFLIT: IDQLIT: IDAW: IDOP: IDPUNC: 
        IDRP: IDLP: IDPIC: IDPNDEF: IDPNREF: IDFIG: IDSPEC: 
IDBLIT: 
        BEGIN 
          GOTO IDERROR; 
        END 
  
        IDREWD: 
        BEGIN 
          IF IDPARSEKEY[CLAVALUE] EQ 0 THEN 
            GOTO IDERROR; 
          ELSE
            BEGIN 
                  SPECIALPARSE(IDPARSEKEY[CLAVALUE]); 
              # ALWAYS HAVE A NEW TOKEN AT THIS POINT # 
              GOTO IDOLDTOKEN;
            END 
        END 
  
        IDEOD:  
        BEGIN 
          GOTO IDLOOPEND; 
        END 
  
        IDERROR:  
          # GENERATE DIAGNOSTIC DEPENDING ON WHERE ITEM OCCURRED #
          IF CLACOLUMN LQ BMARGIN THEN
            SSDIAGS(D026);
          ELSE
           SSDIAGS(D047); 
  
        IDNEWTOKEN: 
          GETTOKEN; 
  
        IDOLDTOKEN: 
  
        END # OF IDENTIFICATION DIVISION LOOP # 
  
        IDLOOPEND:  
        # NOW VERIFY EXISTENCE OF VITAL ELEMENTS OF THIS DIVISION # 
  
        # DID WE HAVE ANY IDENTIFICATION DIVISION ELEMENTS AT ALL # 
        IF IDDIVSTATUS EQ 0 THEN
     BEGIN
     #IF END OF FILE IS ENCOUNTERED AND THERE IS #
     #NO EVIDENCE OF A COBOL PROGRAM, ERASE ALL  #
     #SPURIOUS DIAGNOSTICS.                      #
     IF CLATYPE EQ EODTYPE
      THEN
          BEGIN 
          CCTETEXTLEN = 0;
          CCTABORT = TRUE;
          INTERCEPTOR(0,0,D099,0);
          END 
      ELSE
          INTERCEPTOR(0,0,D055,0);
     END
        ELSE
          BEGIN 
            # DID WE HAVE THE IDENTIFICATION DIVISION HEADER #
            IF B<0,1>IDDIVSTATUS EQ 0 THEN
              INTERCEPTOR(0,0,D056,0);
            # DID WE HAVE A PROGRAM-ID PARAGRAPH #
            IF B<1,1>IDDIVSTATUS EQ 0 THEN
              INTERCEPTOR(0,0,D032 ,0); 
          END 
  
        # NOW CHECK IF A VALID PROGRAM NAME WAS SPECIFIED # 
        IF PROGRAMID EQ "NO-NAME" THEN
          BEGIN 
            # NO: EITHER BECAUSE THE NAME SPECIFIED WAS INCORRECT,
              THE PROGRAM-ID PARAGRAPH WAS OMITTED OR THE ENTIRE
              DIVISION WAS MISSING. SO WE SET UP THE PAGE TITLE 
              AND THE CCT ENTRY FOR THE PROGRAM NAME. 
            # 
            LISTID = PROGRAMID; 
          CBLIST(4, LISTHED, 110);
          $BEGIN
          GOTO SKPGEJECT2;
          $END
              IF CCTSOURCLIST   # PREVENT HEADER WHEN NO SOURCE LISTING#
              THEN
                  BEGIN 
                  CBLIST(3," ",1);   # PAGE EJECT AND PRINT HEADINGS   #
                  END 
          $BEGIN
SKPGEJECT2: 
          $END
            CCTPROGRAMID[0] = PROGRAMID;
            # PLT PROGRAM NAME ENTRY WAS INITIALIZED TO NO-NAME # 
                 #PUT NAME IN "COMPILING" MSG + DISPLAY IT# 
                 C<10,7>COM$MSG = PROGRAMID;
                  C<17,4>COM$MSG = 0;  #ZERO BYTE TO TERMINATE IT#
                 PUTDMSG(COM$MSG);
          END 
  
    END # DOIDENTDIV #
  CONTROL EJECT;
  
  PROC DODATADIV; 
  
    # THIS PROC PROCESSES THE DATA DIVISION # 
  
  
    FUNC LEVELNUMCHEK B;
      # CHECK TO SEE IF INTEGER CAN BE LEVEL NUMBER # 
  
      BEGIN 
        # RETURNS TRUE IF ITIT CAN BE A VALID LEVEL NO. # 
  
        IF CLATYPE NQ ILITTYPE THEN 
          BEGIN 
            LEVELNUMCHEK = FALSE; 
            RETURN; 
          END 
  
        IF SIGNSW THEN # NOT LEVEL NO. #
          BEGIN 
            LEVELNUMCHEK = FALSE; 
            RETURN; 
          END 
        # ELSE #
        LEVELNUMVALU = ASCIITOBIN;
        IF LEVEL$1TO49
        THEN
          BEGIN 
           IF CCTFIPSLEVEL LS 3 
           THEN    BEGIN
             IF LEVELNUMVALU GR 10
           THEN BEGIN 
                #FIPS = 3 SUPPORTS LEVEL NUMBERS 11-49# 
                SSDIAGS(D405);
                END 
           ELSE BEGIN 
             IF SAREALENGTH EQ 1
             THEN BEGIN 
             #FIPS = 3 SUPPORTS ONE DIGIT LEVEL NUMBERS.     #
                  SSDIAGS(610); 
                  END 
                END 
                END 
            LEVELNUMCHEK = TRUE;
            RETURN; 
          END 
        ELSE
        IF LEVELNUMVALU EQ 66 OR LEVELNUMVALU EQ 77 OR
           LEVELNUMVALU EQ 88 THEN
          BEGIN 
            LEVELNUMCHEK = TRUE;
            RETURN; 
          END 
        ELSE
          LEVELNUMCHEK = FALSE; 
        RETURN; 
  
      END # LEVELNUMCHEK #
  
  
    # START OF CODE # 
    BEGIN 
    $BEGIN IF INDEBUG THEN DISPLAY(2," DODATADIV CALLED.",0,18);
    $END
  
  
    NOTVALUEOF = TRUE;
    ASLONGAS INDATADIV DO # LOOP THRU DATA DIVISION # 
  
      BEGIN 
        # DDKEYSWITCH USES TYPE OF CURRENT TOKEN TO DETERMINE 
          THE TYPE OF PROCESSING NEEDED. #
  
        SWITCH DDKEYSWITCH , DDILIT,DDNLIT,DDFLIT,DDQLIT,DDAW,
                    DDOP,DDPUNC,DDRP,DDLP,DDREWD,DDPIC,DDEOD, 
          ,,DDFIG,DDSPEC,,DDBLIT; 
  
        $BEGIN
           IF INDEBUG THEN OUTPUT(2,"DDSWITCH=",DEC(CLATYPE));
        $END
  
        GOTO DDKEYSWITCH[CLATYPE];
  
      DDNLIT: DDFLIT: DDQLIT: DDOP: DDRP: DDLP: DDPIC: DDFIG: 
DDBLIT: 
        BEGIN  # NOT SPECIAL #
          DDCTEXTBUILD; 
          CTOUTPUT; 
          GETTOKEN; 
          GOTO CASEEND; 
        END 
  
      DDAW: DDSPEC: 
        BEGIN # DO ASSIGNED WORD PROCESSING # 
          IF DEFINITION THEN # AW IS A DEFINITION # 
            BEGIN 
              # THIS HAPPENS IN A CD #
              LEVELNUMVALU = 1; # SO ITEMS THAT ARE SUBORD. TO
                                THE CD NAME ARE HANDLED OK #
              DNDEFROUTINE; 
  
             GETTOKEN;
             GOTO CASEEND;
            END 
          ELSE # AW IS A REFERENCE SO HANDLE QUALIFICATION #
            BEGIN 
              CODEAWRT = AWRTDNREF; # CODE FOR AWRT ENTRY # 
              DOREFERENCES; 
  
              GOTO CASEEND; 
            END 
        END # OF AW # 
  
      DDREWD: 
        BEGIN # RESERVED WORD # 
          IF DDPARSEKEY [CLAVALUE] EQ 0 THEN
            BEGIN 
              DDCTEXTBUILD; CTOUTPUT; GETTOKEN; 
              GOTO CASEEND; 
            END 
          ELSE
            BEGIN 
                  SPECIALPARSE(DDPARSEKEY[CLAVALUE]); 
              GOTO CASEEND; 
            END 
        END # OF RESERVED WORD CASE # 
  
  
      DDPUNC: 
        BEGIN # RECOGNIZE ILITS AS LEVEL NUMBER IF THEY 
                FOLLOW A PERIOD AND THEN DO DATA NAME DEFN.#
  
          DDCTEXTBUILD; 
          CTOUTPUT; 
          IF CLAVALUE EQ "." THEN 
            BEGIN 
              DEFINITION = FALSE; # NOT IN CD # 
              INFD = FALSE;  # NOT IF FD #
              NOTVALUEOF = TRUE; # NOT IN "VALUE OF" CLAUSE # 
              GETTOKEN; # GET LEVEL NUMBER #
              # CHECK LEVEL NUMBER. IF OK THEN SAVE BINARY
                VALUE OF NUMBER # 
              IF LEVELNUMCHEK THEN # HAVE LEVEL NUMBER #
                BEGIN 
                  DODATADEF; # PROCESS THE DEFINITION # 
                END 
  
              ELSE # NOT A LEVEL NUMBER # 
               BEGIN
               END
  
            END 
            ELSE
              BEGIN 
              GETTOKEN; 
              END 
             GOTO CASEEND;
  
        END # OF DDPUNC # 
  
      DDILIT: 
        BEGIN # RECOGNIZE DEFINITION IF PRECEEDING PERIOD IS
                MISSING # 
          #CHECK IF THIS WILL BE THE FIRST ATOM ON THIS LINE.#
  
          ITEM FIRSTATOM B; 
          IF CLALINE NQ SSLINE
          THEN FIRSTATOM = TRUE;
          ELSE FIRSTATOM = FALSE; 
  
          DDCTEXTBUILD; 
          #CHECK IF THIS IS A LEVEL NUMBER OR AN ILIT#
  
          IF FIRSTATOM AND LEVELNUMCHEK AND NOTVALUEOF THEN 
            BEGIN 
              # SAVE COLUMN NUMBER OF LITERAL # 
               I = CLACOLUMN; 
              GETTOKEN; 
              IF CLATYPE EQ AWTYPE THEN 
                BEGIN 
                  DEFINITION = FALSE; # NOT IN CD # 
              INFD = FALSE; 
                  NOTVALUEOF = TRUE; # NOT IN "VALUE OF" CLAUSE # 
                  BUILDCTEXT(CTLEVELNUM,LEVELNUMVALU,    I    , 
                             1);
                  CTOUTPUT; 
                   DNDEFROUTINE;
                  GETTOKEN; 
                END 
              ELSE
                IF CLATYPE EQ REWDTYPE AND CLAVALUE EQ RWFILLER 
                  THEN
                  BEGIN 
                    FILLERSWITCH = TRUE;
                    BUILDCTEXT(CTLEVELNUM,LEVELNUMVALU, 
                                    I    ,1); 
                    CTOUTPUT; 
                    IF INREPORTSECT OR NOT LVL$1TO49$77 
                    THEN
                      BEGIN # FILLER NOT LEGAL HERE # 
                       SSDIAGS(D013); 
                      END 
                    DNDEFROUTINE; 
                    GETTOKEN; 
                  END 
              ELSE
                BEGIN # NOT A LEGAL LEVEL NUMBER #
                  IF CLATYPE NQ EODTYPE THEN
                    BEGIN 
                      CTOUTPUT; 
                    END 
                END 
              END 
            ELSE # NOT A LEVEL NUMBER # 
              BEGIN 
                 CTOUTPUT; GETTOKEN;
              END 
  
          GOTO CASEEND; 
        END # OF THIS CASE #
  
  
      DDEOD:  
        BEGIN # END OF FILE # 
    CCT1STCOMPIL = TRUE;
          CCTPDLITADDR = PLTNEXT ;
        IF INREPORTSECT THEN
          BEGIN 
          CCTRSCTXLEN = CTEXTNEXT - 1           ; 
          CCTPDCTXADDR = CTEXTNEXT; 
          END 
        ELSE
          CCTDDCTXLEN = CTEXTNEXT - 1           ; 
  
          RETURN; 
        END 
  
        CASEEND:  
      END # OF DOFOREVER BLOCK #
  
    END # OF DODATADIV #
CONTROL EJECT;
  
  PROC DOENVIRDIV;
  
    # THIS PROC PROCESSES THE ENVIR DIVISION #
  
    ITEM MOREQUALIFS B; 
  
    BEGIN 
    $BEGIN IF INDEBUG THEN DISPLAY(2," DOENVIRDIV CALLED.",0,19); 
    $END
  
              IF CLATYPE NQ AWTYPE THEN 
    EDCTEXTBUILD; # BUILD FIRST ENV. DIV. CTEXT ATOM #
CONTROL IFNQ CB5$CDCS,"NO"; 
    USEDDL = FALSE ;  # DONT TRY SELECTS ON DDL FILES # 
                    # UNLESS SUB-SCHEMA IS FOUND #
CONTROL FI; 
  
    ASLONGAS INENVIRDIV DO # LOOP THRU ENV. DIV. #
  
      BEGIN 
        # EDKEYSWITCH USES THE TYPE OF THE CURRENT TOKEN TO 
          DETERMINE THE TYPE OF PROCESSING NEEDED # 
  
        SWITCH EDKEYSWITCH , EDILIT,EDNLIT,EDFLIT,EDQLIT,EDAW,
                       EDOP,EDPUNC,EDRP,EDLP,EDREWD,EDPIC,EDEOD,
          ,,EDFIG,EDSPEC,,EDBLIT; 
  
        $BEGIN
           IF INDEBUG THEN OUTPUT(2," EDSWITCH=",DEC(CLATYPE)); 
        $END
  
        GOTO EDKEYSWITCH[CLATYPE];
  
      EDFIG:  
        BEGIN # IF HAVE "QUOTE" THEN COULD HAVE "QUOTE IS 
                APOSTROPHE" , ELSE FALL THRU TO NOT SPECIAL 
                CASE #
          IF CLAVALUE EQ RWQUOTE THEN 
            BEGIN 
                    SPECIALPARSE(EDPARSEKEY[RWQUOTE]);
              GOTO CASEEND; 
            END 
        END 
  
  
      EDILIT: EDNLIT: EDFLIT: EDQLIT: EDOP: EDPUNC: EDRP: EDLP: 
          EDPIC:  EDBLIT: 
        BEGIN 
          # NO SPECIAL PROCESSING NEEDED. JUST PUT OUT CTEXT ATOM 
            AND GET NEXT TOKEN #
          IF  SV$CLAS  THEN  # ALPHABET-NAME [MISSING IS] LITERAL CASE #
              PUT$ALPHBET;
          ABET$SEEN = FALSE;       # IF WE HAD "ALPHABET <NAME> IS LIT"#
          EDCTEXTBUILD; 
          CTOUTPUT; 
          GETTOKEN; 
          GOTO CASEEND; 
        END # OF NOTSPECIAL CASE #
  
 EDAW:  
          BEGIN 
          IF  INSPECIALNAM  THEN
              BEGIN 
              IF  NOT SV$CLAS  THEN 
                  BEGIN      # SAVE CURRENT ITEM #
                  IF  ABET$SEEN  THEN 
                      BEGIN        # IF "ALPHABET <NAME> IS .." SEEN# 
                      ABET$SEEN = FALSE;
                      GOTO EDSPEC;     # GO MAKE A REF #
                      END 
                      $BEGIN
                      IF  INDEBUG  THEN 
                          OUTPUT(2, "TOKEN SAVE", "D"); 
                      $END
                  SV$CLATYPE = CLATYPE; 
                  SV$CLAVALUE = CLAVALUE; 
                  SV$CLACOLUMN = CLACOLUMN; 
                  SV$CLALINE = CLALINE; 
                  SV$SAREA0 = SAREA[0]; 
                  SV$SAREA1 = SAREA[1]; 
                  SV$SAREA2 = SAREA[2]; 
                  IF  CLALINE NQ SSLINE  THEN 
                      BEGIN 
                      SSLINE = CLALINE; 
                      NEWLINEATOM;
                      END 
                  SV$CLAS = TRUE; 
                  GETTOKEN; 
                  GOTO CASEEND; 
                  END 
              ELSE
                  BEGIN 
                  CHKIMPS;         # CHECK FOR IMPLEMNTOR-NAME #
                  IF  FND$IMP  THEN 
                      BEGIN        # WE HAVE AN ALPHABET-NAME CLAUSE #
                      PUT$ALPHBET;     # PUT DNDEF #
                      CODEAWRT = AWRTDNREF; 
                      DOREFERENCES; 
                      END 
                  ELSE
    #     WE HAVE AN IMPLEMENTOR-NAME CLAUSE WITH THE "IS" MISSING #
                      BEGIN 
                      PUT$IMPNAM;  # PUT FIRST ITEM AS DNREF #
                      MUSTSAVECTXT = FALSE; 
                      LEVELNUMVALU = 55;
                      DNDEFROUTINE; 
                      END 
                  GETTOKEN; 
                  END 
              FND$IMP = FALSE;
              SV$CLAS = FALSE;
              GOTO CASEEND; 
              END 
          END 
  
  
 EDSPEC:  
        BEGIN    # HANDLE SPEC. REGISTER REFS # 
          CODEAWRT = AWRTDNREF; # SET CODE FOR ENTRY #
          DOREFERENCES; 
          IF  INSPECIALNAM  THEN
              GETTOKEN; 
  
            GOTO CASEEND; 
  
  
          END # OF ASSIGNED WORD CASE # 
  
        EDREWD: 
          BEGIN # IF TOKEN IS A SPECIAL RESERVED WORD THEN
                  A CLAUSE NEEDING SPECIAL PARSING IS POSSIBLY
                  FOLLOWING. IF SO , CALL SPECIAL PARSER. # 
  
            IF EDPARSEKEY[CLAVALUE] EQ 0 THEN # NOT SPECIAL # 
              BEGIN 
          IF  SV$CLAS  THEN  # ALPHABET-NAME NATIVE CASE #
              PUT$ALPHBET;
          ABET$SEEN = FALSE; # IF WE HAD ALPHABET <NAME> IS NATIVE CASE#
                EDCTEXTBUILD; 
                CTOUTPUT; 
                GETTOKEN; 
                GOTO CASEEND; 
              END 
            ELSE # HAVE SPECIAL CASE #
              BEGIN 
                  SPECIALPARSE(EDPARSEKEY[CLAVALUE]); 
                GOTO CASEEND; 
              END 
  
          END # OF RESERVED WORD CASE # 
  
        EDEOD:  
          BEGIN # END OF DATA HIT # 
    CCT1STCOMPIL = TRUE;
            CCTEDCTXLEN = CTEXTNEXT - 1           ; 
            RETURN; 
          END # OF END OF DATA CASE # 
  
        CASEEND:  
  
        END 
            # END OF DOFOREVER LOOP # 
  
    END # OF DOENVIRDIV # 
CONTROL EJECT;
  
  PROC DOPROCDIV; 
  
    # THIS PROC PROCESSES THE PROCEDURE DIVISION #
  
    BEGIN 
      $BEGIN IF INDEBUG THEN DISPLAY(2," DOPROCDIV CALLED.",0,18);
      $END
  
      DEBUGOBJLIST = 0; 
      ALLPROCSFLAG = FALSE; 
              IF CCTDUMPDATA THEN 
                BEGIN 
                BUILDCTEXT(CTRESERVEDWD,RWDIVISION,0,1);
                CTOUTPUT; 
                BUILDCTEXT(CTPERIOD,0,0,1); 
                CTOUTPUT; 
                END 
  
      ASLONGAS INPROCDIV DO # LOOP THRU PROCEDURE DIVISION #
        BEGIN 
  
          IF DELETESWITCH THEN # LOOKING A SOMETHING IN AAREA. IF NOT 
                             SECTION HEADER THEN CONTINUE DELETING
                                             THIS DEBUGGING SECTION # 
            BEGIN 
              IF CLATYPE EQ EODTYPE 
              THEN
                  BEGIN 
                  GOTO PDEOD; 
                  END 
              IF CLATYPE EQ PNDEFTYPE THEN GOTO PDPNDEF;
              MUSTSAVECTXT = TRUE;
              CTSP = -1;
              IF RWCOMMAND(RWEND) THEN
                    IF RWCOMMAND(RWDECLARATIV) THEN # HAVE "END DEC" #
                      BEGIN 
                        FOR I = CTSP-1 STEP -1 UNTIL 0 DO 
                BEGIN 
                  IF  CTTYPESTACK[I] EQ CTRESERVEDWD AND
                      CTVALUESTACK[I] EQ RWEND
                  THEN
                   BEGIN
                      CTTYPESTACK[I] = CTENDDCL;
                              GOTO ESCAPE1; 
                            END 
                   END
                        ESCAPE1:  
  
                        DELETESWITCH = FALSE; # END OF DELETED  SECT# 
                        UNSTACKCTEXT(CTSP); 
                        MUSTSAVECTXT = FALSE; 
                        ENDDCLFLAG = 1; 
                        DCLSWITCH = FALSE;
                        CCTDCLUPPBND = PNTNEXT - 1; 
                        GOTO CASEEND; 
                      END 
  
              # STILL IN DECL. SECTION IF GOT TO HERE # 
  
              MUSTSAVECTXT = FALSE; 
              CTSP = -1;
              SKIPTOAAREA; # SKIP TO NEXT NONEMPTY AAREA #
              GETTOKEN; # GET NEXT TOKEN #
              GOTO CASEEND; 
            END 
  
  
  
          # PDKEYSWITCH USES TYPE OF CURRENT TOKEN TO 
            DETERMINE THE TYPE OF PROCESSING NEEDED. #
     # BYPASS PROCEDURE DIVISION PROCESSING IN DUMPING FILE FOR FMA # 
       IF CCTDUMPDATA THEN
         BEGIN
         IF CLATYPE EQ EODTYPE THEN 
           GOTO PDEOD;
         GETTOKEN;
         GOTO CASEEND;
         END
  
          SWITCH PDKEYSWITCH , PDILIT,PDNLIT,PDFLIT,PDQLIT,PDAW,
                        PDOP,PDPUNC,PDRP,PDLP,PDREWD,PDPIC, 
          PDEOD,PDPNDEF,PDPNREF,PDFIG,PDSPEC,,PDBLIT; 
  
          $BEGIN
            IF INDEBUG THEN OUTPUT(2," PDSWITCH=",DEC(CLATYPE));
          $END
  
          GOTO PDKEYSWITCH[CLATYPE];
  
        PDILIT: PDNLIT: PDFLIT: PDQLIT: PDOP:  PDRP: PDPIC: PDFIG:  
          PDBLIT: 
          BEGIN # NOT SPECIAL # 
            PDCTEXTBUILD; 
            CTOUTPUT; 
            GETTOKEN; 
            GOTO CASEEND; 
          END 
  
        PDLP: 
          BEGIN # LEFT PAREN #
            ILITISPNREF = FALSE;  # ILIT CAN[T BE A PNREF HERE# 
            PDCTEXTBUILD; CTOUTPUT; GETTOKEN; 
            GOTO CASEEND; 
          END 
  
  
  
        PDPUNC: 
          BEGIN # PUNCTUATION # 
           IF CLAVALUE EQ "." THEN
             DEBUGOBJLIST = 0; #IN CASE WE WERE IN LIST#
            PDCTEXTBUILD; 
            CTOUTPUT; 
          IF ENDDCLFLAG EQ 1
          THEN BEGIN
          # CREATE CTEXT-ATOMS AND THE CORESPONDING PNT-ENTRIES FOR A # 
          # SECTION AND A PARAGRAPH AFTER THE END DECLARATIVES.       # 
                BUILDCTEXT(CTSNDEF,PNTNEXT,0,1);
                CTOUTPUT; 
                BUILDCTEXT(CTRESERVEDWD,RWSECTION,0,1); 
                CTOUTPUT; 
                BUILDCTEXT(CTPERIOD,0,0,1); 
                CTOUTPUT; 
                BUILDCTEXT(CTPNDEF,PNTNEXT+1,0,1);
                CTOUTPUT; 
                BUILDCTEXT(CTPERIOD,0,0,1); 
                CTOUTPUT; 
                DECLPNT;
                ENDDCLFLAG = 0; 
                END 
            GETTOKEN; 
            GOTO CASEEND; 
          END 
  
        PDAW: PDSPEC: 
          BEGIN # HAVE DATA NAME REFERENCE #
            SAVEDCTCOL = CLACOLUMN; 
            SAVEDCTLINE = CLALINE;
            IF DEBUGOBJLIST NQ 0 THEN 
              #MUST HAVE AWRT CODE THAT MEANS EITHER DN OR PN REF#
              BEGIN 
                CODEAWRT = AWRTPNORDN;
              END 
            ELSE
              CODEAWRT = AWRTDNREF; 
            DOREFERENCES; # HANDLES QUALIFIERS-BUILDS CTEXT # 
            IF DEBUGOBJLIST GR 1
            THEN BEGIN
                 CRLITATOM(QUALIFFLAGS);
                 BUILDCTEXT(CTLITERAL,PLTNEXT-1,CLACOLUMN,0); 
                 CTOUTPUT;
                 END
  
            GOTO CASEEND; 
          END 
  
        PDPNDEF:  
          BEGIN # PARAGRAPH OR SECTION NAME DEFINITION #
  
            DEBUGOBJLIST = 0; 
            SECTSWITCH = FALSE; 
            CTSP = -1;
            MUSTSAVECTXT = TRUE;
            BUILDCTEXT(CTPNDEF,PNTNEXT,CLACOLUMN,1);
            PNTNAME;
            CTOUTPUT; 
            GETTOKEN; 
            # IF AN ILIT FOLLOWS IT IS NOT A PNREF BUT RATHER A 
              SEGMENT NUMBER. WE MUST SET THE ILITISPNREF SWITCH
              HERE BECAUSE RWCOMMAND GETS THE NEXT TOKEN. # 
            ILITISPNREF = FALSE;
            IF RWCOMMAND(RWSECTION) THEN # HAVE SECTION DEFN #
              BEGIN 
                CCTSECTION[0] = TRUE; 
                DELETESWITCH = FALSE; # IN CASE LAST SECTION WAS
                                        BEING DELETED # 
                SECTSWITCH = TRUE; # HAVE SECTION DEF. #
                USEFORDEBUG = FALSE;
                SEGNUMBER = 0;
  
                FOR I = CTSP-1 STEP -1 UNTIL 0 DO 
                BEGIN 
              IF  CTTYPESTACK[I] EQ CTPNDEF 
              THEN
                    BEGIN 
                  CTTYPESTACK[I] = CTSNDEF; 
  
                      GOTO ESCAPE;
                    END 
                END 
                ESCAPE: 
  
                SKIPCOMMAS; 
                IF CLATYPE EQ ILITTYPE THEN # HAVE SEGMENT NUM #
                  BEGIN 
                    IF SIGNSW THEN # SEG NUM[S SHOULDN[T BE SIGNED# 
                   SSDIAGS(D034); 
                    SEGNUMBER = ASCIITOBIN; 
                    IF DCLSWITCH
                    THEN J = 49;
                    ELSE J = 99;
                    IF SEGNUMBER GR J 
                    THEN BEGIN
                        SSDIAGS(D035);
                         SEGNUMBER = 0; 
                         END
                    PDCTEXTBUILD; 
                    CTOUTPUT; 
                    GETTOKEN; 
                  END 
  
                ILITISPNREF = TRUE; # ILITS ARE NOW PNREFS #
                # NOW SEE IF HAVE " USE FOR DEBUGGING " # 
                # GET PAST PERIOD # 
                SKIPCOMMAS; 
                IF CLATYPE EQ PUNCTYPE AND CLAVALUE EQ "." THEN 
                  BEGIN 
                    PDCTEXTBUILD; CTOUTPUT; 
                    GETTOKEN; 
                  END 
  
  
  
                IF DCLSWITCH THEN # IN DECLARATIVES # 
                IF RWCOMMAND(RWUSE) THEN
                    BEGIN 
                      ITEM TEMPB B; 
                      TEMPB = RWCOMMAND(RWFOR); # TAKE OPTIONAL "FOR" # 
                      IF RWCOMMAND(RWDEBUGGING) THEN
                        BEGIN 
                      IF NOT CCTDEBUGMODE[0]
                      THEN BEGIN
                           # DELETE SECTION # 
                              CTSP = -1;
                              MUSTSAVECTXT = FALSE; 
                              DELETESWITCH = TRUE;
                              # SINCE PNTBUILD IS NOT CALLED, 
                                THE ENTRY IS EFFECTIVELY REMOVED# 
                              SKIPTOAAREA; # SKIP TO NEXT NON-EMPTY 
                                              AAREA # 
                              GETTOKEN; 
                              GOTO CASEEND; 
                            END 
                          # NO NEED TO STACK CTEXT ANY LONGER # 
                          UNSTACKCTEXT(CTSP); 
                          MUSTSAVECTXT = FALSE; 
                          CTSP = -1;
                          USEFORDEBUG = TRUE; 
  
                          TEMPB = RWCOMMAND(RWON); # TAKE OPTIONAL ON # 
                          # NOW LOOKING AT OBJECT OF DEBUGGING #
  
                          DEBUGOBJLIST = 2; #IN THE LIST# 
                          ILITISPNREF = TRUE; 
                          AWISPNREF = FALSE;
                        END 
                      END 
  
                    PNTBUILD; # FINISH BUILDING ENTRY # 
                    UNSTACKCTEXT(CTSP); 
                    MUSTSAVECTXT = FALSE; 
                    GOTO CASEEND; 
                  END 
  
                # NOT A SECTION DEF TO GET TO HERE #
  
                # MUST FILL IN PNT ETC #
                IF DELETESWITCH THEN
                  BEGIN 
                    # SINCE PNTBUILD IS NOT CALLED, THE ENTRY IS
                      EFFECTIVELY REMOVED # 
                    SKIPTOAAREA;
                    GETTOKEN; 
                    GOTO CASEEND; 
                  END 
                PNTBUILD; # FINISH OFF ENTRY #
                UNSTACKCTEXT(CTSP); 
                MUSTSAVECTXT = FALSE; CTSP = -1;
                GOTO CASEEND; 
  
          END 
  
        PDPNREF:  
          BEGIN # PROCEDURE NAME REFERENCE #
            SAVEDCTCOL = CLACOLUMN; 
            SAVEDCTLINE = CLALINE;
            IF DEBUGOBJLIST NQ 0 THEN 
              #ENSURE THAT AWRT CODE INDICATES PN-OR-DN REF#
              BEGIN 
  
                CODEAWRT = AWRTPNORDN;
              END 
            ELSE
              CODEAWRT = AWRTPNREF; 
            DOREFERENCES; # HANDLE QUALIFIERS- BUILD CTEXT #
            IF DEBUGOBJLIST GR 1
            THEN BEGIN
                 CRLITATOM(QUALIFFLAGS);
                 BUILDCTEXT(CTLITERAL,PLTNEXT-1,CLACOLUMN,0); 
                 CTOUTPUT;
                 END
            GOTO CASEEND; 
  
  
          END 
  
        PDREWD: 
          BEGIN # HAVE RESERVED WORD #
            IF PNREFKEY[CLAVALUE] THEN # SET CONTEXT FLAGS FOR
                                         PNREF[S  # 
              BEGIN 
                ILITISPNREF = PNREFILITKEY[CLAVALUE]; 
                AWISPNREF   = PNREFAWKEY[CLAVALUE]; 
                DEBUGOBJLIST = 0; #RESET FOR EVERY VERB#
  
                $BEGIN
                  IF INDEBUG THEN OUTPUT(4,"ILITISPN= ",
                    DEC(ILITISPNREF),"AWISPN = ",DEC(AWISPNREF)); 
                $END
  
              END 
           CONTROL IFNQ CB5$CDCS,"NO";
          IF CLAVALUE EQ RWOPEN OR CLAVALUE EQ RWSTART OR 
              CLAVALUE EQ RWCLOSE OR CLAVALUE EQ RWREAD 
          THEN RDFLAG = TRUE;          #CHECK FOR AREA OR RELATION# 
           CONTROL FI;
          IF PDPARSEKEY[CLAVALUE] NQ 0
          THEN                        # SPECIAL PARSE                  #
              BEGIN 
              IF CLAVALUE EQ RWIDENTIFICA 
              THEN   # WE MAY HAVE MULTIPLE COMPILES                   #
                  BEGIN 
                  IF CLACOLUMN GR BMARGIN 
                  THEN   # DIAGNOSE THIS ELEMENT MUST APPEAR IN A AREA #
                      BEGIN 
                      SSDIAGS(D025) ; 
                      END 
                  ELSE   # MULTIPLE COMPILES                           #
                      BEGIN 
                      CCT1STCOMPIL[0] = FALSE;
                      # INPUT FILE POSITIONED PROPERLY BY COBOLSS      #
                      GOTO PDEOD; 
                      END 
                  END 
              ELSE   # SPECIAL PARSE                                   #
                  BEGIN 
                  SPECIALPARSE(PDPARSEKEY[CLAVALUE]); 
                  GOTO CASEEND; 
                  END 
              END 
          ELSE   # NO SPECIAL PARSE                                    #
              BEGIN 
              PDCTEXTBUILD; 
              # CHECK IF THE -ALL PROCEDURES- PHRASE IS ENCOUNTERED    #
              # DURING THE SCANNING OF A USE FOR DEBUGGING STATEMENT   #
              # IF YES SET THE ALLPROCSFLAG TO TRUE.                   #
              IF CLAVALUE EQ RWPROCEDURES AND DEBUGOBJLIST GR 1 
              THEN
                  BEGIN 
                  ALLPROCSFLAG = TRUE;
                  END 
              END 
          CTOUTPUT; 
          GETTOKEN; 
          GOTO CASEEND; 
  
          END 
  
        PDEOD:  
          BEGIN # END OF FILE # 
          # CREATE A CTEXT-ATOM FOR A SECTION NAME AND ONE FOR   #
          # A PARAGRAPH NAME AT THE END OF THE EXISTING ATOMS.   #
          # THESE ARE GOING TO BE USED BY THE REPORT-WRITER.     #
          IF CCTSECTION[0]
          THEN BEGIN
               BUILDCTEXT(CTSNDEF,PNTNEXT,0,1); 
               CTOUTPUT;
               BUILDCTEXT(CTRESERVEDWD,RWSECTION,0,1);
               CTOUTPUT;
               BUILDCTEXT(CTPERIOD,0,0,1);
               CTOUTPUT;
               END
          IF CCTSECTION[0]
          THEN
              BEGIN 
               BUILDCTEXT(CTPNDEF,PNTNEXT+1,0,1); 
              END 
          ELSE
              BEGIN 
               BUILDCTEXT(CTPNDEF,PNTNEXT,0,1); 
              END 
          CTOUTPUT; 
               BUILDCTEXT(CTPERIOD,0,0,1);
          CTOUTPUT; 
                  IF CLATYPE EQ EODTYPE 
                  THEN
                  BEGIN 
    CCT1STCOMPIL = TRUE;
                  END 
              CCTPDCTXLEN = CTEXTNEXT - 1           ; 
            RETURN; 
  
          END 
        CASEEND:  
        END # OF ASLONGAS INPROCDIV # 
  
    END # OF DOPROCDIV #
CONTROL EJECT;
  
    # INITIALIZATION #
  
    $BEGIN IF INDEBUG THEN DISPLAY(2," INTERPRETTER CALLED.",0,21); 
    $END
    CSTATE = 1; 
    P<RAPLUSARRAY> = 0; 
    INITTBLPROCS; 
    DELETESWITCH = FALSE; 
   SSLINE = 0;     # LINE NO COUNTER #
    ALLOWLRGILIT = FALSE; 
    ILITISPNREF = FALSE;
    AWISPNREF   = FALSE;
    CTEXTNEXT = 1;
    PICCOUNT    = 0;
    MUSTSAVECTXT = FALSE; 
    DCLSWITCH = FALSE;
    DEBUGOBJLIST = 0; 
    QUALAWRT = 0; 
    CODEAWRT = 0; 
    IMMEAWRT = 0; 
    FDLINAGE = 0; 
    LASTFD   = 0; 
    FDLINAMBIG = FALSE; 
    INFD = FALSE; 
    INRD = FALSE; 
    FILLERSWITCH = FALSE; 
    INSPECIALNAM = FALSE; 
    DEFINITION = FALSE; 
    PROGRAMID = "NO-NAME";
    ENDDCLFLAG = 0; 
    CURRENTDIV = IDENTDIV;
          CTSTACKSZ = 10; 
          IF  GROUP1FLAG EQ 0 
          THEN  GROUP1FLAG = CMM$AGR(1);
          I = CMM$ALV(CTSTACKSZ, 1, 3, GROUP1FLAG, P<CTEXTSTACK>, 0); 
  
    # END OF INITIALIZATION # 
  
    DOIDENTDIV; # DO THE IDENTIFICATION DIVISION #
          IF CCTABORT 
          THEN
              GOTO INTERPRETEND;  #GARBAGE PROGRAM - NO ID DIV - ABORT# 
    DOENVIRDIV; # DO THE ENVIRONMENT DIVISION # 
    DODATADIV ; # DO THE DATA DIVISION #
    DOPROCDIV ; # DO THE PROCEDURE DIVISION # 
  
    # NOW DO THE INTERPRETTER WRAP-UP # 
  
   CONTROL IFNQ CB5$CDCS,"NO";
    IF USEDDL THEN
      DA$CLSB;               #CLOSE THE SUBSCHEMA#
   CONTROL FI;
    AWRTRESOLVE; # RESOLVE ALL REFERENCES IN THE AWRT. BUILD THE INT #
    PNATBUILD; # BUILD THE PNAT # 
    # IF ALLPROCSFLAG IS TRUE CALL PROCEDURE STOREALLPROCS TO  #
    # STORE THE PROCEDURE NAMES INTO THE PLT.                  #
    IF ALLPROCSFLAG 
    THEN BEGIN
         STORALLPROCS(I,J); 
         CCTPNINDEX = I;
         CCTPNCOUNT = J;
         END
  
    IF  B<59,1>CTEXTNEXT EQ 0  #WRITE LAST CTEXT ATOM#
    THEN
        BEGIN 
        REALCTEXT = VIRTUAL(TABLETYPE"CTEXT$",CTEXTNEXT/2); 
        CTEXTATOM1[REALCTEXT] = SAVCTATM[0];
        END 
      REPLDON;   # RELEASE ANY REPLACE CMMBLKS                         #
    # NOW ADD ANY CCT ENTRIES NEEDED #
  
    CCTLASTREPOR = LASTRD;
   CCTLASTLINE = SSLINE - 1;
    CCTCTEXTLEN = CTEXTNEXT - 1;
    CCTDNTLEN = DNTNEXT - 1;
    CCTDNATLEN=CCTDNTLEN+1; 
    CCTAWRTLEN = AWRTNEXT - 1;
    CCTPNTLEN  = PNTNEXT - 1; 
    CCTPNATLEN = CCTPNTLEN; 
    CCTINTLEN  = INTNEXT - 1; 
    CCTSPBTLEN = SPBTNEXT - 1;
    CCTPLTLEN  = PLTNEXT - 1; 
    CCTPLSTLEN = PLSTNEXT - 1;
    CCTPDLITLEN = CCTPLTLEN;
    CCTNAMETLEN = CCTNAMETLEN - 1;
 INTERPRETEND:  
  
  END # INTERPRETTER #
TERM
