*DECK DA
USETEXT CCTTEXT 
USETEXT DNTEXT
PROC DA;
BEGIN #D-ANALYZER#
# 
COBOL 5 DATA DIVISION ANALYZER FOR THE CYBER 170. 
  
AUTHOR: A. JOHNSON-LAIRD (CYBER 170)
        P. M. OLYNYK (PL50) 
  
LOCATION: CANADIAN DEVELOPMENT DIVISION 
          MEADOWVALE FACILITY 
          STREETSVILLE
          ONTARIO, CANADA 
  
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
  
COPYRIGHT CONTROL DATA CANADA, OCTOBER 1974 
  
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
  
# 
CONTROL EJECT;
          $BEGIN
          CONTROL PRESET; 
          $END
#CALL DACOMDK FOR GLOBAL DEFS AND DECLARATIOMS# 
*CALL DACOMDK 
#DECLARE ALL PART 1 PROCS AND FUNCS AS XDEFS FOR PART2# 
XDEF
*CALL DAPT1 
#DECLARE ALL PART 2, 3 AND 4 PROCS AS XREFS FOR PART1#
XREF
*CALL DAPT2 
XREF
*CALL DAPT3 
XREF
*CALL DAPT4 
          NEWPAGE;
PROC DEBUG$PROC;
BEGIN 
# 
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
  
MODULE FLAG VALUES
  
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
  
MODULES APPEAR IN THE D-ANALYZER IN THE ORDER STATED BELOW
AND ARE ASSIGNED THE SPECIFIED MODULE FLAG SUBSCRIPT FOR USE
WITH THE DEBUG PACKAGE
  
MODULE NAME [FLAG NUMBER] 
------------------------- 
  
ATT$NEW$AUXT[0]   ATTACH NEW AUXTABLE ENTRY 
BLD$LIN$T [1]     BUILDS LINAGE TEMP ENTRIES
CAL$SL$BYTES [2]  CALCULATES SLACK BYTES
SRCH$AUXT [3]     SEARCHES AUXTABLE FOR SPECIFIED ENTRY 
C$SRCH$AUXT [4]   CONTINUES SRCH$AUXT FOR NEXT ENTRY
BLANK$PROC [5]    BLANK WHEN ZERO PROCESSOR 
CHKKEYVAL [34]     CHECK KEY TYPE AND USAGE 
CHKUSINT [35]      CHECK UNSIGNED INTEGER ITEM
CLOSEDOWN [6]     D-ANALYZER CLOSEDOWN PROCESSOR
CLOSESRA [7]      CLOSEDOWN SUBROUTINE A
CLOSESRB [8]      CLOSEDOWN SUBROUTINE B
GET$NXT$DNAT [9]  GETS NEXT DNAT ENTRY TO BE PROCESSED
INITIAL [10]      D-ANALYZER INITIALISATION ROUTINE 
ITEM$PROC [11]    ITEM PROCESSOR (LVLS 1 TO 49 AND 77)
JUST$PROC [12]    JUSTIFIED PROCESSOR 
LEVEL1 [13]       LEVEL 1 PROCESSOR 
LEVEL2$49 [14]    LEVELS 2 THRU 49 PROCESSOR
LEVEL66 [15]      LEVEL 66 PROCESSOR
LEVEL77 [16]      LEVEL 77 PROCESSOR
LVL$CD [17]     LEVEL CD PROCESSOR
LVL$CDDN [18]   LEVEL CD DATA NAME PROCESSOR
LEVEL$FDSD [19]   LEVEL FD AND SD PROCESSOR 
LEVEL$INDX [20]   LEVEL INDEX PROCESSOR 
LVL$SELECT [21] LEVEL SELECTION PROCESSOR 
LVL$SECTN [33] LEVEL SECTION PROCESSOR ===[33]=== 
OCCUR$PROC [22]   OCCURS PROCESSOR
PIC$PROC [23]     PICTURE PROCESSOR 
REDEF$PROC [24]   REDEFINES PROCESSOR 
SIGN$PROC [25]    SIGN PROCESSOR
SUM$FILE [26]     SUMMATION OF FILE PROCESSOR 
SUM$GROUP [27]    SUMMATION OF GROUP ITEM PROCESSOR 
SUM$ITEM [28]     SUMMATION OF ITEM PROCESSOR 
SUM$RECORD [29]   SUMMATION OF RECORD PROCESSOR 
SYNC$PROC [30]    SYNCHRONIZED PROCESSOR
USAGE$PROC [31]   USAGE PROCESSOR 
VALUE$PROC [32]   VALUE PROCESSOR 
  
# 
NEWPAGE;
    ITEM OFFSETB; 
    ITEM VALUEB;
ITEM ZERO I=0;
##
MFLAG[0]=0; 
MFLAG[2]=0; 
MFLAG[3]=0; 
MFLAG[4]=0; 
#ALL INTERACTIVE DEBUGGING OPTIONS HAVE BEEN DELETED. 
THE DEBUG PACKAGE IS NOW ALL OR NOTHING DEPENDING ON THE
SETTING OF CCTCHKOUT. IF THIS FLAG IS NONZERO AND THE 
ZEROTH WORD OF THE COMMON PARAMETER BLOCK IS "DEBUG" THEN 
FLAG PHDEBUG WILL BE SET ON. PHDEBUG IS CHECKED FOR EACH
CALL TO ENTRY$, EXIT$, TRACK$ AND VALUE$. THESE IN TURN 
GENERATE THEIR OUTPUT ACCORDING TO THE SETTING OF THE 
APPROPRIATE MFLAG FOR THE MODULE IN WHICH THE CALL IS MADE. 
THE MFLAG ARRAY CANNOT BE SET INTERACTIVELY, BUT CAN ONLY BE
PRESET AT COMPILE TIME. 
THE FOLLOWING OPTIONS ARE PERMANENTLY DISABLED -
   *BREAKPOINT
   *OWNCODE 
   *ENTRY/EXIT DISPLAY
# 
IF CCTCHKOUT[0] NQ 0
  THEN #COMPILER IS IN DEBUG MODE#
   IF C<0,5>PARAMC[0] EQ "DEBUG"
   THEN #DANALYZER IN DEBUG MODE# 
   PHDEBUG=1; #ENABLE DEBUGGING (PRESET TO ZERO)# 
$BEGIN
IF PHDEBUG NQ 0 THEN DISPLAY(2,"DEBUG MODE ON",0,13); 
$END
END #DEBUG PROC#
NEWPAGE;
PROC E$PROC((FLAGNO),(NAME)); #ENTRY PROCESSOR# 
BEGIN #A# 
ITEM FLAGNO I;
ITEM E$TXT C(10) = "ENTRY TO  ";
ITEM NAME C(10);
$BEGIN
IF PHDEBUG EQ 0 THEN RETURN;
  IF DISPEEX NQ 0 
    THEN DISPLAY(2,E$TXT,0,20); 
    ELSE
    BEGIN #C# 
    IF MFLAG[FLAGNO] NQ 0 
      THEN
      BEGIN #B# 
      OUTPUT(1,"          "); 
      OUTPUT(2,"ENTRY TO  ",NAME);
      END #B# 
    END #C# 
$END
RETURN; 
END #A# 
##
PROC X$PROC((FLAGNO),(NAME)); #EXIT PROCESSOR#
BEGIN #A# 
ITEM FLAGNO I;
ITEM X$TXT C(10) = "EXIT FROM ";
ITEM NAME C(10);
$BEGIN
IF PHDEBUG EQ 0 THEN RETURN;
  IF DISPEEX NQ 0 
    THEN DISPLAY(2,X$TXT,0,20); 
    ELSE
    BEGIN #C# 
    IF MFLAG[FLAGNO] NQ 0 
      THEN
      BEGIN #B# 
      OUTPUT(2,"EXIT FROM ",NAME);
      OUTPUT(1,"          "); 
      END #B# 
    END #C# 
$END
RETURN; 
END #A# 
##
PROC T$PROC((FLAGNO),TPNO); #TRACK POINT PROCESSOR# 
BEGIN #A# 
ITEM FLAGNO I;
ITEM TPNO I; #TRACK POINT ID NUMBER#
$BEGIN
IF PHDEBUG EQ 0 THEN RETURN;
IF MFLAG[FLAGNO] EQ 1 OR MFLAG[FLAGNO] EQ 3 
  THEN
  OUTPUT(3,"          ","  TRACK   ",DEC(TPNO));
IF TPNO EQ TRIGGER
  THEN #TIME TO CALL OWN CODE PROCESSOR#
  OWN$CODE; 
IF TPNO EQ BREAKPOINT 
  THEN #CURRENTLY AT BREAKPOINT#
  BEGIN #B# 
  DISPLAY(2,"BREAKPOINT AT=",0,14); 
  DISPLAY(2,DEC(TPNO),0,10);
  END #B# 
$END
RETURN; 
END #A# 
##
PROC V$PROC((FLAGNO),TITLE,VAL); #VALUE PROCESSOR#
BEGIN #A# 
ITEM FLAGNO I;
ITEM TITLE C(10); #TITLE FOR VALUE LINE#
ITEM VAL I; #VALUE TO BE SHOWN# 
$BEGIN
IF PHDEBUG EQ 0 THEN RETURN;
IF MFLAG[FLAGNO] GR 1 
  THEN #VALUE IS TO BE SHOWN# 
  OUTPUT(4,"         ","         ",TITLE, 
        DEC(VAL));
$END
END #A# 
##
PROC OWN$CODE;
BEGIN 
#INSERT OWN CODE PROCEDURE HERE#
END 
##
##
NEWPAGE;
#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 
  
M A S T E R  C O N T R O L  R O U T I N E 
  
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$# 
#THIS IS THE MASTER CONTROL ROUTINE OF THE D ANALYZER.
ON ENTRY, CONTROL IS TRANSFERRED TO THE FIRST EXECUTABLE
STATEMENT BELOW#
CONTROL IFEQ DEBUG$SWITCH,1; #ONLY ENTER DEBUG SETUP IF FLAG ON#
DEBUG$PROC; #CALL DEBUG SETUP PROCESSOR#
CONTROL FI; 
INITIAL; #INITIALISATION PROCESSOR# 
DA$LOOP:  
  GET$NXT$DNAT; #GET NEXT ITEM TO BE PROCESSED IN DNAT# 
CONTROL IFEQ DEBUG$SWITCH,1;
IF PHDEBUG NQ 0 THEN
  DISPLAY(2,DEC(DNAT$PTR),0,10);
CONTROL FI; 
  #NOTE: CONTROL TRANSFERRED DIRECTLY TO CLOSEDOWN AT END#
  LVL$SELECT; #SWITCH AND PROCESS ACCORDING TO LEVEL# 
  GOTO DA$LOOP; 
END$DA: 
#CLOSEDOWN PROCESSOR TRANSFERS CONTROL HERE#
NEWPAGE;
FUNC ATT$NEW$AUXT(LDNAT$PTR) I; 
BEGIN #A# 
# 
ATTACH NEW AUX TABLE ENTRY. 
THIS FUNCTION UPDATES THE AUXTABLE LENGTH IN THE CCT, CREATES 
A NEW ENTRY IN THE AUXTABLE, SETS THIS NEW ENTRY IN THE AUXTABLE TO 
POINT TO ORIGINAL HEAD OF CHAIN AUX ENTRY AND THEN SETS THE 
SPECIFIED DNAT ENTRY TO POINT TO THE NEW ENTRY. 
  
THE ENTRY PARAMETER IS THE DNAT PTR TO THE ITEM ONTO WHICH THE
NEW ENTRY IS TO BE HUNG.
# 
ITEM LDNAT$PTR; 
##
ENTRY$(0,"ATTNEWAUXT"); 
CCTAUXTLEN=CCTAUXTLEN+1; #UPDATE AUX TABLE LENGTH#
                    VALUE$(0,"CCTAUXTLN=",CCTAUXTLEN);
TGET=GETQUICK(DN$AUXREF,DNAT$,LDNAT$PTR); #NEW AUX->OLD HEAD OF CHN#
SETFIELD(AX$TNEXTPTR,AUX$,CCTAUXTLEN,TGET); 
SETFIELD(DN$AUXREF,DNAT$,LDNAT$PTR,CCTAUXTLEN); #SET DNAT PTR TO NEW AX#
ATT$NEW$AUXT=CCTAUXTLEN;
EXIT$(0,"ATTNEWAUXT");
END #A# 
NEWPAGE;
FUNC CAL$SL$BYTES((LNAB));
BEGIN 
  #THIS FUNCTION COMPUTES THE NUMBER OF SLACK (SPARE) BYTES 
  (IN THE CYBER THIS IS A NUMBER OF 6 BIT CHARACTERS) THAT
  ARE NECESSARY TO PAD OUT A DATA ITEM TO THE NEXT WORD BOUNDARY. 
  FOR LEFT SYNC ITEMS THE SLACK BYTES VALUE IS ADDED TO 
  THE NEXT AVAILABLE BYTE PTR (NAB) AFTER THE DATA ITEM LENGTH
  AND BYTE OFFSET (RELATIVE TO THE MAJOR/MINOR MEMORY SECTION 
  IN WHICH THE ITEM OCCURS) HAVE BEEN STORED IN THE ITEM"S DNAT 
  ENTRY.   IN THIS WAY THE NEXT ITEM TO BE ALLOCATED STORAGE WILL BE
  FORCED TO START AT THE NEXT WORD BOUNDARY.
  FOR RIGHT SYNC ITEMS THE SLACK BYTES VALUE IS ADDED TO
  THE NEXT AVAILABLE BYTE BEFORE STORAGE ALLOCATION SO THAT 
  THE RIGHTMOST CHARACTER OF THE ITEM SITS IN THE RIGHTMOST 
  CHARACTER OF A WORD.
  # 
  # 
  DEBUG FLAG IS 2 
  # 
  #LOCAL VARIABLES# 
  ITEM LNAB;  #LOCAL COPY OF NEXT AVAIL BYTE PTR# 
  ITEM LFT$WD$BDY;#BYTE NUMBER OF NXT LEFTMOST WD BDY#
  ##
    ENTRY$(2,"CALSLBYTES"); 
    VALUE$(2,"LNAB=",LNAB); 
  LFT$WD$BDY=(LNAB/BYTES$PER$WD)*BYTES$PER$WD; #COMP LFT BDY# 
                          VALUE$(2,"LFT$WD$BD=",LFT$WD$BDY);
  IF LFT$WD$BDY NQ LNAB   #CHECK LNAB EXACT MULT OF BYTES/WD# 
    THEN    #NOT EXACT MULT SO CALC SLACK REQD# 
    CAL$SL$BYTES=BYTES$PER$WD-LNAB+LFT$WD$BDY; #RETURN FUNC VALUE#
    ELSE    #EXACT MULT#
    CAL$SL$BYTES=0;  #NO SLACK NECESSARY# 
                          VALUE$(2,"CAL$SL$BY=",CAL$SL$BYTES);
    EXIT$(2,"CALSLBYTES");
END 
NEWPAGE;
FUNC SRCH$FUNC(LAUX$PTR,LAUX$TYPE); 
    #COMMON SEARCH CODING FOR BOTH ENTRIES# 
BEGIN #A# 
ITEM LAUX$PTR; #AUX TABLE PTR FOR CHAIN#
ITEM LAUX$TYPE; #TYPE OF ENTRY SEARCHED FOR#
    FOR ZERO = 0 WHILE LAUX$PTR NQ 0 DO 
        BEGIN #B# 
                             TRACK$(2,202); 
        IF GETQUICK(AX$TTYPE,AUX$,LAUX$PTR) EQ LAUX$TYPE
            THEN
                 BEGIN #AB# 
                VALUE$(3,"LAUX$PTR=",LAUX$PTR); 
                VALUE$(3," LAUX$TYP=",LAUX$TYPE); 
                SRCH$FUNC=LAUX$PTR; 
                RETURN; 
                 END #AB# 
        LAUX$PTR=GETQUICK(AX$TNEXTPTR,AUX$,LAUX$PTR); 
        END #B# 
        SRCH$FUNC=0;
    END #A# 
FUNC SRCH$AUXT (LDNAT$PTR,(LAUX$TYPE)); 
    BEGIN #A# 
    #THIS FUNCTION PERFORMS A SEARCH ALONG AN AUXTABLE
    CHAIN LOOKING FOR AN ENTRY THAT HAS ITS TYPE
    EQUAL TO THE SPECIFIED TYPE.
    THIS IS THE INITIAL ENTRY TO THE SEARCH SO
    THE PTR FOR THE FIRST AUXT ENTRY IS TAKEN FROM
    THE SPECIFIED DNAT ENTRY. 
  
    THE ROUTINE RETURNS EITHER THE APPROPRIATE AUXT PTR 
    VALUE OR ZERO IF NO MATCH OCCURS. 
    # 
# 
DEBUG FLAG IS 3 
# 
    ITEM LDNAT$PTR;  #POINTER TO THE SPECIFIED DNAT ENTRY#
    ITEM LAUX$TYPE;  #SPECIFIED AUXT ENTRY TYPE#
    ENTRY$(3,"SRCH$AUXT");
                VALUE$(3,"LDNAT$PTR=",LDNAT$PTR); 
                 VALUE$(3,"LDNAT$PTR=",LDNAT$PTR);
                VALUE$(3," LAUX$TYP=",LAUX$TYPE); 
    #SET PTR FROM DNAT ENTRY# 
    SRCH$AUXT=SRCH$FUNC(GETQUICK(DN$AUXREF,DNAT$,LDNAT$PTR) 
                      ,LAUX$TYPE);
                EXIT$(3,"SRCH$AUXT"); 
    END #A# 
 FUNC C$SRCH$AUXT (LAUX$PTR,(LAUX$TYPE)); 
BEGIN #A# 
    #THIS IS THE CONTINUATION SEARCH ENTRY POINT. 
    IT DIFFERS ONLYIN THAT THE VALUE
    OF LAUX$PTR IS SET FROM THE SPECIFIED AUXT
    CHAIN ELEMENT OF THE SPECIFIED AUXT ENTRY.
    # 
    ITEM LAUX$PTR;  #POINTS TO LAST ENTRY CHECKED#
    ITEM LAUX$TYPE; #CONTAINS SPECIFIED ENTRY TYPE# 
    ENTRY$(4,"CSRCHAUXT");
                VALUE$(4,"LAUX$PTR=",LAUX$PTR); 
                VALUE$(4," LAUX$TYP=",LAUX$TYPE); 
    #SET PTR FROM SPECIFIED AUXT ENTRY# 
    C$SRCH$AUXT=SRCH$FUNC(GETQUICK(AX$TNEXTPTR,AUX$,LAUX$PTR) 
                        ,LAUX$TYPE);
    EXIT$(4,"CSRCHAUXT"); 
END #A# 
NEWPAGE;
PROC BLANK$PROC;
BEGIN #A# 
# 
BLANK WHEN ZERO PROCESSOR.
THIS PROCESSOR PERFORMS BASIC SYNTACTIC CHECKING RELATED TO 
THE BLANK WHEN ZERO CLAUSE. 
* 
ON ENTRY, IT IS ASSUMED THAT :  
  * DNAT$PTR POINTS TO THE CURRENT ITEM IN THE DNAT 
  * ELEMENTARY = 1 IF THE CURRENT ITEM IS ELEMENTARY (0 GRP)
# 
#LOCAL VARIABLE#
ITEM LAUX$PTR; #PTR TO EDIT INFO AUX ENTRY# 
##
ENTRY$(5,"BLANK$PROC"); 
IF GETQUICK(DN$BZERO,DNAT$,DNAT$PTR) EQ 1 
  THEN #BLANK WHEN ZERO CLAUSE PRESENT# 
  BEGIN #AB#
  IF ELEMENTARY EQ 0
    THEN #ITEM IS GROUP#
    ERROR(MSG23,D$ERROR); 
    #A BLANK WHEN ZERO CLAUSE IS ONLY ALLOWED FOR AN
    ELEMENTARY ITEM#
  IF GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) NQ NUMERIC
    AND 
    GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) NQ NUMERICEDIT 
    THEN #TYPE IS NEITHER NUMERIC OR EDITTED NUMERIC# 
    ERROR(MSG24,D$ERROR); 
    #THE BLANK WHEN ZERO CLAUSE IS ALLOWED ONLY WITH ITEMS
    WHOSE PICTURE STRING IS SPECIFIED AS NUMERIC OR 
    NUMERIC EDITTED, AND WHOSE USAGE IS DISPLAY#
    ELSE #ITEM IS EITHER NUMERIC OR NUMERIC EDITTED#
    BEGIN #B# 
                             TRACK$(5,502); 
    IF GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) EQ NUMERICEDIT
      THEN #ITEM IS NUMERIC EDITTED#
      BEGIN #C# 
                             TRACK$(5,503); 
      LAUX$PTR=SRCH$AUXT(DNAT$PTR,EDITINFO); #FIND EDIT INFO# 
                           VALUE$(5,"LAUX$PTR=",LAUX$PTR);
      SETFIELD(AX$TBWZ,AUX$,LAUX$PTR,1); #SET FLAG IN AUXENT# 
      SETFIELD(DN$BZERO,DNAT$,DNAT$PTR,0); #CLR FLAG IN DNAT# 
      END #C# 
      ELSE #ITEM IS NUMERIC#
      SETFIELD(DN$TYPE,DNAT$,DNAT$PTR,NUMERICEDIT); #CHANGE TYPE# 
    END #B# 
  IF GETQUICK(DN$USAGE,DNAT$,DNAT$PTR) EQ INDEXUSE
    THEN #ITEM IS USAGE INDEX#
    ERROR(MSG16,D$ERROR); 
    #A JUSTIFIED, PICTURE, VALUE OR BLANK WHEN ZERO CLAUSE
    IS NOT ALLOWED FOR AN ITEM WHOSE USAGE IS INDEX#
  END #AB#
EXIT$(5,"BLANK$PROC");
END #A# 
NEWPAGE;
PROC CHKKEYVAL((LDNAT$PTR));
BEGIN 
#THIS PROCEDURE CHECKS THE SPECIFIED ITEM AND ISSUES THE APPROPRIATE
ERROR MESSAGES IF THE KEY IS NOT OF THE CORRECT TYPE, OR IF THE 
KEY HAS AN "S" IN ITS PIC AND IS NOT USAGE COMP-1 (THIS LAST
CHECK IS BYPASSED IF THE FILE ORGANISATION IS ACTUAL KEY)#
ITEM LDNAT$PTR; #DNAT PTR TO THE ITEM TO BE CHECKED#
ITEM LDN$TYPE; #DNAT TYPE OF ITEM#
ENTRY$(34,"CHKEYVAL");
LDN$TYPE=GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR); #GET DNAT TYPE# 
IF LDN$TYPE EQ VARGROUP 
  THEN #ITEM IS VARIABLE GROUP# 
  BEGIN 
  ERROR$F(MSG103,D$ERROR);
  SETFIELD(FN$ABORT,FNAT$,FNAT$PTR,1); #ABORT THIS FNAT#
  END 
  #A RECORD KEY OR AN ALTERNATE KEY CAANOT BE A GROUP ITEM
  THAT CONTAINS A VARIABLE OCCURRENCE ITEM# 
IF LDN$TYPE NQ ALPHABET 
  AND 
  LDN$TYPE NQ ALPHNUM 
  AND 
  LDN$TYPE NQ GROUP 
  # TYPE EQUALS ZERO FOR GROUP ITEMS DEFINED OUTSIDE #
  # OF THE CURRENT FILE-S RECORD DESCRIPTIONS # 
  AND 
  LDN$TYPE NQ 0 
  THEN #KEY IS NOT ALPHA OR GROUP#
  IF LDN$TYPE NQ NUMERIC
    AND 
    LDN$TYPE NQ COMP1 
    AND 
    LDN$TYPE NQ COMP2 
    AND 
    LDN$TYPE NQ COMP4 
    THEN #KEY IS NOT ALPHA OR NUMERIC#
    BEGIN 
    ERROR$F(MSG105,D$ERROR);
    SETFIELD(FN$ABORT,FNAT$,FNAT$PTR,1); #ABORT THIS FNAT#
    END 
    #A RECORD KEY OR AN ALTERNATE KEY MUST BE ALPHABETIC
    ALPHANUMERIC OR NUMERIC#
    ELSE #KEY IS NUMERIC# 
     BEGIN
     #NUMERIC RECORD KEY OR NUMERIC ALTERNATE RECORD KEY IS NON-STAND#
     ERROR$F(MSG201,D$ERROR); 
    IF GETQUICK(FN$ORG,FNAT$,FNAT$PTR) NQ ACTUAL$KEY
      THEN #ORGANISATION IS INDEXED OR DIRECT#
      IF GETQUICK(DN$SIGNBIT,DNAT$,LDNAT$PTR) EQ 1
        AND 
        GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR) NQ BINARY 
        THEN #S IN PIC BUT USAGE NOT COMP-1#
        BEGIN 
        ERROR$F(MSG104,D$ERROR);
        SETFIELD(FN$ABORT,FNAT$,FNAT$PTR,1); #ABORT THIS FNAT#
        END 
        #IF A RECORD KEY OR AN ALTERNATE KEY IS AN ELEMENTARY 
        NUMERIC ITEM ITS PICTURE MUST NOT CONTAIN AN "S" UNLESS 
        ITS USAGE IS COMP-1#
     END
EXIT$(34,"CHKKEYVAL");
END 
NEWPAGE;
PROC CHKUSINT((LDNAT$PTR),(LMSGNN));
BEGIN 
#THIS PROCEDURE CHECKS THE ITEM POINTED TO BE THE LDNAT$PTR 
AND IF THE ITEM IS NOT AN UNSIGNED INTEGER ISSUES THE SPECIFIED 
ERROR MESSAGE#
ITEM LDNAT$PTR; #PTR TO THE ITEM TO BE CHECKED# 
ITEM LMSGNN; #ERROR MESSAGE NUMBER TO BE OUTPUT#
ITEM LDN$TYPE; #ITEMS TYPE# 
##
ENTRY$(35,"CHKUSINT");
LDN$TYPE=GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR); 
IF LDN$TYPE NQ NUMERIC
  AND 
  LDN$TYPE NQ COMP1 
  AND 
  LDN$TYPE NQ COMP4 
  THEN #KEY IS NOT NUMERIC# 
  BEGIN 
  ERROR(LMSGNN,D$ERROR);
  SETFIELD(FN$ABORT,FNAT$,FNAT$PTR,1); #ABORT THIS FNAT#
  END 
  ELSE #KEY IS NUMERIC BUT MAYBE NOT INTEGRAL#
  IF GETQUICK (DN$POINT,DNAT$,LDNAT$PTR) GR 0 
    OR
    GETQUICK(DN$PICSIGN,DNAT$,LDNAT$PTR) EQ 1 
    THEN #NON INTEGRAL# 
    BEGIN 
    ERROR(LMSGNN,D$ERROR);
    SETFIELD(FN$ABORT,FNAT$,FNAT$PTR,1); #ABORT THIS FNAT#
    END 
EXIT$(35,"CHKUSINT"); 
END 
NEWPAGE;
PROC CLOSEDOWN; 
BEGIN #A# 
# 
CLOSEDOWN PROCESSOR.
THIS PROCESSOR IS CALLED WHEN THE CURRENT ITEM HAS A LEVEL OF "RDSECTN".
* 
THE PROCESSOR PERFORMS THE FOLLOWING FUNCTIONS: 
  A. SETS THE WORKING STORAGE AND INDEX MEMORY SECTIONS IN THE CCT. 
  B. SCANS THE ENTIRE FNAT AND FOR EACH ENTRY:  
    1. GETS THE LINE NUMBER FROM THE DEFLINE TABLE
    2. PERFORMS SYNTACTIC CHECKING ON : 
      RELATIVE KEYS 
      FILE STATUS ITEMS 
      LABEL VALUES
      LINAGE IEMS 
      TOP LINE ITEMS
      BOTTOM LINE ITEMS 
      FOOTING ITEMS 
  
    NOTE : RELATIVE KEYS AND FILE STATUS ITEMS ARE CHECKED DIRECTLY 
      WHEREAS LABEL VALUES USE SUBROUTINE "CLOSESRB"
        REMAINING ITEMS ARE CHECKED USING "CLOSESRA"
  C. SUBROUTINE "CLOSESRA" IS ALSO USED TO CHECK THE DEPENDING NAME 
    ITEMS IN THE AUX CHAIN ATTACHED TO THE TALLY ITEM 
    THIS CHAIN IS DISCONNECTED FROM THE TALLY ITEM WHEN ALL ITEMS 
    HAVE BEEN CHECKED 
  
ON ENTRY IT IS ASSUMED THAT:  
  * SECTION CONTAINS THE CURRENT SECTION CODE 
  * CCTLASDNAT CONTAINS THE DNAT PTR OF THE LAST ENTRY IN THE DNAT
    THAT IS MEANINGFUL TO THE D-ANALYZER
# 
#LOCAL VARIABLES# 
ITEM LFNAT$PTR; #FNAT PTR USED TO SCAN FNAT#
ITEM LDNAT$PTR; #POINTER TO THE DNAT# 
ITEM LDNAT$LINAG; #DNAT PTR TO LINAGE ITEM# 
ITEM LDNAT$TOPL; #DNAT PTR TO TOP LINE ITEM#
ITEM LDNAT$BOTL; #DNAT PTR TO BOTTOM LINE ITEM# 
ITEM LDNAT$FOOT; #DNAT PTR TO FOOTING ITEM# 
ITEM SREGNAB; #CELL FOR SREG ALLOCATION CALCULATION#
ITEM LINLEN; #CELL TO HOLD LENGTH OF LINAGE CLAUSE DATA-NAME OR LIT#
ITEM BADIDFLAG; #FLAG TO INDICATE BAD LINAGE CLAUSE DATA-NAME#
ITEM LAUX$DEP; #AUX PTR TO ITEM IN DEPENDING CHAIN# 
ITEM LDNAT$DEP; #DNAT PTR TO DEPENDING ITEM#
ITEM FNLABLPTR; #TEMP STORAGE FOR CALL TO SRB#
ITEM FNLABLLIT; #TEMP STORAGE FOR CALL TO SRB#
ITEM LCEPLT1; #CURRENT ENTRY -PLT PTR NAME 1# 
ITEM LCEPLT2; #NAME 2#
ITEM LSEPLT1; #SCANNED ENTRY - PLT PTR NAME 1#
ITEM LSEPLT2; #NAME 2#
ITEM LCEIN1 C(10); #CURRENT ENTRY - NAME 1# 
ITEM LCEIN2 C(10); #NAME 2# 
ITEM LSEIN1 C(10); #SCANNED ENTRY - NAME 1# 
ITEM LSEIN2 C(10); #NAME 2# 
ITEM LFNAT$PTR2; #SCANNING FNAT$PTR#
##
#NAMECHECK DEFINITION IS USED TO CHECK CURRENT NAME AGAINST 
SCANNED NAME ONLY IF BOTH CURRENT AND SCANNED PLT PTR ARE NONZERO#
DEF NAMECHECK(A,B,C,D)
  #IF A NQ 0 AND B NQ 0 
   AND C EQ D 
    THEN BEGIN
    ERROR$F(MSG124,T$ERROR);
    TEST LFNAT$PTR; 
    END 
    CONTROL LIST#;
ENTRY$(6,"CLOSEDOWN");
IF SECTION EQ WSSECTN 
  THEN #CURRENTLY IN WORKING STORAGE SECTION# 
  BEGIN #B# 
                             TRACK$(6,602); 
  CCTMSECLEN[WSMSEC]=NAB; #SET CCT 01 MEM SECTION#
  END #B# 
  
IF NAB GR WORDLIMITX10
   THEN IF SECTION EQ CSSECTN THEN ERROR(MSG144,D$ERROR); 
   ELSE IF SECTION EQ WSSECTN THEN ERROR(MSG145,D$ERROR); 
   ELSE IF SECTION EQ SSSECTN THEN ERROR(MSG146,D$ERROR); 
  
CCTMSECLEN[INDEXMSEC]=NAB$INDEX; #SET CCT INDEX MEM SECTION#
FOR LFNAT$PTR=1 STEP 1 UNTIL CCTFNATLEN 
  DO #FOR ENTIRE FNAT#
  BEGIN #C# 
   TGET = GETQUICK(FN$SSRELATN,FNAT$,LFNAT$PTR);  #SS -RELATION- FLAG#
   IF TGET NQ 0              #IF SS -RELATION-, IGNORE FNAT#
     THEN TEST LFNAT$PTR; 
                           VALUE$(6,"LFNAT$PTR=",LFNAT$PTR);
                             TRACK$(6,603); 
      FNAT$LINE=GETQUICK(FN$LINE,FNAT$,LFNAT$PTR);
   TGET=GETQUICK(FN$DNATPTR,FNAT$,LFNAT$PTR); #GET LINE NBR#
  LINE$NO=GETQUICK(DN$LINE,DNAT$,TGET); 
                        VALUE$(6,"LINE$NO=",LINE$NO); 
    IF GETQUICK(DN$REPORTS,DNAT$,TGET) EQ 0 THEN
        BEGIN 
        TGET = GETQUICK(FN$ACCUMMAX,FNAT$,LFNAT$PTR); 
        IF TGET LS GETQUICK(FN$RCTMAX,FNAT$,LFNAT$PTR) THEN 
            BEGIN 
            ERROR(MSG147,D$ERROR);
            SETFIELD(FN$RCTMAX,FNAT$,LFNAT$PTR,TGET); 
            END 
        TGET = GETQUICK(FN$DNATPTR,FNAT$,LFNAT$PTR);
        END 
  IF GETQUICK(DN$REPORTS,DNAT$,TGET) EQ 0 
  AND GETQUICK(FN$RECCOUNT,FNAT$,LFNAT$PTR) EQ 0
  THEN
    BEGIN  # A NON-REPORT FD OR AN SD MUST HAVE A RECORD AFTER IT#
    ERROR(MSG118,D$ERROR);
    SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); 
    END 
  LDNAT$PTR=GETQUICK(FN$RELKPTR,FNAT$,LFNAT$PTR); #GET DNAT TO REL KEY# 
                           VALUE$(6,"LDNAT$PTR=",LDNAT$PTR);
  IF GETQUICK(FN$ORG,FNAT$,LFNAT$PTR) EQ RELATIVE 
    AND 
    LDNAT$PTR NQ 0
    THEN #CURRENT FILE ORGANISATION IS RELATIVE AND HAS REL KEYS# 
    BEGIN #D# 
                             TRACK$(6,604); 
    IF GETQUICK(DN$SDEPTH,DNAT$,LDNAT$PTR) NQ 0 
      THEN #REL KEY HAS OCCURS OR IS SUBORD TO OCCURS#
      BEGIN 
      ERROR$F(MSG96,D$ERROR); 
      SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
      END 
      #RELATIVE KEY IDENTIFIERS CAN NOT BE SUBSCRIPTED# 
    END #D# 
  LDNAT$PTR=GETQUICK(FN$STATPTR,FNAT$,LFNAT$PTR); 
                           VALUE$(6,"LDNAT$PTR=",LDNAT$PTR);
  #DNAT OF NAME IN FILE STAT CLAUSE#
  IF LDNAT$PTR NQ 0 
    THEN #THERE IS A FILE NAME DEFINED# 
    BEGIN #E# 
                             TRACK$(6,605); 
       LINE$NO = GETQUICK(DN$LINE,DNAT$,LDNAT$PTR); 
    IF LDNAT$PTR GR CCTDNATLEN
      THEN #FILE STAT DNAT ENTRY IS IN REPORT SECTION#
      BEGIN 
      ERROR(MSG80,D$ERROR); 
      SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
      END 
      #THE FILE STATUS NAME MAY NOT BE DEFINED IN THE REPORT SECTION# 
    IF GETQUICK(DN$MAJMSEC,DNAT$,LDNAT$PTR) EQ FDMSEC 
      THEN #FILE STATUS" DNAT ENTRY IS IN FD SECTION# 
      BEGIN 
      ERROR(MSG81,D$ERROR); 
      SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
      END 
      #THE FILE STATUS NAME MAY NOT BE DEFINED IN THE FILE SECTION# 
    IF GETQUICK(DN$ITMLEN,DNAT$,LDNAT$PTR) NQ 2 
      OR
      ( GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR) NQ ALPHNUM
    AND 
    GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) NQ ALPHABET
    AND 
    GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR) NQ GROUP  ) 
      THEN #FILE STATUS ITEM IS NOT 2 CHARS LONG OR ALPHANUMERIC# 
      BEGIN 
      ERROR(MSG82,D$ERROR); 
      SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
      END 
      #THE FILE STATUS ITEM MUST BE AN ALPHANUMERIC ITEM WITH A LENGTH
      OF 2# 
    IF GETQUICK(DN$SDEPTH,DNAT$,LDNAT$PTR) NQ 0 
      THEN
      BEGIN 
      ERROR(MSG98,D$ERROR); 
      SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
      END 
      #FILE STATUS IDENTIFIERS CAN NOT BE SUBSCRIPTED#
    END #E# 
  LDNAT$PTR=GETQUICK(FN$DNATPTR,FNAT$,LFNAT$PTR); #GET DNAT PTR#
                           VALUE$(6,"LDNAT$PTR=",LDNAT$PTR);
  IF GETQUICK(DN$LABVALU,DNAT$,LDNAT$PTR) EQ  1 
    THEN # "VALUE OF" CLAUSE PRESENT# 
    BEGIN #F# 
                             TRACK$(6,606); 
    #CHECK ALL 9 LABEL VALUE ITEM"S TYPE MAJ MSEC AND SUBSCRIPT DEPTH#
     FNLABLPTR=GETQUICK(FN$LABLPTR1,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT1,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK FILE-ID TO BE 1-17 CH A/N#
     CLOSESRB(FNLABLPTR,FNLABLLIT,1,17,ALPHNUM,MSG127); 
     FNLABLPTR=GETQUICK(FN$LABLPTR2,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT2,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK FILE-SET-ID TO BE 1-6 CH A/N# 
     CLOSESRB(FNLABLPTR,FNLABLLIT,1,6,ALPHNUM,MSG128);
     FNLABLPTR=GETQUICK(FN$LABLPTR3,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT3,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK FILE-SECTION-NUMBER TO BE 1 - 4 CH NUM# 
     CLOSESRB(FNLABLPTR,FNLABLLIT,1,4,NUMERIC,MSG129);
     FNLABLPTR=GETQUICK(FN$LABLPTR4,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT4,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK FILE-SEQUENCE-NUMBER TO BE 1-4 CH NUM#
     CLOSESRB(FNLABLPTR,FNLABLLIT,1,4,NUMERIC,MSG130);
     FNLABLPTR=GETQUICK(FN$LABLPTR5,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT5,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK GENERATION-NUMBER TO BE 1-4 CH,NUM# 
     CLOSESRB(FNLABLPTR,FNLABLLIT,1,4,NUMERIC,MSG131);
     FNLABLPTR=GETQUICK(FN$LABLPTR6,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT6,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK GENERATION-VERSION-NO TO BE 1-2 CH NUM# 
     CLOSESRB(FNLABLPTR,FNLABLLIT,1,2,NUMERIC,MSG132);
     FNLABLPTR=GETQUICK(FN$LABLPTR7,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT7,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK CREATION-DATE TO BE 5 NUM#
     CLOSESRB(FNLABLPTR,FNLABLLIT,5,5,NUMERIC,MSG133);
     FNLABLPTR=GETQUICK(FN$LABLPTR8,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT8,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK EXPIRATION-DATE TO BE 5  CH NUM#
     CLOSESRB(FNLABLPTR,FNLABLLIT,5,5,NUMERIC,MSG134);
     FNLABLPTR=GETQUICK(FN$LABLPTR9,FNAT$,LFNAT$PTR); #SET TEMPS# 
                         VALUE$(6,"FNLABLPTR=",FNLABLPTR);
     FNLABLLIT=GETQUICK(FN$LABLLIT9,FNAT$,LFNAT$PTR); 
                      VALUE$(6,"FNLABLLIT=",FNLABLLIT); 
     #CHECK ACCESSIBILITY TO BE 1 A/N#
     CLOSESRB(FNLABLPTR,FNLABLLIT,1,1,ALPHNUM,MSG135);
    END #F# 
IF GETQUICK(DN$LINAGE,DNAT$,LDNAT$PTR) EQ 1 THEN
BEGIN #FA#
  BADIDFLAG = 0;
  LDNAT$LINAG = GETQUICK(FN$LINAGPTR,FNAT$,LFNAT$PTR);
                           VALUE$(6,"LDNAT$LIN=",LDNAT$LINAG);
  IF LDNAT$LINAG NQ 0 
    AND 
    GETQUICK(FN$LINAGLIT,FNAT$,LFNAT$PTR) EQ 0
    THEN #LINAGE CLAUSE PRESENT AND NOT LITERAL#
    CLOSESRA(LDNAT$LINAG,MSG86); #CHECK TYPE PT LOC AND SIGN# 
  LDNAT$TOPL=GETQUICK(FN$TOPPTR,FNAT$,LFNAT$PTR); #PTR TO TOP LINE ITM# 
                           VALUE$(6,"LDNAT$TOP=",LDNAT$TOPL); 
  IF LDNAT$TOPL NQ 0
    AND 
    GETQUICK(FN$TOPLIT,FNAT$,LFNAT$PTR) EQ 0
    THEN #TOP LINE CLAUSE PRESENT AND NOT LITERAL#
    CLOSESRA(LDNAT$TOPL,MSG87); #CHECK TYPE, PT LOC AND SIGN# 
  LDNAT$BOTL=GETQUICK(FN$BOTTPTR,FNAT$,LFNAT$PTR); #PTR TO BOTTOM LINE# 
                          VALUE$(6,"LDNAT$BOT=",LDNAT$BOTL);
  IF LDNAT$BOTL NQ 0
    AND 
    GETQUICK(FN$BOTTLIT,FNAT$,LFNAT$PTR) EQ 0 
    THEN #BOTTOM LINE CLAUSE PRESENT AND NOT LITERAL# 
    CLOSESRA(LDNAT$BOTL,MSG88); #CHECK TYPE PT LOC AND SIGN#
  LDNAT$FOOT=GETQUICK(FN$FOOTPTR,FNAT$,LFNAT$PTR); #PTR TO FOOT ITEM# 
                          VALUE$(6,"LDNAT$FT=",LDNAT$FOOT); 
  IF LDNAT$FOOT NQ 0
    AND 
    GETQUICK(FN$FOOTLIT,FNAT$,LFNAT$PTR) EQ 0 
    THEN #FOOTING CLAUSE PRESENT AND NOT LITERAL# 
    CLOSESRA(LDNAT$FOOT,MSG89); #CHECK TYPE, PT LOC AND SIGN# 
  IF BADIDFLAG EQ 1 THEN
     SETFIELD(DN$TYPE,DNAT$,LDNAT$PTR+1,ERRTYPE); 
  IF GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR+1) NQ ERRTYPE 
  THEN BEGIN
       IF GETQUICK(FN$LINAGLIT,FNAT$,LFNAT$PTR) EQ 0
          THEN
          LINLEN = GETQUICK(DN$NUMLEN,DNAT$,LDNAT$LINAG); 
          ELSE
          LINLEN = GETQUICK(PL$LENGTH,PLT$,LDNAT$LINAG);
       SREGNAB = CCTMSECLEN[SREGMSEC];
       SREGNAB = ((SREGNAB + 9)/10)*10; 
       SREGNAB = SREGNAB + 10 - (LINLEN - ((LINLEN/10)*10));
       CCTMSECLEN[SREGMSEC] = SREGNAB + LINLEN; 
       SETFIELD(DN$LONGOFF,DNAT$,LDNAT$PTR+1,SREGNAB);
       SETFIELD(DN$MAJMSEC,DNAT$,LDNAT$PTR+1,SREGMSEC); 
       SETFIELD(DN$ITMLEN,DNAT$,LDNAT$PTR+1,LINLEN);
       SETFIELD(DN$NUMLEN,DNAT$,LDNAT$PTR+1,LINLEN);
       SETFIELD(DN$LEVEL,DNAT$,LDNAT$PTR+1,77); 
       SETFIELD(DN$TYPE,DNAT$,LDNAT$PTR+1,NUMERIC); 
       END
END #FA#
ELSE
  IF GETFIELD(DN$LEVEL,DNAT$,LDNAT$PTR) NQ SDDESCR THEN 
     SETFIELD(DN$TYPE,DNAT$,LDNAT$PTR+1,ERRTYPE); 
  LCEPLT1=GETQUICK(FN$DVCEPTR,FNAT$,LFNAT$PTR); #SET CURR ENTRY#
  LCEPLT2=GETQUICK(FN$2DPLTPTR,FNAT$,LFNAT$PTR);
  GETFILENAME(LCEPLT1,LCEIN1); #GET FILE NAMES# 
  GETFILENAME(LCEPLT2,LCEIN2);
                          VALUE$(6,"LCEPLT1=",LCEPLT1); 
                          VALUE$(6,"LCEPLT2=",LCEPLT2); 
     CHKFILENAME(LCEPLT1,LCEIN1); 
     CHKFILENAME(LCEPLT2,LCEIN2); 
  FOR LFNAT$PTR2 = 1 STEP 1 UNTIL CCTFNATLEN
    DO #SCAN OF COMPLETE FNAT#
    BEGIN #CA#
    IF LFNAT$PTR NQ LFNAT$PTR2
      THEN #CURRENT ENTRY IS NOT THE ONE BEING SCANNED# 
      BEGIN #CB#  #EXTRACT NAMES FROM SCANNED ENTRY#
      LSEPLT1=GETQUICK(FN$DVCEPTR,FNAT$,LFNAT$PTR2);
      LSEPLT2=GETQUICK(FN$2DPLTPTR,FNAT$,LFNAT$PTR2); 
      GETFILENAME(LSEPLT1,LSEIN1); #GET FILE NAMES# 
      GETFILENAME(LSEPLT2,LSEIN2);
                          VALUE$(6,"LSEPLT1=",LSEPLT1); 
                          VALUE$(6,"LSEPLT2=",LSEPLT2); 
      #CHECK IF NAMES SPECIFIED ARE THE SAME AND GIVE MSG124 IF SO# 
      #MSG124 - 
      ONE OR MORE OTHER FILES ARE ASSIGNED TO THIS SAME IMPLEMENTOR 
      NAME. AN ATTEMPT TO OPEN THIS FILE WILL FAIL IF ONE OF THE
      OTHERS IS ALREADY OPEN# 
      NAMECHECK(LCEPLT1,LSEPLT1,LCEIN1,LSEIN1); #CURR1 TO SCAN1#
      NAMECHECK(LCEPLT2,LSEPLT1,LCEIN2,LSEIN1); #CURR2 TO SCAN1#
      NAMECHECK(LCEPLT1,LSEPLT2,LCEIN1,LSEIN2); #CURR1 TO SCAN2#
      NAMECHECK(LCEPLT2,LSEPLT2,LCEIN2,LSEIN2); #CURR2 TO SCAN2#
      END #CB#
  END #CA#
  END #C# 
LAUX$DEP=GETQUICK(DN$AUXREF,DNAT$,1); #GET AUX PTR IN TALLY ITEM# 
                          VALUE$(6,"LAUX$DEP=",LAUX$DEP); 
#NOTE: TALLY ITEM HAS AUX ITEM CHAIN OF OCCURS DEPENDING ITEMS# 
FOR ZERO = 0 WHILE LAUX$DEP NQ 0
  DO #FOR ALL ITEMS IN THE CHAIN# 
  BEGIN #G# 
                             TRACK$(6,607); 
  TGET=GETQUICK(AX$OCCNAM,AUX$,LAUX$DEP); #GET LINE NBR#
  LINE$NO=GETQUICK(DN$LINE,DNAT$,TGET); 
                        VALUE$(6,"LINE$NO=",LINE$NO); 
  LDNAT$DEP=GETQUICK(AX$DEPNAM,AUX$,LAUX$DEP); #PTR TO DEPEND ITEM# 
                          VALUE$(6,"LDNAT$DEP=",LDNAT$DEP); 
  CLOSESRA(LDNAT$DEP,MSG56); #CHECK TYPE, PT LOC AND SIGN#
  LAUX$DEP=GETQUICK(AX$TNEXTPTR,AUX$,LAUX$DEP); #MV TO NEXT ITM#
                          VALUE$(6,"LAUX$DEP=",LAUX$DEP); 
  END #G# 
#DISCONNECT AUX CHAIN FROM TALLY ITEM#
SETFIELD(DN$AUXREF,DNAT$,1,0);
EXIT$(6,"CLOSEDOWN"); 
GOTO END$DA; #EXIT FROM D-ANALYZER PHASE# 
##
#CLOSEDOWN SUBROUTINE A 
THIS SUBROUTINE CHECKS THE TYPE, POINT LOCATION AND SIGN BIT
OF THE SPECIFIED DNAT ITEM. 
  
THE ENTRY PARAMETERS ARE THE DNAT$PTR TO THE ITEM TO BE CHECKED AND THE 
MESSAGE NUMBER TO BE USED IN CASE OF ERROR
# 
PROC CLOSESRA((LDNAT$PTR),(LMSGNN));
BEGIN #AA#
ITEM LDNAT$PTR; #POINTS TO DNAT ITEM BEING CHECKED# 
ITEM LMSGNN; #MESSAGE NUMBER# 
ITEM LDNAT$TYPE ; #DNAT TYPE# 
##
ENTRY$(7,"CLOSESRA"); 
LDNAT$TYPE=GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR); #GET ITEM TYPE# 
                      VALUE$(7,"LDNAT$TYP=",LDNAT$TYPE);
IF LDNAT$TYPE NQ NUMERIC
  AND 
  LDNAT$TYPE NQ BINARY
  AND 
  LDNAT$TYPE NQ COMP4 
  OR
  GETQUICK(DN$POINT,DNAT$,LDNAT$PTR) NQ 0 
  OR
  GETQUICK(DN$SIGNBIT,DNAT$,LDNAT$PTR) NQ 0 
  THEN BEGIN  #TYPE, POINT LOC, OR SIGN IS INCORRECT# 
       ERROR(LMSGNN,D$ERROR); 
       #ITEM MUST BE AN UNSIGNED INTEGER# 
       BADIDFLAG = 1; 
        IF LMSGNN NQ MSG56
          THEN #ITS OK TO CLOBBER THE FNAT - ROLF SAYS SO....#
          SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
       END
  
EXIT$(7,"CLOSESRA");
END #AA#
# 
  
# 
#CLOSEDOWN SUBROUTINE B.
THIS SUBROUTINE CHECKS THE OPERANDS OF THE "VALUE OF" CLAUSE. 
  
THE OPERAND MAY BE EITHER A DNAT ITEM (IF FN$LABLLITX EQ 0) OR A QUOTED 
LITERAL (IF FN$LABLLIT EQ 1). 
  
FOR THE DNAT ITEMS THE SUBROUTINE CHECKS THE FOLLOWING :- 
  * MAJOR MSEC (MUST BE WORKING STORAGE)
  * DNAT TYPE (MUST BY  A DISPLAY OR GROUP TYPE)
  * SUBSCRIPT DEPTH (MUST BE 0) 
  * ITEM LENGTH (MUST BE WITHIN RANGE SPECIFIED)
  
FOR THE PLT ITEMS THE LDNAT$PTR IS IN FACT A PLT PTR. FOR THESE ITEMS 
ONLY THE LENGTH AND TYPE OF ITEM ARE CHECKED. 
  
THE INPUT PARAMETERS ARE :- 
  * DNAT/PLT PTR
  * LITERAL FLAG (=1 FOR QUOTED LITERAL)
  * LOW AND HIGH LIMIT OF ITEM LENGTH 
  * ACCEPTABLE ITEM TYPE
  * ERROR MESSAGE NUMBER TO BE USED IF ERROR
  
NOTE: THE LFNAT$PTR DECLARED IN THE MAIN CLOSEDOWN ROUTINE IS USED. 
# 
PROC CLOSESRB((LDNAT$PTR),(LLIT),(LMINLEN),(LMAXLEN),(LTYPE),(LMSGNN)); 
BEGIN #AA#
ITEM LLIT; #LIT FLAG# 
ITEM LDNAT$PTR; #DNAT PTR TO LABEL ITEM#
ITEM LMINLEN;  #MINIMUM LENGTH# 
ITEM LMAXLEN;  #MAXIMUM LENGTH# 
ITEM LTYPE;  #REQUIRED DATA TYPE# 
ITEM LMSGNN;  #MESSAGE NUMBER IN CASE OF ERROR# 
ITEM LITYPE; #ACTUAL DATA TYPE FROM DNAT# 
##
ENTRY$(8,"CLOSERSRB");
IF LDNAT$PTR NQ 0 
  AND 
  LLIT EQ 0 
  THEN #LABEL VALUE DECLARED WITHOUT LITERAL# 
  BEGIN #AB#
                             TRACK$(8,828); 
  IF GETQUICK(DN$MAJMSEC,DNAT$,LDNAT$PTR) NQ WSMSEC 
    THEN #ITEM NOT IN WORKING STORAGE#
    BEGIN 
    ERROR(MSG83,D$ERROR); 
    SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
    END 
    #IDENTIFIERS USED IN A "VALUE OF" LABEL CLAUSE MUST BE
    DEFINED IN WORKING STORAGE SECTION# 
  IF GETQUICK(DN$SDEPTH,DNAT$,LDNAT$PTR) NQ 0 
    THEN #ITEM HAS OCCURS OR IS SUBORD TO OCCURS# 
    BEGIN 
    ERROR(MSG85,D$ERROR); 
    SETFIELD(FN$ABORT,FNAT$,LFNAT$PTR,1); #ABORT THIS FNAT# 
    END 
    #IDENTIFIERS USED IN A "VALUE OF" CLAUSE MAY NOT BE 
    SUBSCRIPTED OR INDEXED# 
    IF (GETQUICK(DN$ITMLEN,DNAT$,LDNAT$PTR) LS LMINLEN
       OR 
       GETQUICK(DN$ITMLEN,DNAT$,LDNAT$PTR) GR LMAXLEN 
       )
       THEN 
        BEGIN 
        ERROR(LMSGNN,D$ERROR);
        RETURN; 
        END 
       #OUTPUT MESSAGE DEFINING FIELD CONSTRAINTS#
    LITYPE=GETQUICK(DN$TYPE,DNAT$,LDNAT$PTR); 
    IF LTYPE EQ ALPHNUM AND 
       LITYPE NQ ALPHABET AND 
       LITYPE NQ ALPHEDIT AND 
      LITYPE NQ ALPHNUM AND 
       LITYPE NQ ALPHNUMED AND
       LITYPE NQ NUMEDIT AND
       LITYPE NQ NUMERIC AND
       LITYPE NQ GROUP
       THEN #ITEM IS NOT ALPHANUMERIC#
        BEGIN 
        ERROR(LMSGNN,D$ERROR);
        RETURN; 
        END 
    IF LTYPE EQ NUMERIC AND 
       LITYPE NQ NUMERIC
       THEN #ITEM IS NOT NUMERIC# 
        BEGIN 
        ERROR(LMSGNN,D$ERROR);
        RETURN; 
        END 
  END #AB#
IF LDNAT$PTR NQ 0 
  AND 
  LLIT NQ 0 
  THEN #VALUE IS DECLARED AS A LITERAL IN PLT#
  BEGIN #AC#
  IF GETQUICK(PL$LENGTH,PLT$,LDNAT$PTR) LS LMINLEN
    OR
     GETQUICK(PL$LENGTH,PLT$,LDNAT$PTR) GR LMAXLEN
    THEN #ITEM WRONG SIZE#
        BEGIN 
        ERROR(LMSGNN,D$ERROR);
        RETURN; 
        END 
  IF LTYPE EQ ALPHNUM AND 
    GETQUICK(PL$CODE,PLT$,LDNAT$PTR) NQ PLTQUOTEDLIT
    THEN #ITEM NOT ALPHANUMERIC#
        BEGIN 
        ERROR(LMSGNN,D$ERROR);
        RETURN; 
        END 
  IF LTYPE EQ NUMERIC AND 
   GETQUICK(PL$CODE,PLT$,LDNAT$PTR) NQ PLTINTLIT
    THEN #ITEM NOT NUMERICINTEGER#
        BEGIN 
        ERROR(LMSGNN,D$ERROR);
        RETURN; 
        END 
  END #AC#
EXIT$(8,"CLOSERSRB"); 
END #AA#
##
PROC CHKFILENAME(LPLTPTR,LSTRING);
BEGIN #CHKFILENAME# 
#THIS PROC CHECKS THE SPECIFIED STRING IN THE PLT FOR ALPHANUMERIC
CHARACTERS THE FIRST OF WHICH IS ALPHA# 
ITEM LPLTPTR;   #PLT PTR TO FILENAME# 
ITEM LSTRING C(10);  #ACTUAL FILENAME#
ITEM CHARCNT I=0;  #CHARACTER ACCESS POINTER# 
ITEM CHAR;   #SINGLE CHAR IS INTEGER# 
##
IF LPLTPTR NQ 0 
  THEN #NAME IS PRESENT SO CHECK IT#
  BEGIN 
  LINE$NO=GETQUICK(PL$LINE,PLT$,LPLTPTR); #SET READY FOR MESSAGES#
  FOR CHARCNT=0 STEP 1 UNTIL GETQUICK(PL$LENGTH,PLT$,LPLTPTR)-1 
    DO BEGIN
    CHAR=C<CHARCNT,1>LSTRING; 
    IF CHARCNT EQ 0 
      THEN #CHAR IS NOT ALPHA#
      BEGIN 
      IF CHAR LS O"01" OR 
         CHAR GR O"32"
        THEN #CHAR IS ALPHA#
        BEGIN 
        ERROR(MSG126,D$ERROR);
        #A FILENAME MUST BE ALPHANUM CHARS FIRST OF WHICH MUST BE ALPHA#
        RETURN; 
        END 
      END 
      ELSE #NOT FIRST CHARACTER TO CHECK ALPHANUMERIC#
      BEGIN 
      IF CHAR LS O"01" OR 
         CHAR GR O"44"
        THEN #NOT ALPHANUMERIC# 
        BEGIN 
        ERROR(MSG126,D$ERROR);
        RETURN; 
        END 
        #SEE ABOVE FOR MSG TEXT#
      END 
    END 
  END 
END #CHKFILENAME# 
##
PROC GETFILENAME(LOCPLTPTR,LOCSTRING);
BEGIN #GETFILENAME# 
#THIS PROC RETRIEVES THE FILENAME FROM THE PLT FIRST CHECKING TO BE SURE
 IT IS LESS THAN EIGHT CHARACTERS TRUNCATING IF NOT.# 
ITEM LOCPLTPTR;  #PLT PTR TO FILENAME#
ITEM LOCSTRING;  #ACTUAL FILENAME RETURNED# 
##
IF LOCPLTPTR NQ 0 
  THEN #FILE NAME IS PRESENT GO RETRIEVE IT#
  BEGIN 
  LINE$NO = GETQUICK(PL$LINE,PLT$,LOCPLTPTR); #SET TRADY FOR MESSAGES#
  IF GETQUICK(PL$LENGTH,PLT$,LOCPLTPTR) GR 7
    THEN # MORE THAN 7 CHARS IN NAME TRUNCATE#
    BEGIN 
    ERROR(MSG143,D$ERROR);
    #A FILENAME MUST BE 7 OR LESS CHARS#
    SETFIELD(PL$LENGTH,PLT$,LOCPLTPTR,7); #SET TO MAX#
    END 
  GETPLST(LOCPLTPTR,LOC(LOCSTRING)); #GET PLT STRING# 
  END 
RETURN; 
END #GETFILENAME# 
END #A# #CLOSEDOWN PROCESOR#
NEWPAGE;
PROC ERROR((MSGNN),(SEVERITY)); 
BEGIN #A# 
#THIS PROCEDURE IS USED TO DISPLAY IN LINE ERROR MSGS 
WHEN DEBUGGING - THE CALL TO INTERCEPTOR IS EXECUTED
REGARDLESS OF WHETHER DEBUG MODE HAS BEEN SELECTED# 
ITEM MSGNN I; #MESSAGE CODE -SEE XREF TO FIND CALLS#
ITEM SEVERITY I; #SEVERITY CODE FOR INTERCEPTOR#
S$TRACK; #TRACKING TYPE DEBUG MUST BE ON TO GENERATE# 
IF PHDEBUG NQ 0 
  THEN #DEBUG MODE IS ON# 
  BEGIN #B# 
  OUTPUT(5," ","****ERROR=",DEC(MSGNN),"LINE=",DEC(LINE$NO)); 
  END #B# 
CONTROL FI; #END OF CONDITIONAL GENERATION OF CODE# 
IF LINE$NO GQ 0 THEN  #NOT A SUB-SCHEMA ITEM# 
INTERCEPTOR(0,LINE$NO,MSGNN,SEVERITY);
ELSE
  INTERCEPTOR(253,LINE$NO,MSGNN,0);  #253 INDICATES SS SOURCE#
END #A# 
PROC ERROR$F((MSGNN),(SEVERITY)); 
#NOTE: THIS PROCEDURE IS IDENTICAL TO ERROR ABOVE, WITH THE 
EXCEPTION THAT THIS ONE USES THE LINE NUMBER OF THE SELECT/ASSIGN 
CLAUSE EXTRACTED FROM THE FNAT ENTRY IN THE LEVEL$FDSD PROC#
BEGIN #A# 
#THIS PROCEDURE IS USED TO DISPLAY IN LINE ERROR MSGS 
WHEN DEBUGGING - THE CALL TO INTERCEPTOR IS EXECUTED
REGARDLESS OF WHETHER DEBUG MODE HAS BEEN SELECTED# 
ITEM MSGNN I; #MESSAGE CODE -SEE XREF TO FIND CALLS#
ITEM SEVERITY I; #SEVERITY CODE FOR INTERCEPTOR#
S$TRACK; #TRACKING TYPE DEBUG MUST BE ON TO GENERATE# 
IF PHDEBUG NQ 0 
  THEN #DEBUG MODE IS ON# 
  BEGIN #B# 
  OUTPUT(5," ","****ERROR=",DEC(MSGNN),"LINE=",DEC(FNAT$LINE)); 
  END #B# 
CONTROL FI; #END OF CONDITIONAL GENERATION OF CODE# 
INTERCEPTOR(0,FNAT$LINE,MSGNN,SEVERITY);
END #A# 
NEWPAGE;
PROC GET$NXT$DNAT;
BEGIN #A# 
# 
GET NEXT DNAT ENTRY.
THIS PROCEDURE PERFORMS THE FOLLOWING FUNCTIONS:  
  A. UPDATES THE DNAT PTR BY 1 TO THE NEXT ITEM 
  B. CHECKS IF ALL THE DNAT ENTRIES HAVE BEEN PROCESSED,AND IF SO 
    CALLS THE CLOSEDOWN PROCESSOR 
  C. SETS THE LINE$NO FIELD FROM THE DEFLINE TABLE
    USING THE CURRENT VALUE OF DNAT$PTR 
  D. SETS CURR$ITM$LVL TO THE LEVEL NUMBER OF THE NEW DNAT ITEM 
  E. SETS UP THE NXT$ITM$LVL FIELD (WHICH CONTAINS THE LEVEL NO 
    OF THE NEXT NON INDEX, 77 OR 88 ITEM..OR ZERO IF THE
    NOW CURRENT ITEM IS EFFECTIVELY THE LAST IN THE DNAT
  F. SETS THE FIELD "ELEMENTARY" TO 1 IF THE CURRENT ITEM 
    IS ELEMENTARY OR TO ZERO IF IT IS A GROUP ITEM
* 
ON ENTRY IT IS ASSUMED THAT:  
  * DNAT$PTR POINTS TO THE CURRENT ITEM IN THE  DNAT
    (WHICH HAS JUST BEEN PROCESSED) 
  * LAST$ITEM CONTAINS PTR TO LAST ENTRY INPUT TO DA
# 
#LOCAL VARIABLES# 
ITEM LDNAT$PTR; #USED TO SCAN FOR NXT NON INDX,77,88 ITM# 
ENTRY$(10,"GETNXTDNAT");
IF DNAT$PTR EQ LAST$ITEM
  THEN #ALL ITEMS IN DNAT HAVE BEEN PROCESSED#
  CLOSEDOWN; #CALL CLOSEDOWN PROCESSOR# 
  ELSE #MORE ITEMS IN DNAT TO BE PROCESSED# 
  BEGIN #B# 
                             TRACK$(9,902); 
  DNAT$PTR=DNAT$PTR+1; #MOVE TO NXT ITM IN DNAT#
                         VALUE$(9,"DNAT$PTR=",DNAT$PTR);
 #GET LINE NUMBER FOR CURRENT ITEM# 
  LINE$NO=GETQUICK(DN$LINE,DNAT$,DNAT$PTR); 
                        VALUE$(9,"LINE$NO=",LINE$NO); 
  CURR$ITM$LVL=GETQUICK(DN$LEVEL,DNAT$,DNAT$PTR); #SET CURR ITM LVL#
                          VALUE$(9,"CITMLVL=",CURR$ITM$LVL);
  IF DNAT$PTR EQ LAST$ITEM
    THEN #CURR ITEM IS LAST IN DNAT#
    BEGIN #BA#
    NXT$ITM$LVL=0; #NXT LEVEL SET TO ZERO#
                          VALUE$(9,"NITMLVL=",NXT$ITM$LVL); 
    END #BA#
    ELSE #CURR ITEM IS NOT LAST#
    BEGIN #C# 
                             TRACK$(9,903); 
    #SET NXT$ITM$LVL TO LEVEL ON NEXT NON INDX,77,88 ITEM#
    NXT$ITM$LVL=77; #ENSURE ENTRY TO DO LOOP# 
    FOR LDNAT$PTR=DNAT$PTR+1 STEP 1 WHILE 
      NXT$ITM$LVL EQ INDXLEVL 
      OR
      NXT$ITM$LVL EQ 77 
      OR
      NXT$ITM$LVL EQ 88 
      DO
      BEGIN #D# 
                             TRACK$(9,904); 
                           VALUE$(9,"LDNAT$PTR=",LDNAT$PTR);
      NXT$ITM$LVL=GETQUICK(DN$LEVEL,DNAT$,LDNAT$PTR); 
                          VALUE$(9,"NITMLVL=",NXT$ITM$LVL); 
      IF LDNAT$PTR EQ LAST$ITEM 
        THEN #END OF DNAT REACHED#
        BEGIN #DA#
        NXT$ITM$LVL=0; #ALSO FORCES EXIT FROM DO LOOP#
                          VALUE$(9,"NITMLVL=",NXT$ITM$LVL); 
        END #DA#
      END #D# 
    END #C# 
  IF NXT$ITM$LVL LQ CURR$ITM$LVL
    OR
    NXT$ITM$LVL EQ 0
    OR
    NXT$ITM$LVL EQ 1
    OR
    NXT$ITM$LVL GR 49 
    THEN #CURRENT ITEM IS ELEMENTARY# 
    ELEMENTARY=1; #SET FLAG#
    ELSE #CURRENT ITEM IS A GROUP#
    ELEMENTARY=0; #CLEAR FLAG#
                         VALUE$(9,"ELEMENTY=",ELEMENTARY);
  END #B# 
EXIT$(10,"GETNXTDNAT"); 
END #A# 
NEWPAGE;
PROC INITIAL; 
BEGIN #A# 
# 
INITIALIZATION. 
AS ALL FLAGS AND PTRS ARE SETUP AS PRESETS THE MAIN 
PURPOSES OF THIS PROCESSOR ARE :  
  A. TO PROVIDE INITIAL DUMPS OF THE DNAT AND AUXTABLE
    IF REQUIRED 
  B. TO CREATE THE DNAT ENTRY FOR THE TALLY COUNTER IN
    DNAT[1] 
* 
ON ENTRY IT IS ASSUMED THAT:  
  * DNAT$PTR IS SET TO 1
# 
ENTRY$(10,"INITIAL"); 
DNAT$PTR=14; #SET TO ELEM BEFORE FIRST TO BE PROCESSED# 
##
IF CCTDNATLEN LQ 14 
THEN #EMPTY DATA DIVISION#
GOTO END$DA; #IMMEDIATE EXIT FROM DANALYZER#
ELSE #DATA DIVISION TO BE PROCESSED#
LAST$ITEM=CCTDNATLEN; #SAVE DNAT LENGTH AS I/P TO D-A#
                          VALUE$(10,"LASTITEM=",LAST$ITEM); 
MAJ$MEM$SEC = WSMSEC; 
EXIT$(10,"INITIAL");
END #A# 
NEWPAGE;
PROC ITEM$PROC; 
BEGIN #A# 
# 
ITEM PROCESSOR
* 
THIS PROCESSOR IS CALLED FOR EACH LEVEL 1 THRU 49 AND 77 ITEM 
ENCOUNTERED.
* 
THE PROCESSOR ITSELF IS JUST A CONTROL ROUTINE THAT IN TURN 
CALLS THE FOLLOWING PROCEDURES: 
  * USAGE PROCESSOR 
  * BLANK (WHEN ZERO) PROCESSOR 
  * SIGN PROCESSOR
  * OCCUR PROCESSOR 
  * SYNC PROCESSOR
  * PIC PROCESSOR 
  * JUSTIFIED PROCESSOR 
  * VALUE PROCESSOR 
  * REDEFINES PROCESSOR 
* 
THE "RAISON D"ETRE" FOR THE ITEM PROCESSOR IS JUST TO ALLOW 
FLEXIBILITY IN TERMS OF WHICH ROUNTIES ARE CALLED AND IN WHAT 
SEQUENCE# 
  USAGE$PROC; 
  BLANK$PROC; 
  SIGN$PROC;
  OCCUR$PROC; 
  SYNC$PROC;
  PIC$PROC; 
  JUST$PROC;
  VALUE$PROC; 
  REDEF$PROC; 
END #A# 
NEWPAGE;
PROC JUST$PROC; 
BEGIN #A# 
# 
JUSTIFIED PROCESSOR.
THIS PROCESSOR PERFORMS BASIC SYNTACTIC CHECKING ON THE VALIDITY
OF THE JUSTFIED CLAUSE. 
* 
ON ENTRY, IT IS ASSUMED THAT :  
  * DNAT$PTR POINTS TO THE CURRENT ITEM IN THE DNAT 
  * ELEMENTARY = 1 IF THE CURRENT ITEM IS ELEMENTARY (0= GROUP) 
  * VALUE$FLAG =1 IF A SUPERIOR GRP ITEM HAS A VALUE CLAUSE 
# 
ENTRY$(12,"JUST$PROC"); 
IF GETQUICK(DN$JUST,DNAT$,DNAT$PTR) EQ 1
  THEN #JUSTIFIED CLAUSE PRESENT# 
  BEGIN #B# 
                             TRACK$(12,1202); 
  IF ELEMENTARY EQ 0
    THEN #ITEM IS GROUP#
    ERROR(MSG45,D$ERROR); 
    #THE JUSTIFIED CLAUSE MAY ONLY BE USED WITH 
    ELEMENTARY ITEMS# 
  ELSE #ITEM IS ELEMENTARY# 
  BEGIN #D# 
  IF GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) NQ ALPHABET 
    AND 
    GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) NQ ALPHNUM 
    AND  GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) NQ BOOLDSP
    AND  GETQUICK(DN$TYPE,DNAT$,DNAT$PTR) NQ BOOLBIT
    THEN
    BEGIN #C# 
                             TRACK$(12,1203); 
    ERROR(MSG21,D$ERROR); 
    #A JUSTIFIED CLAUSE IS NOT ALLOWED WITH A DATA ITEM 
    WHICH IS NUMERIC OR FOR WHICH EDITTING IS SPECIFIED#
    SETFIELD(DN$JUST,DNAT$,DNAT$PTR,0); #TURN OFF JUSTIFIED#
    END #C# 
    IF VALUE$FLAG EQ 1
      THEN #SUPERIOR GROUP HAS VALUE# 
      ERROR(MSG8,T$ERROR);
      #A VALUE CLAUSE MAY NOT BE USED FOR A GROUP ITEM
      WHOSE SUBORDINATE ITEMS CONTAIN A JUSTIFIED 
      SYNCHRONIZED OR USAGE (OTHER THAN DISPLAY) CLAUSE#
    IF GETQUICK(DN$USAGE,DNAT$,DNAT$PTR) EQ INDEXUSE
      THEN #USAGE IS INDEX# 
      ERROR(MSG16,D$ERROR); 
      #A JUSTIFIED, PICTURE, VALUE, OR BLANK WHEN ZERO
      IS NOT ALLOWED WITH A DATA ITEM WHOSE USAGE IS INDEX# 
  END #D# 
  END #B# 
EXIT$(12,"JUST$PROC");
END #A# 
NEWPAGE;
PROC LEVEL1;
BEGIN #A# 
# 
LEVEL 1 PROCESSOR#
#THIS PROCESSOR IS CALLED WHEN THE CURRENT ITEM HAS A LEVEL OF 1. 
* 
THE PROCESSOR PERFORMS THE FOLLOWING FUNCTIONS: 
  A. IF THE CURRENT ITEM IS THE FIRST OF THE FIRST RECORD 
    IN THE CURRENT FILE, THEN THE REDEFINITION PTRS ARE 
    RESET. THE CURRENT ITEMS BYTE OFFSET AND DNAT$PTR ARE 
    STORED AS THE FIRST ENTRY IN THESE STACKS.
    A NEW AUX TABLE ENTRY CONTAINING PTRS TO THE FNAT ENTRY 
    FOR THE FILE, AND DNAT PTR TO THE FD DECLARATION IS 
    HUNG ONTO THE CURRENT DNAT ENTRY. 
  B. THE ITEM PROCESSOR IS CALLED.
C. IF THE ITEM IS IN COMMON, SUBSCHEMA OR WORKING STORAGE, ANY NECESSARY
    SLACK BYTES ARE ADDED 
    TO THE NEXT AVAIABLE BYTE COUNTER.
  D. IF THE ITEM IS IN THE FD SECTION, THE NEXT AVAILABLE 
    BYTE COUNTER IS RESET, THE ITEM"S BYTE OFFSET SET TO THE
    RESET VALUE AND THE ITEM"S MINOR MEMORY SECTION FIELD SET.
  E. IF THE ITEM IS IN THE COMMUNICATION OR LINKAGE SECTION 
    THEN THE NEXT AVAILABLE BYTE COUNTER AND THE BYTE OFFSET
    ARE SET TO APPROPRIATE VALUES.
  F. IF THE CURRENT ITEM IS ELEMENTARY THEN THE SUM ITEM AND
    SUM RECORD PROCESSORS ARE CALLED.. AND IF THE ITEM IS IN THE
    FD SECTION (AND NO LVL 66 ITEMS FOLLOW) THE SUM FILE
    PROCESSOR IS CALLED.
    IF THE ITEM IS A GROUP, THE GROUP STACK PTR IS RESET AND
    THE CURRENT ITEM"S DNAT PTR STORED AS THE FIRST ENTRY.
* 
ON ENTRY IT IS ASSUMED THAT:  
  * DNAT$PTR POINTS TO THE CURRENT ITEM IN THE DNAT 
  * FIRST$R$PTR POINTS TO THE FIRST 01 ITEM FOR THE 
    CURRENT FILE
  * MAJ$MEM$SEC CONTAINS THE CURRENT MAJOR MEMORY SECTION CODE
  * NAB CONTAINS THE NEXT AVAILABLE BYTE FOR ALLOCATING 
    TO THE CURRENT ITEM 
  * SECTION CONTAINS THE CURRENT SECTION CODE 
  * BYTES$PER$WD IS 10 FOR THE CYBER
  * MIN$MEM$SEC CONTAINS THE CURRENT MINOR MEMORY SECTION CODE
  * CD$OFFSET CONTAINS THE VALUE TO WHICH NAB IS RESET
    FOR THE CD SECTION
  * ELEMENTARY =1 IF THE CURRENT ITEM IS ELEMENTARY (0= GROUP)
  * NXT$ITM$LVL CONTAINS THE LEVEL NUMBER OF THE NEXT ITEM IN THE DNAT
    (=0 IF THE CURRENT ITEM IS THE LAST IN THE DNAT)
# 
#LOCAL VARIABLES# 
ITEM LAUX$PTR; #AUXTABLE PTR TO NEW ENTRY OF TYPE "FILENAME" #
ITEM LSLACK$BYTES; #SLACK BYTES (IF ANY) ADDED TO NAB TO
      FORCE NAB TO NEXT HIGHEST WORD BOUNDARY#
##
ENTRY$(13,"LEVEL1");
CD01COUNT = CD01COUNT + 1;
SUB$DEPTH=0; #RESET SUBSCRIPT DEPTH#
                        VALUE$(13,"SUBDEPTH=",SUB$DEPTH); 
IF SECTION EQ FDSECTN 
  THEN #CURRENTLY IN FD SECTION#
  BEGIN #B# 
                             TRACK$(13,1302); 
  IF GETQUICK(DN$REPORTS,DNAT$,FD$PTR) NQ 0 
    THEN #FD FOR THIS FILE HAS REPORTS CLAUSE#
    ERROR(MSG120,T$ERROR);
    #NO RECORD DESCRIPTION ENTRIES ARE SUPPOSED TO FOLLOW 
    AN FD CONTAINING A REPORTS CLAUSE#
  IF DNAT$PTR NQ FIRST$R$PTR
    THEN #CURR ITM IS NOT FIRST OF FIRST RECD IN FD#
    BEGIN #C# #CURRENT RECD IS REGARDED AS REDEFINITION#
                             TRACK$(13,1303); 
    RDEF$ST$PTR=0;  #RESET POINTER# 
                         VALUE$(13,"RDEFSTPTR=",RDEF$ST$PTR); 
    RDEF$DNAT$ST[RDEF$ST$PTR]=DNAT$PTR; #SAVE DNAT OF CURRENT ITEM# 
    RDEF$NAB$ST[RDEF$ST$PTR]=NAB;  #SAVE NAB OF CURRENT ITEM# 
                    VALUE$(13,"RDEFDNAT=",RDEF$DNAT$ST[0]); 
                    VALUE$(13,"RDEFNAB=",RDEF$NAB$ST[0]); 
    END #C# 
  LAUX$PTR=ATT$NEW$AUXT(DNAT$PTR); #HANG NEW AUXENT ON THIS ITM#
                           VALUE$(13,"LAUX$PTR=",LAUX$PTR); 
  #SET DNAT TO POINT TO NEW AUX ENTRY#
  SETFIELD(DN$AUXREF,DNAT$,DNAT$PTR,LAUX$PTR);
  SETFIELD(AX$TTYPE,AUX$,LAUX$PTR,FILENAME); #TYPE TO FILENAME# 
  SETFIELD(AX$FNATPTR,AUX$,LAUX$PTR,FNAT$PTR); #PTR TO FNAT ENT#
  SETFIELD(AX$FDPTR,AUX$,LAUX$PTR,FD$PTR); #PTR TO FD ENTRY#
  END #B# 
ITEM$PROC; #CALL ITEM PROCESSOR#
  
SETFIELD(DN$MAJMSEC,DNAT$,DNAT$PTR,MAJ$MEM$SEC);#SET MAJOR MEM SEC# 
IF SECTION EQ WSSECTN 
  OR
  SECTION EQ SSSECTN
  OR
  SECTION EQ CSSECTN
  THEN  # CURRENTLY IN COMMON, SUBSCHEMA OR WORKING STORAGE SECTION # 
  BEGIN #D# 
                             TRACK$(13,1304); 
  LSLACK$BYTES=CAL$SL$BYTES(NAB); #COMP SLK BYTES TO GET TO NXT WD BDY# 
                      VALUE$(13,"LSLACKBYT=",LSLACK$BYTES); 
  NAB=NAB+LSLACK$BYTES; #UPDATE NAB TO NEXT WD BOUNDARY#
                       VALUE$(13,"NAB=",NAB); 
  END #D# 
IF SECTION EQ FDSECTN 
  THEN #CURRENTLY IN FD SECTION#
  BEGIN #E# 
                             TRACK$(13,1305); 
  NAB=0; #RESET TO ZERO FOR THIS SUB MSEC#
                       VALUE$(13,"NAB=",NAB); 
  SETFIELD(DN$BYTEOFFS,DNAT$,DNAT$PTR,NAB); #SET BYTE OFFSET# 
  SETFIELD(DN$SUBMSEC,DNAT$,DNAT$PTR,MIN$MEM$SEC); #SET MINOR MEM SEC#
  END #E# 
  ELSE #NOT IN FD SECTION#
  BEGIN #F# 
                             TRACK$(13,1306); 
  IF SECTION EQ WSSECTN 
    THEN
    BEGIN 
    IF GETQUICK(DN$EXTERNAL,DNAT$,DNAT$PTR) EQ 1
      AND 
       GETQUICK(DN$RDEF,DNAT$,DNAT$PTR) EQ 0
      THEN
      BEGIN 
       IF SAVE$NAB LS 0 
        THEN
        BEGIN 
        SAVE$NAB = NAB; 
        NAB = 0;
        END 
        ELSE
        NAB = 0;
      END 
      ELSE
      BEGIN 
      IF GETQUICK(DN$RDEF,DNAT$,DNAT$PTR) EQ 1
        AND 
         GETQUICK(DN$EXTERNAL,DNAT$,DNAT$PTR) EQ 1
        THEN
        BEGIN 
        NAB = 0;
        END 
        ELSE
        BEGIN 
        IF SAVE$NAB GQ 0
          THEN
          BEGIN 
          NAB = SAVE$NAB; 
          SAVE$NAB = -1;
          END 
        END 
      END 
    END 
  IF SECTION EQ CDSECTN 
    THEN #CURRENTLY IN COMMUNICATION SECTION# 
    BEGIN #FA#
                             TRACK$(13,1355); 
    NAB=CD$OFFSET; #RESET NEXT AVAILABLE BYTE#
                       VALUE$(13,"NAB=",NAB); 
    END #FA#
  IF SECTION EQ LKSECTN 
    THEN #CURRENTLY IN LINKAGE SECTION# 
    BEGIN #FB#
                             TRACK$(13,1356); 
    NAB=0; #RESET NEXT AVAILABLE BYTE#
                       VALUE$(13,"NAB=",NAB); 
    END #FB#
  SETFIELD(DN$LONGOFF,DNAT$,DNAT$PTR,NAB);  #SET BYTE OFFSET IN ITEM# 
  END #F# 
IF SECTION EQ WSSECTN 
  THEN
  BEGIN 
  IF GETQUICK(DN$EXTERNAL,DNAT$,DNAT$PTR) EQ 1
    AND 
     GETQUICK(DN$FILLREF,DNAT$,DNAT$PTR) EQ 1 
    THEN
    BEGIN 
    ERROR(MSG14,D$ERROR); 
    #THE EXTERNAL CLAUSE MUST NOT BE SPECIFIED
    FOR FILLER ITEMS.#
    END 
  END 
IF ELEMENTARY EQ 1
  THEN #ITEM IS ELEMENTARY# 
  BEGIN #G# 
                             TRACK$(13,1307); 
  SUM$ITEM; #CALL SUM ITEM PROCESSOR# 
  SUM$RECORD; #CALL SUM RECORD PROCESSOR# 
  IF SECTION EQ FDSECTN 
    THEN #CURRENTLY IN FD SECTION#
    BEGIN #H# 
                             TRACK$(13,1308); 
    IF NXT$ITM$LVL GR 49
      AND 
      NXT$ITM$LVL NQ 66 
      OR
      NXT$ITM$LVL EQ 0
      THEN #NEXT ITEM"S LVL GREATER THAN 49 BUT NOT 66
        OR CURRENT ITEM IS LAST IN DNAT#
      SUM$FILE; #CALL SUM FILE PROCESSOR# 
    END #H# 
  END #G# 
  ELSE #ITEM IS GROUP#
  BEGIN #I# 
                             TRACK$(13,1309); 
  GRP$ST$PTR=1; #RESET STACK POINTER# 
  GRP$ST[GRP$ST$PTR]=DNAT$PTR; #STORE CURRENT ITM"S DNAT IN STACK#
                 VALUE$(13,"GRPSTPTR=",GRP$ST$PTR); 
                 VALUE$(13,"GRPST=",GRP$ST[GRP$ST$PTR]);
  END #I# 
EXIT$(13,"LEVEL1"); 
END #A# 
NEWPAGE;
PROC LEVEL2$49; 
BEGIN #A# 
# 
LEVEL 2 THRU 49 PROCESSOR.
THIS PROCESSOR IS CALLED WHEN THE CURRENT ITEM HAS A LEVEL NUMBER 
OF 2 THRU 49. 
  
THE PROCESSOR PERFORMS THE FOLLOWING FUNCTIONS: 
  A. CALLS THE ITEM PROCESSOR 
  B. SETS THE MAJOR MEMORY SECITON OF THE CURRENT ITEM AND, 
    IF THE CURRENT SECTION IS FD, THE MINOR MEMORY SECTION
  C. IF THE NEXT ITEM IN THE DNAT HAS A LEVEL NO LESS THAN 49 
    AND THE CURRENT ITEM IS A GROUP THEN THE GRP$ST$PTR IS
    UPDATED AND THE BYTE OFFSET FOR THE CURRENT ITEM IS SET 
    . IF THE CURRENT ITEM IS ELEMENTARY THEN THE SUM$ITEM PROCESSOR 
    IS CALLED.
    THE PROCESSOR THEN CHECKS THAT, IF THE LEVEL OF THE NEXT ITEM 
    IS LESS THAN THE LEVEL OF THE CURRENT ITEM, THAT AN ITEM OF 
    THE SAME LEVEL HAS ALREADY BEEN ENCOUNTERED SINCE THE LAST 01.
  D. IF THE NEXT ITEM IS GREATER THAN LEVEL 49 THEN THE SUM$ITEM, 
    AND SUM$GROUP PROCESSORS ARE CALLED. THE SUM$RECORD PROCESSOR 
    IS CALLED IF THE NEXT ITEM"S LEVEL IS NOT 66. SIMILARLY,
    IF THE NEXT ITEM"S LEVEL IS NOT 66 AND THE CURRENT SECTION
    IS THE FD SECTION THE SUM$FILE PROCESSOR IS CALLED. 
  
ON ENTRY IT IS ASSUMED THAT:  
  * DNAT$PTR POINTS TO THE CURRENT ITEM IN THE DNAT 
  * ELEMENTARY =1 IF THE CURRENT ITEM IS ELEMENTARY (0= GROUP)
  * SECTION CONTAINS THE CURRENT SECTION CODE 
  * GRP$ST[1] CONTAINS THE DNAT$PTR TO THE 01 ITEM IF THE 
    CURRENT ITEM IS SUBORDINATE 
  * MAJ$MEM$SEC, MIN$MEM$SEC CONTAINS RESPECTIVELY THE CURRENT MAJOR
    AND MINOR MEMORY SECTIONS 
  * CURR$ITM$LVL CONTAINS THE LEVEL NUMBER OF THE CURRENT ITEM
  * NXT$ITM$LVL CONTAINS THE LEVEL NUMBER OF THE NEXT NON-INDEX 
    77, OR 88 ITEM
# 
#LOCAL VARIABLES# 
ITEM LDNAT$PTR; #POINTER TO DNAT# 
ENTRY$(14,"LEVEL2$49"); 
ITEM$PROC; #CALL THE ITEM PROCESSOR#
SETFIELD(DN$MAJMSEC,DNAT$,DNAT$PTR,MAJ$MEM$SEC); #SET MAJOR MSEC# 
IF SECTION EQ FDSECTN 
  THEN #CURRENTLY IN FD SECTION#
  SETFIELD(DN$SUBMSEC,DNAT$,DNAT$PTR,MIN$MEM$SEC); #SET MINOR MSEC# 
IF NXT$ITM$LVL GQ 1 
  AND 
  NXT$ITM$LVL LQ 49 
  THEN #NEXT ITEM IS LEVEL 1 THRU 49# 
  BEGIN #B# 
                             TRACK$(14,1402); 
  IF ELEMENTARY EQ 0
    THEN #CURRENT ITEM IS A GROUP#
    BEGIN #C# 
                             TRACK$(14,1403); 
    GRP$ST$PTR=GRP$ST$PTR+1; #MV TO NXT ENTRY IN STACK# 
                          VALUE$(14,"GRPSTPTR=",GRP$ST$PTR);
    GRP$ST[GRP$ST$PTR]=DNAT$PTR; #STORE DNAT PTR TO THIS GRP# 
                 VALUE$(14,"GRPST=",GRP$ST[GRP$ST$PTR]);
    IF SECTION NQ FDSECTN 
      THEN #NOT IN FD SECTION#
      SETFIELD(DN$LONGOFF,DNAT$,DNAT$PTR,NAB); #SET LONG OFFSET#
      ELSE #IN FD SECTION#
      SETFIELD(DN$BYTEOFFS,DNAT$,DNAT$PTR,NAB); #SET BYTE OFFSET# 
    END #C# 
    ELSE #CURR ITEM IS ELEMENTARY#
    BEGIN #D# 
                             TRACK$(14,1404); 
    SUM$ITEM; #CALL SUM$ITEM PROCESSOR# 
    IF CURR$ITM$LVL NQ NXT$ITM$LVL
      THEN #NXT ITM AT LOWER LVL NBR THAN CURR ITM# 
      BEGIN #E# 
                             TRACK$(14,1405); 
      FOR LDNAT$PTR=GRP$ST[1] STEP 1
        UNTIL (DNAT$PTR-1)
        DO #FOR ALL ITEMS FROM 01 TO ONE BEFORE CURRENT#
        BEGIN #F# 
                             TRACK$(14,1406); 
                           VALUE$(14,"LDNAT$PTR=",LDNAT$PTR); 
        IF NXT$ITM$LVL EQ GETQUICK(DN$LEVEL,DNAT$,LDNAT$PTR)
          THEN #ITEM BEING CHECKED IS SAME LEVEL
                AS ITEM FOLLOWING CURRENT ITEM# 
          GOTO CALL$SUM$GRP;
        END #F# 
      ERROR(MSG47,J$ERROR); 
      #ALL ITEMS IMMEDIATELY SUBORDINATE TO A GROUP ITEM MUST HAVE
      THE SAME LEVEL NUMBERS. THE LEVEL NUMBRS MUST BE GREATER THAN 
      THE LEVEL OF THE GROUP ITEM.# 
     NANSILVLNOFG = TRUE; 
##
CALL$SUM$GRP: 
    IF NXT$ITM$LVL LQ 
       GETQUICK (DN$LEVEL, DNAT$, GRP$ST [GRP$ST$PTR]) THEN 
      SUM$GROUP; #CALL THE SUM GROUP PROCESSOR# 
      IF NXT$ITM$LVL EQ 1 
        THEN #NEXT ITEM IS LEVEL 1# 
        SUM$RECORD; #CALL SUM RECORD PROCESSOR# 
      END #E# 
    ELSE
      IF GETQUICK(DN$OCCURS,DNAT$,DNAT$PTR) NQ 0
         AND GETQUICK(DN$DEP,DNAT$,DNAT$PTR) NQ 0 
         THEN ERROR(MSG41,D$ERROR); 
    END #D# 
  END #B# 
  ELSE #NXT ITEM LEVEL IS 0 OR GREATER THAN 49# 
  BEGIN #G# 
                             TRACK$(14,1407); 
  SUM$ITEM; #CALL SUM ITEM PROCESSOR# 
  SUM$GROUP; #CALL SUM GROUP PROCESSOR# 
  IF NXT$ITM$LVL NQ 66
    THEN #NEXT ITEM IS NOT LEVEL 66#
    BEGIN #H# 
                             TRACK$(14,1408); 
    SUM$RECORD; #CALL SUM RECORD PROCESSOR# 
    IF SECTION EQ FDSECTN 
      THEN #CURRENTLY IN FDSECTN# 
      SUM$FILE; #CALL SUM FILE PROCESWOR# 
    END #H# 
  END #G# 
EXIT$(14,"LEVEL2$49");
END #A# 
END 
TERM
