*DECK QDRSYN
      PRGM DL30304;                    # THIS IS 3,4 OVERLAY           #015560
      BEGIN 
      DEF FIELDNAMEMAX #6#; 
      DEF CHARCNT #CURLENG#;
      DEF SSDIRLEN # 8#;     # LENGTH OF SUBSCHEMA CONTROL WORD        #015590
                                                                        015600
      XREF
      BEGIN 
      ITEM OLD65;            #LAST WORD ADDRESS OF LAST LOADED OVERLAY #
                             #+1                                       #
      ITEM ENDCOMP;          #SET IF THERE IS E OR C DIAGS             #
      ITEM DDLMEM;           #CURRENT FIELD LENGTH                     #
      ITEM DIAGDL;           # FWA OF DIAGNOSTIC ROUTINE               #
      ITEM AREALG;           #SIZE OF LARGEST AREA LENGTH              #
      ITEM CURLENG;          #CURRENT WORD LENGTH IN CHARS             #
      ITEM CURLENW;          #CURRENT WORD LENGTH IN WORDS             #
      ITEM DIAGNOS;          #DIAGS NUMBER                             #
      PROC STDNO;            #RETURN TO SYNGEN NO                      #
      PROC STDYES;           #RETURN TO SYNGEN YES                     #
      PROC ABRT1;            #CALLED IF INSUFFICIENT FL                #
      PROC ABRT4;            #CALLED IF SYNTAX ERRORS OCCUR            #
      PROC GETENT;           #READ FROM SUBSCHEMA SCRATCH FILE         #015630
      PROC PUTENT;           #WRITE TO SUBSCHEMA SCRATCH FILE          #015640
      PROC QUDRTN5;          #LOAD AND EXECUTE OVERLAY (3,5)           #015650
      PROC RETNZZ;           #CLOSE AND UNLOAD SUBSCHEMA SCRATCH FILE  #015660
      PROC STD$START;        #ENTRY POINT IN CTLSTD WHICH              #015670
                             #STARTS SYNTAX ANALYSIS                   #015680
      PROC DIAGS;            #CALLED TO PRINT DIAGS IN OUTPUT          #
      FUNC DHASH I;          #TO HASH DATA NAMES                       #
      ITEM CURTYPE;          # IF CURTYPE=100, SCAN TYPE=KEYWORD       #
                             #           =101            NAME          #
                             #           \102            LITERAL       #
                             #           \106            NUMERIC       #
                             #           =107            INTEGER       #
                             #           =109            COMPLEX       #
                             #           >102 AND <106 NON-NUMERIC     #
      ITEM SBLOCK;           #WA OF SUB-SCHEMA CONTROL WORD BLOCK      #015700
      ARRAY CWRD[25]; 
         BEGIN
         ITEM CWD U(0,0,60);
         ITEM CWC C(0,0,10);
         ITEM CWC9 U(0,6,54); 
         ITEM CWC1 U(0,0,6);
         END
               ITEM DDLDIAG;
               ITEM SYNTBL; 
               ITEM SYNTBLE;
               ITEM LBLPTR; 
               ITEM LBLPTRS;
               ITEM LEXWD;
               ITEM LEXWORDS; 
               ITEM LEXICO; 
               ITEM LEXICON;
               ITEM SWITCHVCTR; 
               PROC DCTINIT;
      END 
      BASED ARRAY RA; 
         BEGIN
         ITEM RAOCC U(0,6,18);
         ITEM RAW U(0,0,60);
         ITEM RAC C(0,0,10);
         END
      BASED ARRAY BA S(4);
         BEGIN
         ITEM BARNAMLG       U(0,0,6);  #LENGTH OF AREA NAME (WORDS)   #
         ITEM BARPTR         U(0,30,30);#WORD ADDRESS OF AREA ENTRY    #
         ITEM BARCYCL        U(0,6,1);  #SET IF AREA USED FOR TRAVERSIN#
                                        #G IN RELATION DIVISION        #
         ITEM BARNAME        C(1,0,30); #AREA NAME BLANK FILLED        #
         END
      BASED ARRAY BFN;
         ITEM  BFW   U(0,0,60); 
      BASED ARRAY HASHTBL;
         ITEM  HASHWD (0,0,60); 
      BASED ARRAY RELATIONINDX[0];
         BEGIN
         ITEM RELNAMELEN     U(0,0,6);      #LENGTH OF RELATION NAME   #
                                            #IN WORDS                  #
         ITEM RELENTRYADR    U(0,30,30);    #WORD ADD OF RELATION ENTRY#
         ITEM RELNAME        C(0,0,10);     #RELATION NAME BLANK FILLED#
         END
      BASED ARRAY SCHBLOCK [0] S(SSDIRLEN);  # SS DIRECTORY CONTROL WD #015720
        BEGIN                                                           015730
*CALL COMQUSBLK              SUBSCHEMA CONTROL WORD BLOCK               015740
        END                                                             015750
                                                                        015760
      ARRAY SBWORD S(2);
         BEGIN
         ITEM SBARINDXLG     U(0,0,30); #LENGTH(WORD) OF AREA INDEX TAB#
                                        #LE                            #
         ITEM SBARINDXPTR    U(0,30,30);#WORD ADDRESS OF AREA INDEX    #
                                        #TABLE                         #
         ITEM SBRLINDXLG     U(1,6,24); #LENGTH(WORD) OF RELATION INDEX#
                                        #TABLE                         #
         ITEM SBRLINDXPTR    U(1,30,30);#WORD ADDRESS OF RELATION INDEX#
                                        #TABLE                         #
         ITEM SBLG           U(1,30,30);#POINTER OF LAST AREAINDEX TAB# 
         END
      ARRAY FIELDN[1:FIELDNAMEMAX] S(4);
#ARRAY FIELDN WILL CONTAIN DATA NAME, SUBSCRIPTS, AND FLAGS FOR        #
# A DATA ITEM AND ITS QUALIFIERS FROM INPUT SYNTAX.                    #
         BEGIN
         ITEM FNNAME   C(0,0,30);   #FULL DATA NAME FIELD, 30 CHAR.    #
         ITEM FN       C(0,0,10);   #DATA NAME 1 TO 30 CHARS LEFT      #
         ITEM FN1      C(1,0,10);   #JUSTIFIED BLANK FILLED            #
         ITEM FN2      C(2,0,10);   #                                  #
         ITEM FN3      U(3,0,60);   #                                  #
         ITEM FNLG     U(3,0,6);    #LENGTH OF DATA NAME IN CHAR       #
         ITEM FNSUB    U(3,6,12);   #SUBSCRIPT IF THERE IS ANY         #
                                    #IN SUBSCHEMA                      #
         ITEM FNADDR   U(3,18,18);  #ADDRESS OF DATA NAME ATTRIBUTE    #
         ITEM FNANY  B(3,36,1);     #FLAG FOR SUBSCRIPT ANY            #
         ITEM FNSUBSFLAG B(3,37,1); #TRUE IF SUBSCRIPTABLE ITEM.       #
         END
      ARRAY AREAENTRY S(3); 
         BEGIN
         ITEM MULTIREC       B(0,36,1);  #MULTIPLE RECORD INDICATOR    #
         ITEM HASHPTR        U(0,48,12);    #HASH TABLE POINTER        #
         ITEM RECADD         U(1,42,18);    #RECORD POINTER            #
         ITEM FITPTR         U(2,36,12); #FIT POINTER                  #
         END
      BASED ARRAY RELATIONHEAD[0];
         BEGIN
         ITEM RELRANKS       U(0,0,6);   #NBR OF RANKS IN RELATION     #
         ITEM RELNBRRES      U(0,6,6);   #NBR OF RESTRICT CLAUSES IN   #
                                         #RELATION                     #
         ITEM RELRESTADR     U(0,42,18); #WORD ADDRESS OF RESTRICT     #
                                         #ENTRY (ZERO IF NONE)         #
         END
      BASED ARRAY RELATIONENTR[0];
         BEGIN
         ITEM RELDBIAREADR   U(0,0,18);  #WORD ADDR OF AREA ENTRY OF   #
                                         #JOIN DBI                     #
         ITEM RELDBIITMADR   U(0,18,18); #WORD ADDR OF ITEM ENTRY OF   #
                                         #JOIN DBI                     #
         ITEM RELDBIANYFLG   B(0,37,1);  #TRUE IF SUBSCRIPT = ANY      #
         ITEM RELDBIBCP      U(0,38,4);  #BEGIN CHAR POS(RELATIVE TO   #
                                         #WORD) OF SPECIFIED OCCU OF   #
                                         #WORD) OF SPECIFIED OCCUR     #
                                         #OF DBI                       #
         ITEM RELDBIBWP      U(0,42,18);   #BEGIN WORD POS(RELATIVE TO #
                                         #FWA OF RECORD) OF SPECIFIED  #
                                         #OCCUR OF DBI                 #
         END
     BASED ARRAY RESTRICTHEAD[0]; 
         BEGIN
         ITEM RESNEXTFLAG    B(0,0,1);   #TRUE IF ANOTHER RESTRICT     #
                                         #ENTRY FOLLOWS                #
         ITEM RESENTRLENG    U(0,1,8);   #LENGTH(WORDS) OF RESTRICT    #
                                         #CHAR STRING                  #
         ITEM RESRANK        U(0,36,6);  #RANK OF RECORD BEING RESTR.  #
         ITEM RESRECADR      U(0,42,18); #WORD ADDR OF REC  ENTRY FOR  #
                                         #RESTRICT                     #
         END
      BASED ARRAY RESTRICTCHAR[0];
         ITEM RESCHARSTRNG   C(0,0,10);  #CHAR STRING OF RESTRICT      #
                                         #CLAUSE, BLANK FILLED         #
      ARRAY RELDBIRECTBL[64]; 
         BEGIN
         ITEM RELDBIRECTBW  U(0,0,60);
         ITEM RELDBIRECADR U(0,0,18);    #REC ENTRY OF JOIN DBI        #
         ITEM RELDBIRESFLG B(0,18,1);    #SET IF HAS RESTRICT CLAUSE   #
         END
      ARRAY AHASHTBLE[64];
         ITEM AHASHPTR U(0,42,18);
      ARRAY RECORDNAME [2]; 
         ITEM RECNAM C(0,0,10); 
      BASED ARRAY ITEMENTRY P(8); 
      BEGIN 
         ITEM  ITMTYPE U(0,0,6);    #DATA NAME TYPE                    #
         ITEM ITMDOM   U(0,24,12);  #DOMINANT POINTER                  #
         ITEM ITMNAMLGW U(1,6,6);   #DATA NAME LENGTH IN WORDS         #
         ITEM ITMNAMLGC U(1,0,6);   #ITEM NAME LENGTH, CHARS.          #
         ITEM ITMCLASS  U(1,12,6);  #ITEM CLASS                        #
         ITEM ITMBWP   U(1,18,18);  #BEGINNING WORD POSITION RELATIVE  #
                                    #TO RECORD                         #
         ITEM  ITMBBP  U(1,36,6);   #BEGINNING BIT POSITION RELATIVE   #
                                    #TO WORD                           #
         ITEM ITMSIZE  U(1,42,18);  #INTERNAL USAGE SIZE               #
         ITEM  ITMOCB  U(2,2,1);    #SET IF TYPE IS 2, 3 OR 4          #
         ITEM ITMDIMOCC B(2,2,1);   #TRUE IF OCCURS INFO EXISTS.       #
         ITEM ITMMAXOCC U(0,6,18);  #NUMBER OF OCCURRENCE              #
         ITEM ITMALTKEY B(2,16,1);     #TRUE IF ITEM IS ALTERNATE KEY. #
         ITEM ITMNAMUNIQ     B(2,19,1); #NAME NOT IN ANY OTHER AREA.   #
         ITEM ITMSYN         U(3,0,18);#SYNONYM POINTER.               #
         ITEM ITMSAMNAM      U(3,18,18);#SAME-NAME POINTER.            #
         ITEM ITMNAME        C(4,0,30); #ITEM NAME. 1-30 CHARS.        #
      END 
      ITEM CURRENTRANK;      #RANK OF CURRENT RESTRICT RECORD. #
      ITEM EMTRESTRING B;    # TRUE IF CURRENT RESCHARSTRNG IS EMPTY   #
      ITEM FL;               #CURRENT FIELD LENGTH                     #
      ITEM AREAINDX;         #ADDRESS OF AREA INDEX TABLE IN CORE      #
      ITEM WRITEWORD;        #ADDRESS IN SUBSCHEMA WHERE NEW ENTRY TO  #
                             #BE WRITTEN                               #
      ITEM RELATIONBASE;     #ADDRESS IN CORE WHERE RELATION ENTRIES   #
                             #BEGIN                                    #
      ITEM NBRRL;            #NUMBER OF RELATIONS                      #
      ITEM FIELDNAMELG;      #NUMBER OF LEVELS OF DATA NAMES           #
      ITEM DISPINT; 
      ITEM INTCNT;           #INTEGER COUNT                            #
      ITEM XDTBRSLT;         #RESULT OF CONVERSION FROM DISPLAY TO     #
                             #BINARY                                   #
      ITEM AREADESADD;       #ADDRESS OF AREA ENTRY                    #
      ITEM SOUDBI B;         #SET IF SOURCE DBI                        #
      ITEM TARDBI B;         #SET IF TARGET DBI                        #
      ITEM ANYFLAG B;        #SET IF ANY SUBSCRIPT DEFINED             #
      ITEM WRDADDR;          #WORD ADDRESS OF DATA NAME IN CORE        #
      ITEM AREABUFF;         #WORD ADDRESS IN CORE WHERE REC INFORMATIO#
                             #N STARTS                                 #
      ITEM CLOSEP;           #NUMBER OF CLOSE PARENTHESIS              #
      ITEM OPENP;            #NUMBER OF OPEN PARENTHESIS               #
      ITEM AREASIZE;         #CURRENT AREA SIZE                        #
      ITEM SOUAR;            #POINTER OF AREA OF SOURCE DBI            #
      ITEM TARAR;            #POINTER OF AREA OF TARGET DBI            #
      ITEM BCP;              #BEGINNING CHAR POSITION                  #
      ITEM BWP;              #BEGINNING WORD POSITION                  #
      ITEM HASHADDR;         #ADDRESS OF HASH TABLES IN CORE           #
      ITEM NBRAR;            #NUMBER OF AREAS                          #
      ITEM RECPTR;           #RECORD POINTER IN SUBSCHEMA              #
      ITEM ITMPTR;           #ITEM POINTER IN SUBSCHEMA                #
      ITEM AREAPTR;          #AREA POINTER FOR JOIN DBI                #
      ITEM AA;               #BEGINNING CHAR POSITION OF RESTRICT CLAUS#
                             #E CHAR STRING WHERE FOR NEW CHAR STRING  #
                             #TO BE WRITTEN                            #
      ITEM RESFLAG B;        #SET IF CRACKING RESTRICT CLAUSE          #
      ITEM USESIZE;          #INTERNAL USAGE SIZE OF ITEM              #
      ITEM CLASS;            #ITEM DATA NAME CLASS                     #
      ITEM ALLFOUND B;       #TRUE IF ITEM AS QUALIFIED HAS BEEN FOUND.#
      ITEM ALLEXCEPTSUB B;   #TRUE IF ITEM AS QUALIFIED HAS BEEN       #
                   #FOUND, BUT SUBSCRIPTABLE QUALIFIER ITEM OMITTED.   #
      ITEM HASHTABLINDX;     #INDEX INTO AREA HASH TABLES.# 
      ITEM SAMENAMEPTR U;    #SAVE SAME-NAME POINTER.                  #
      ITEM SAVEAREAORD U;    #SAVE INDEX TO AREA HASH TABLE.           #
      ITEM SUBSCOUNT U;      #COUNT OF SUBSCRIPTS. #
      ITEM UNIQUENAME B;     #TRUE IF PRIMARY ITEM NAME DOES NOT       #
                             #  APPEAR IN ANY OTHER AREA.              #
      ITEM RELTRFLAG B;      #IF TRUE PROCESS PROC RELTRVSD            #
      ITEM NBRRES;           #NUMBER OF RESTRICT CLAUSES IN RELATION   #
      ITEM RELDBIRECIDX;     #INDEX FOR ARRAY RELDBITBL                #
      ITEM I; 
      ITEM J; 
      ITEM K; 
      ITEM L; 
      ITEM M; 
      ITEM II;
        SWITCH RELJUMP
               ANYYES,
               CHKPAR,
               CHKREC,
               CLARCYL, 
               CLOSEPAR,
               CLUP,
               DBI1,
               DBI2,
               ENDR,
               GETNAME, 
               INITR, 
               ITMNAM,
               OPENPAR, 
               RECNAME, 
               RELTRVSD,
               RESETNAM,
               SOURCEDBI, 
               STRN,
               SUB1,
               TARGETDBI, 
               VERIFYLIT, 
               WRITERES,
               WRITEWRD,
               WRTRESET;
*IF DEF,DEBUG 
         XREF ITEM  TRACE; XREF ITEM TRACEM;
         TRACE=LOC(TRACEM); 
*ENDIF
*IF DEF,DEBUG1
      XREF
         BEGIN
         PROC SNATCH; 
         PROC SNATCHO;
         PROC SNATCHF;
         END
*ENDIF
      CONTROL EJECT;                                                    015780
#**********************************************************************#015790
#                                                                      #015800
#         E X E C U T A B L E   C O D E   F O R   Q D R S Y N          #015810
#                                                                      #015820
#**********************************************************************#015830
                                                                        015840
                                                                        015850
      P<SCHBLOCK> = LOC(SBLOCK);   # WA OF SUBSCHEMA CONTROL WORD BLOCK#015860
      DDLDIAG = LOC(DIAGDL);
      SYNTBL=LOC(SYNTBLE);
      LBLPTR=LOC(LBLPTRS);
      LEXWD=LOC(LEXWORDS);
      LEXICO=LOC(LEXICON);
      SWITCHVCTR=LOC(RELJUMP);
      DCTINIT;
      STD$START;                   # START SYNTAX ANALYSIS             #015880
#                                                                      #
#ARRAY CWRD PRESENTLY CONTAINS THE INPUT ELEMENT WORD LENGTH IN CHAR 0 #
# OF WORD 0. SHIFT CONTENTS OF ARRAY LEFT ONE CHARACTER SO THAT        #
#CURRENT ELEMENT IS LEFT-JUSTIFIED, BLANK FILLED.                      #
#                                                                      #
      PROC GETCURNAM(A);
         BEGIN
         ARRAY A[3];
            BEGIN 
            ITEM CWF9 U(0,0,54);
            ITEM CWF1 U(0,54,6);
            ITEM CWFD U(0,0,60);
            END 
         FOR I=0 STEP 1 UNTIL CURLENW-1 DO
            BEGIN 
            CWF9[I]=CWC9[I];
            CWF1[I]=CWC1[I+1];
            END 
         CWFD[I]="          ";
         IF CWFD[I-1] EQ "          " THEN
            CURLENW=CURLENW-1; #DISCARD LAST WORD,IF ONLY BLANK REMAINS#
         END
#                                                                      #
# THIS PROC IS TO CHECK RELATION ENTRIES TO BE BUILT LIE  WITHIN       #
# CURRENT FIELD LENGTH.IF NOT CALL ABRT1 TO PRINT MESSAGE AND ABORT JOB#
#                                                                      #
      PROC CHKFL(FLG);
         BEGIN
         ITEM FLG;
         IF FLG GR FL THEN
           BEGIN
           RETNZZ;           # CLOSE AND UNLOAD SUBSCHEMA SCRATCH FILE #015900
           ABRT1; 
           END
         RETURN;
         END
#                                                                      #
#THIS PROC IS TO CONVERT INPUT DISPLAY CODE TO BINARY CODE             #
#                                                                      #
       PROC XDTB; 
  
        BEGIN 
        XDTBRSLT = 0; 
        FOR I = 60 - (INTCNT * 6) STEP 6 UNTIL 59 DO
         BEGIN
          XDTBRSLT = (B<I,6> DISPINT - O"33") + XDTBRSLT; 
          IF I EQ 54 THEN GOTO XDTBEX;
          XDTBRSLT = XDTBRSLT * 10; 
         END
        XDTBEX: 
         RETURN;
        END 
  
#                                                                      #
# THIS PROC IS TO CALCULATE  BCP AND BWP OF DATA NAME. ITS SUBSCRIPTS  #
# ARE STORED IN ARRAY FIELDN.                                          #
#                                                                      #
      PROC BWPBCP;
      BEGIN 
      ARRAY SUBTAB[1:FIELDNAMEMAX]; 
         BEGIN
         ITEM SUBWD  U(0,0,60); 
         ITEM SUBCHAR U(0,0,30);            #BEGINNING CHAR POSITION   #
                                            #RELATIVE TO THE RECORD    #
         ITEM SUBOFFSET U(0,30,15);         #OFFSET OF CHAR FROM       #
                                            #DOMINANT                  #
         ITEM SUBSIZE U(0,45,15);           #SIZE OF ONE OCCURS        #
         END
      J=0;
      FOR I=FIELDNAMELG STEP -1 UNTIL 1 DO
      BEGIN 
      SUBWD[I]=0;            #INITIALIZE# 
      P<ITEMENTRY> = FNADDR[I];#DATA NAME OR ITS QUALIFIER ENTRY# 
      M=4+ITMNAMLGW[0];      #INDEX TO OCCUR WORD IN SUBSCHEMA# 
      IF ITMTYPE[0] GQ 2 AND ITMTYPE[0] LQ 4 THEN 
                             #DATA NAME WITH OCCURS#
         BEGIN
         IF FNANY[I] THEN    #SUBSCRIPT -ANY- IS SPECIFIED             #
            RELDBIANYFLG[1]=TRUE; 
         IF ITMTYPE[0] NQ 4 THEN
                             #GROUP DATA NAME WITH OCCURS#
            BEGIN 
            P<RA>=P<ITEMENTRY>; 
            ITMSIZE[0]=ITMSIZE[0]/RAOCC[M]; #DATA NAME SIZE FOR ONE OCC#
            END 
         END
      SUBCHAR[I]=ITMBWP[0]*10+ITMBBP[0]/6;#DATA NAME BEGINNING POSITION#
      SUBSIZE[I]=ITMSIZE[0]; #STORE ITEM SIZE#
      END 
# GET OFFSET OF DATA NAME  FROM REPEATING DOMINANT GROUP               #
      FOR I=FIELDNAMELG STEP -1 UNTIL 1 DO
         BEGIN
         IF FNSUB[I] EQ 0 THEN FNSUB[I]=1;
         IF I GR 1 THEN 
            SUBOFFSET[I]=SUBCHAR[I-1]-SUBCHAR[I]; 
         K=SUBOFFSET[I]+(FNSUB[I]-1)*SUBSIZE[I];
         J=J+K; 
         END
      J=J+SUBCHAR[FIELDNAMELG]; #BEGINNING POSITION FOR DATA NAME#
      BWP=J/10;              #BEGINNING WORD POSITION FOR DATA NAME#
      BCP=J-BWP*10;          #BEGINNING CHAR POSITION FOR DATA NAME#
      END 
  
#                                                                      #
# THIS PROC CALLS FOR ERROR DIAGNOSTIC AND EXITS TO STDNO.             #
#                                                                      #
      PROC DIAGNONO(NBR); 
      BEGIN 
      ITEM NBR;              #DIAGNOSTIC NUMBER. #
      DIAGNOS=NBR;
      DIAGS;
      STDNO;                 #EXIT. # 
      END 
  
#                                                                      #
# THIS PROC READS (FROM DIRECTORY TO CORE BUFFER, ADDRESS -AREABUFF-)  #
# THE ENTIRE RECORD ENTRY FOR THE AREA WITH ORDINAL -AREAORD-.         #
#                                                                      #
      PROC GETAREAENTRY(AREAORD); 
        BEGIN 
        ITEM AREAORD;        #ORDINAL OF AREA IN AREA INDEX TABLE. #
        P<BA> = AREAINDX;    #START OF THE AREA INDEX. #
        FOR I = 1 STEP 1 UNTIL AREAORD DO #SKIP OVER PRIOR AREA INDEXES#
          P<BA> = P<BA> + BARNAMLG[0] + 1;  #NEXT AREA INDEX ENTRY. # 
# BA NOW CONTAINS THE AREA INDEX ENTRY FOR AREA NUMBER AREAORD. # 
# READ 3 WORDS OF AREA ENTRY FROM DIRECTORY AT WA = BARPTR. # 
      AREAPTR=BARPTR[0];     #WA OF AREA ENTRY# 
        GETENT(LOC(AREAENTRY),3,BARPTR[0]); 
        RECPTR = RECADD[0];  #WA OF RECORD ENTRIES. # 
# READ RECORD ENTRIES FROM DIRECTORY AT WA = RECPTR, TO BFR AT AREABUFF#
# SIZE OF RECORD ENTRIES = WA OF AREA ENTRY - WA OF RECORD ENTRIES. # 
        GETENT(AREABUFF,BARPTR[0]-RECPTR,RECPTR); 
        RETURN; 
        END 
  
#                                                                      #
# THIS PROC SEARCHES FOR A MATCH ON THE NAMES (IN ARRAY -FIELDN-) OF   #
# THE PRIMARY ITEM AND ITS QUALIFIER ITEMS WITH THOSE OF THE ITEM AND  #
# ITS DOMINANT ITEM ENTRIES, LOCATED BY THE HASHING ROUTINE.           #
#                                                                      #
      PROC CKQUALIFIERS;
       BEGIN
      ITEM SKIPSUB B;        #TRUE IF A SUBSCRIPTABLE DOMINANT SKIPPED.#
      P<ITEMENTRY> = WRDADDR - RECPTR + AREABUFF; 
      K = FNLG[1];           #LENGTH OF PRIMARY ITEM NAME.             #
# LOOP UNTIL FIND ENTRY WITH NAME OF PRIMARY ITEM.                     #
      FOR I = 0 WHILE K NQ ITMNAMLGC[0] OR
       C<0,K>FNNAME[1] NQ C<0,K>ITMNAME[0] DO 
        BEGIN 
        IF ITMSYN[0] EQ 0 THEN
          RETURN;            #NO MORE SYNONYMS.  EXIT WITH ALLFOUND=F. #
        P<ITEMENTRY> = P<ITEMENTRY> + ITMSYN[0];  #ENTRY OF NEXT SYN. # 
        END                  #LOOP ON SYNONYMS. # 
  
# WE HAVE FOUND ENTRY WITH SAME NAME AS PRIMARY ITEM.                  #
      IF ITMNAMUNIQ[0] THEN 
        UNIQUENAME = TRUE;        #ITEM NAME EXISTS IN NO OTHER AREA.  #
# NOW LOOP THRU SAME-NAME ENTRIES, LOOKING FOR MATCH ON ALL QUALIFIERS #
#   WITH NAMES OF DOMINANT ITEMS.                                      #
      SAMENAMEPTR = 1;       #INITIALIZE. # 
      FOR I=0 WHILE SAMENAMEPTR NQ 0 DO  #LOOP THRU SAME-NAMES. # 
        BEGIN 
        IF ITMSAMNAM[0] NQ 0 THEN 
          SAMENAMEPTR = ITMSAMNAM[0] + P<ITEMENTRY>; #SAVE SAME NAME AD#
        ELSE
          SAMENAMEPTR = 0;
        IF NOT ALLFOUND THEN       #SAVE INFO FOR PRIMARY ITEM.        #
          BEGIN 
          FNADDR[1] = P<ITEMENTRY>;  #SAVE ADDR OF PRIMARY ITEM ENTRY. #
          FNSUBSFLAG[1] = ITMDIMOCC[0];  #TRUE IFF ITEM SUBSCRIPTABLE. #
          END 
  
#     LOOP THRU DOMINANT ITEMS, COMPARING NAMES WITH NAMES OF          #
#     QUALIFIER ITEMS.                                                 #
#   SKIP OVER DOMINANT ITEMS, AS NEEDED, LOOKING FOR A MATCH,          #
#   BUT NOTE IF A SUBSCRIPTABLE DOMINANT ITEM IS SKIPPED OVER.         #
        SKIPSUB = FALSE;     #INITIALIZE. # 
        J = 2;               #START WITH FIRST QUALIFIER ITEM.         #
        FOR L = 0 WHILE ITMDOM NQ 0 AND ITMTYPE NQ 7 DO 
          BEGIN 
          P<ITEMENTRY> = P<ITEMENTRY> - ITMDOM[0]; #DOM ITEM INFO.     #
          IF J LQ FIELDNAMELG THEN #MORE QUALIFIER ITEMS EXIST.        #
            BEGIN 
            L = FNLG[J];     #LENGTH (CHAR) OF QUALIFIER NAME.         #
            IF L EQ ITMNAMLGC[0]   #NAMES OF SAME LENGTH.              #
             AND C<0,L>FNNAME[J] EQ C<0,L>ITMNAME[0] THEN  #NAMES EQUAL#
              BEGIN 
              IF NOT ALLFOUND THEN #MATCH ON ALL QUALS NOT YET FOUND.  #
                BEGIN 
                FNADDR[J] = P<ITEMENTRY>;    #SAVE ADDR OF ITEM ENTRY. #
                FNSUBSFLAG[J] = ITMDIMOCC[0];  #TRUE IFF SUBSCRIPTABLE.#
                END 
              J = J + 1;     #CONSIDER NEXT QUALIFIER ITEM.            #
              END 
            ELSE             #QUALIFIER AND DOM ITEM NAME NOT MATCH.   #
              IF ITMDIMOCC[0] THEN #THIS DOM ITEM IS SUBSCRIPTABLE.    #
                SKIPSUB = TRUE; 
            END 
          ELSE               #NO MORE QUALIFIERS TO BE CONSIDERED.     #
            IF ITMDIMOCC[0] THEN   #THIS DOMINANT ITEM IS SUBSCRIPTABLE#
              SKIPSUB = TRUE; 
  
          END  #OF FOR L... LOOP ON DOMINANT ITEMS. # 
  
        IF J EQ FIELDNAMELG + 1 THEN   #ALL QUALIFIERS FOUND MATCH.    #
          IF ALLFOUND THEN   #ALREADY HAD A FULL MATCH. # 
            DIAGNONO(075);   #ITEM MULTIPLY DEFINED. #
          ELSE
           IF SKIPSUB THEN   #FULL MATCH, BUT SUBSCRIPTABLE DOMINANT   #
                             #ITEM WAS SKIPPED.                        #
             ALLEXCEPTSUB = TRUE; 
           ELSE 
            BEGIN 
            ALLFOUND = TRUE; #INDICATE FULL MATCH FOUND. #
            SAVEAREAORD = HASHTABLINDX; #SAVE INDEX TO THIS AREA. # 
            END 
#     GO ON TO NEXT SAME-NAME ITEM, IF ANY.                            #
          IF SAMENAMEPTR NQ 0 THEN
            BEGIN 
            P<ITEMENTRY> = SAMENAMEPTR;     #NEXT SAME-NAME ENTRY.     #
            END 
        END #OF FOR I... LOOP ON SAMENAMES. # 
       RETURN;               #EXIT. # 
       END  #OF PROC CKQUALIFIERS. #
  
#                                                                      #
# THIS PROC VALIDATES THE SUBSCRIPTS SPECIFIED ON THE PRIMARY ITEM     #
# AND THE QUALIFIER ITEMS.                                             #
#                                                                      #
      PROC CKSUBSCRIPTS;
      BEGIN 
      ITEM ITEMPOS U;        #SAVE POSITION (BITS) RELATIVE TO RECORD. #
      ITEM ALTKEYFLAG B;     #TRUE = PRIMARY ITEM IS AN ALTERNATE KEY  #
                             #  OR THE MAJOR PART OF AN ALTERNATE KEY. #
      ITEM ANYFLAG B;        #TRUE IF A SUBSCRIPT -ANY- WAS ENCOUNTERED#
      ANYFLAG = FALSE;
      SUBSCOUNT = 0;         # INITIALIZE. #
      P<ITEMENTRY> = FNADDR[1];    #SET UP PRIMARY ITEM ENTRY. #
      ITEMPOS = ITMBBP[0] + 60*ITMBWP[0]; #SAVE BEG POS OF PRIMARY ITEM#
      ALTKEYFLAG = ITMALTKEY[0];   #SET TRUE IF ITEM IS AN ALT KEY. # 
  
# LOOP THRU ITEM AND QUALIFIERS, CHECKING THAT SUBSCRIPTS ARE SUPPLIED #
#   FOR ALL (AND ONLY) THE SUBSCRIPTABLE ITEMS, AND THE SUBSCRIPT VALUE#
#   IS WITHIN THE MAXIMUM OCCURS DEFINED FOR THE ITEM.                 #
        FOR J = 1 STEP 1 UNTIL FIELDNAMELG DO 
          BEGIN 
          IF #10# FNSUBSFLAG[J] THEN   #ITEM IS SUBSCRIPTABLE. #
            BEGIN 
            IF #20# FNSUB[J] EQ 0 THEN #NO SUBSCRIPT SUPPLIED. #
              DIAGNONO(076); #SUBSCRIPT LACKING. #
            ELSE #20#        #SUBSCRIPT SUPPLIED. # 
              BEGIN 
              SUBSCOUNT = SUBSCOUNT + 1;    #INCREMENT COUNT OF SUBS.  #
# GET ITEM ENTRY. THEN POINT TO OCCURS INFO BY SKIPPING NAMES ENTRIES. #
              P<ITEMENTRY> = FNADDR[J];  #SET UP ITEM ENTRY. #
              IF #30# FNANY[J] THEN     #SUBSCRIPT = -ANY- #
              BEGIN 
                IF #40# ANYFLAG THEN    #ALREADY HAD AN -ANY-. #
                  DIAGNONO(063);       #MORE THAN ONE -ANY- SPECIFIED. #
                ELSE #40#    #THIS IS THE FIRST -ANY-. #
                  BEGIN 
                  ANYFLAG = TRUE; 
                  IF RESFLAG           #PROCESSING A RESTRICT ENTRY. #
                  OR SOUDBI THEN       #PROCESSING A SOURCE ITEM. # 
                    DIAGNONO(072); #ILLEGAL SUBSCRIPT -ANY-. #
                  IF NOT ALTKEYFLAG THEN  #PRI ITEM NOT AN ALT KEY.    #
                    IF ITMALTKEY[0]  #THIS ITEM IS AN ALT KEY.         #
                    AND ITEMPOS EQ (ITMBBP[0] + 60*ITMBWP[0]) THEN
                             #ITEM IN SAME POSITION AS PRIMARY ITEM, SO#
                             #PRIMARY ITEM IS A MAJOR PART OF ALT KEY. #
                      ALTKEYFLAG = TRUE;
                  IF NOT ALTKEYFLAG    #PRI ITEM NOT ALT KEY OR MAJOR. #
                   THEN 
                    DIAGNONO(073); #ILLEGAL SUBSCRIPT -ANY-. #
                  END #OF ELSE 40#
                END #OF IF 30#
              ELSE #30#      #NUMERIC SUBSCRIPT (NOT -ANY-). #
                BEGIN 
                I=4+ITMNAMLGW[0];  #OFFSET TO OCC # 
                IF FNSUB[J] GR ITMMAXOCC[I] THEN
                  DIAGNONO(078);   #SUBSCRIPT VALUE OUT OF BOUNDS. #
                END #OF ELSE 30#
              END #OF ELSE 20#
            END #OF IF 10#
          ELSE #10#          #ITEM IS NOT SUBSCRIPTABLE. #
            BEGIN 
            IF FNSUB[J] NQ 0
             OR FNANY[J] THEN 
              DIAGNONO(076); #SUBSCRIPT ON UNSUBSCRIPTABLE ITEM. #
            END #OF ELSE 10#
          END #OF LOOP ON QUALIFIERS, FOR J ...#
  
# VERIFY AT MOST 3 SUBSCRIPTS ARE SPECIFIED.                           #
# IF SUBSCRIPT -ANY- WAS ENCOUNTERED, NO OTHER SUBSCRIPT CAN APPEAR.   #
# ONLY 1 SUBSCRIPT ALLOWED IF PROCESSING A RESTRICT ENTRY.             #
        IF SUBSCOUNT GR 3 
         OR (RESFLAG AND SUBSCOUNT GR 1)
         OR (ANYFLAG AND SUBSCOUNT NQ 1) THEN 
          DIAGNONO(080);     #TOO MANY SUBSCRIPTS. #
        RETURN; 
        END #OF PROC CKSUBSCRIPTS. #
  
#                                                                      #
#SYNGEN SEMANTIC ROUTINES START HERE                                   #
#                                                                      #
  
# SET SUBSCRIPT -ANY- FLAG IN FIELDN                                   #
ANYYES: 
      FNSUB[FIELDNAMELG]=1; 
      FNANY[FIELDNAMELG]=TRUE;
      STDNO;
  
# CHECKS FOR SAME NBRS OF RIGHT AND LEFT PARENTHESIS                   #
CHKPAR: 
      IF OPENP NQ CLOSEP THEN #DIAGONOSE IF UNBALANCE IN ( AND )# 
         BEGIN
         DIAGNOS=064;        #ERROR IN PARENTHESIS# 
         DIAGS; 
         END
      CLOSEP=0;              #INITIALIZE# 
      OPENP=0;               #INITIALIZE# 
      RESFLAG=FALSE;         #INITIALIZE# 
      STDNO;
  
#ZERO OUT THE CYCLING BIT IN AREA INDEX TABLE BEORE WRITTEN BACK       #
#TO SUBSCHEMA                                                          #
CLARCYL:  
      P<BA>=AREAINDX;        #PTR TO AREA INDEX TABLE IN CORE#
      FOR I=0 STEP 1 WHILE P<BA> LS HASHADDR DO 
         BEGIN
         BARCYCL[0]=0;       #ZERO OUT CYCLING BIT# 
         P<BA>=P<BA>+BARNAMLG[0]+1; #PTR TO NEXT AREA INDEX ENTRY#
         END
      STDNO;
  
# ACCUMULATES NUMBER OF RIGHT PARENTHESIS                              #
CLOSEPAR: 
      CLOSEP=CLOSEP+1;       #INCREMENT BY 1# 
      STDYES; 
  
# CHECK DATA ITEM NAME IS IN THE RECORD OF RESTRICT CLAUSE             #
CHKREC: 
      P<ITEMENTRY>=AREABUFF;  #RECORD ENTRY IN CORE#
      P<RA>=P<ITEMENTRY>; 
         FOR I=0 STEP 1 UNTIL ITMNAMLGW[0]-1 DO 
      IF RECNAM[I] NQ  RAC[I+4] THEN
         DIAGNONO(082);      #DATA ITEM NOT IN RECORD OF RESTRICT. #
      STDYES; 
  
# RESET SOURCE AND TARGET DBI FLAGS                                    #
CLUP: 
      SOUDBI=FALSE; 
      TARDBI=FALSE; 
      EMTRESTRING = FALSE;
      STDNO;
  
# THIS IS CALLED WHEN DBI IS A SOURCE DBI. IT SETS THE CYCLING BIT IN  #
#AREA INDEX TABLE, AND BUILDS SOURCE DBI RELATION ENTRIES.             #
DBI1: 
      NBRAR=NBRAR+1;         #INCREMENT NBR OF AREAS TRAVERSED# 
      BARCYCL[0]=1;          #SET CYCLING BIT#
#CHECK TARGET DBI AND NEXT SOURCE DBI IN SAME FILE                     #
      SOUAR=P<BA>;
      IF NBRAR GR 1 THEN
         BEGIN
         IF SOUAR NQ TARAR THEN 
            BEGIN 
            DIAGNOS=068;     #SOURCE DBI NOT IN SAME AREA AS PREVIOUS  #
            DIAGS;           #DBI                                      #
            END 
         END
      BWPBCP; 
#CHECK INTERNAL USAGE                                                  #
      USESIZE=ITMSIZE[0]; 
      CLASS=ITMCLASS[0];
      IF USESIZE GR 255  THEN 
         BEGIN
         DIAGNOS=071;        #DBI SIZE EXCEEDS MAXIMUM# 
         DIAGS; 
         END
#BUIDL RELATION ENTRY                                                  #
      RELDBIBCP[0]=BCP;      #STORE BEGINNING CHAR POSITION#
      RELDBIBWP[0]=BWP;      #STORE BEGINNING WORD POSITION#
      RELRANKS[0]=RELRANKS[0]+1; #STORE NBR OF RANKS# 
      RELDBIAREADR[0]=AREAPTR; #STORE SUBSCHEMA AREA ENTRY# 
     IF NBRAR EQ 1 THEN      #STORE REC ADDR ON SOURCE DBI FOR         #
      BEGIN                  #  FIRST JOIN ITEM ONLY. # 
      RELDBIRECADR[RELDBIRECIDX]=RECPTR;  #STORE REC PTR OF JOIN DBI IN#
                                          #ARRAY RELDBITBL             #
      RELDBIRECIDX=RELDBIRECIDX+1;   #INCREMENT BY 1# 
      END 
      RELDBIITMADR[0]=ITMPTR; #STORE SUBSCHEMA ITEM ENTRY#
      STDNO;
  
# BUILD TARGET DBI RELATION ENTRIES                                    #
DBI2: 
#CHECK FOR CYCLING                                                     #
      IF BARCYCL[0] EQ 1  THEN
         BEGIN
         DIAGNOS=065;        #CYCLING NOT ALLOWED#
         DIAGS; 
         END
#CHECK SOURCE DBI AND TARGET DBI NOT IN SAME FILE                      #
      TARAR=P<BA>;
      IF SOUAR EQ TARAR THEN
         BEGIN
         DIAGNOS=069;        #SOURCE AND TARGET DBI IN SAME AREA# 
         DIAGS; 
         END
#BUILD RELATION ENTRY                                                  #
      RELDBIAREADR[1]=AREAPTR;
      RELDBIRECADR[RELDBIRECIDX]=RECPTR;  #STORE REC PTR OF JOIN DBI IN#
                                          #ARRAY RELDBITBL             #
      RELDBIRECIDX=RELDBIRECIDX+1;   #INCREMENT BY 1# 
      RELDBIITMADR[1]=ITMPTR; 
      BWPBCP; 
#CHECK INTERNAL SIZE                                                   #
      IF USESIZE NQ ITMSIZE[0] OR CLASS NQ ITMCLASS[0] THEN 
         BEGIN
         DIAGNOS=070;        #SOURCE AND TARGET DBI DIFFERENT IN SIZE#
         DIAGS; 
         END
      RELDBIBCP[1]=BCP; 
      RELDBIBWP[1]=BWP; 
      P<RELATIONENTR>=P<RELATIONENTR>+2; #ADVANCE RELATION ENTRIES# 
      P<RESTRICTHEAD>=P<RELATIONENTR>; #SET RESTRICT CLAUSE HEAD ENTRY# 
      P<RESTRICTCHAR>=P<RESTRICTHEAD>+1;
      J=P<RELATIONENTR>+1;
      CHKFL(J);              #CHECK NEW ENTRIES WILL LIE WITHIN FL# 
      STDNO;
  
# THIS PROC WRITES LAST RELATION AND RESTRICT ENTRIES TO SUBSCHEMA AND #
#UPDATES PTR IN RELATION INDEX, AREA INDEX AND SCHEMA BLOCK AND THEN   #
#WRITES THEM TO SUB-SCHEMA FILE.  IT WILL CALL QUDRTN5 TO LOAD AND     #015920
#EXECUTE OVERLAY (3,5)                                                 #015930
#NEW ENTRIES WILL NOT BE WRITTEN TO SUBSCHEMA IF THERE IS ANY E OR C   #
#SYNTAX ERROR                                                          #
                                                                        015950
ENDR:                                                                   015960
      IF ENDCOMP EQ 1 THEN
        BEGIN 
        RETNZZ;              # CLOSE AND UNLOAD SUBSCHEMA SCRATCH FILE #015980
        ABRT4;
        END 
      L=P<RELATIONINDX>-RELATIONBASE; #LENGTH OF RELATION INDEX TABLE#
      SBRLINDXLG[0]=L;
      SBRLINDXPTR[0]=WRITEWORD; #RELATION ENTRY IN SUBSCHEMA# 
      SRELINDXADR[0] = SBRLINDXPTR[0];  # WA OF RELATION INDEX TABLE   #016000
      SRELINDXLEN[0] = SBRLINDXLG[0];  # LENGTH OF RELATION INDEX TABLE#016010
      P<BA>=RELATIONBASE; 
      PUTENT(P<BA>,L,WRITEWORD);  #WRITE RELATION INDEX TO SUBSCHEMA# 
      WRITEWORD=WRITEWORD+L;
      L=SBARINDXLG[0];
      P<BA>=AREAINDX; 
      SBARINDXPTR[0]=WRITEWORD; #AREA INDEX ENTRY IN SUBSCHEMA# 
      SAREAINDXADR[0] = SBARINDXPTR[0];  # WA OF AREA INDEX TABLE      #016030
      SAREAINDXLEN[0] = SBARINDXLG[0];   # LENGTH OF AREA INDEX TABLE  #016040
      PUTENT(P<BA>,L,WRITEWORD); #WRITE AREA INDEX BACK TO SUBSCHEMA# 
      WRITEWORD=WRITEWORD+L;
      PUTENT(LOC(SBWORD),2,3); #WRITE SCHEMA BLOCK BACK TO SUBSCHEMA   #
*IF DEF,DEBUG1
      SNATCHF;
*ENDIF
      QUDRTN5;                     # LOAD AND EXECUTE OVERLAY (3,5)    #016060
#                                                                      #
# LABEL -GETNAME-                                                      #
# ENTER WITH                                                           #
#    PRIMARY ITEM NAME, QUALIFIER NAMES, AND SUBSCRIPTS IN             #
#      ARRAY -FILEDN-                                                  #
# ABNORMAL EXIT TO -STDNO- IF ERROR CONDITION, AFTER CALLING -DIAGS-   #
# NORMAL EXIT TO -STDYES- (AFTER -GETNAMEND-) WITH                     #
#    ARRAY -FIELDN- AS ON ENTRY, WITH WA OF ITEM ENTRIES IN            #
#      FIELD -FNADDR-                                                  #
#    BUFFER (ADDRESS IN -AREABUFF-) CONTAINS DIRECTORY ENTRY FOR       #
#      THE RECORD OF THE PRIMARY ITEM                                  #
#                                                                      #
#    LOOP THRU THE HASH TABLES FOR EACH OF THE AREAS UNTIL ONE IS FOUND#
# HAVING A NON-ZERO HASH VALUE FOR THE PRIMARY ITEM NAME.              #
#    CALL PROC -CKQUALIFIERS- TO VERIFY THAT THE ITEM AS QUALIFIED     #
# EXISTS AND IS UNIQUE IN THIS AREA.                                   #
#    IF THE ITEM NAME EXISTS IN OTHER AREAS, CONTINUE TO LOOP THRU     #
# HASH TABLES, VERIFYING THAT THE ITEM AS QUALIFIED IS UNIQUE IN       #
# ALL AREAS.                                                           #
#                                                                      #
 GETNAME: 
      ALLFOUND = FALSE;      #INITIALIZE.#
      ALLEXCEPTSUB = FALSE;  #INITIALIZE. # 
      UNIQUENAME = FALSE;    #INITIALIZE.#
# LOOP THRU HASH TABLES.  END OF HASH TABLES WHEN AHASHPTR = 0.        #
      FOR HASHTABLINDX = 0 STEP 1 WHILE AHASHPTR[HASHTABLINDX] NQ 0 DO
        BEGIN 
        P<BFN> = LOC(FIELDN);#ITEM NAME, TO PASS TO HASH ROUTINE.#
        P<HASHTBL> = AHASHPTR[HASHTABLINDX];  #SET UP HASH TABLE.#
        I = (FNLG[1] + 9) / 10;   #LENGTH OF NAME, ROUNDED UP TO WORDS.#
        WRDADDR = DHASH(BFN,I,HASHTBL);   #GET HASH VALUE FOR ITEM NAME#
        IF WRDADDR EQ 0 THEN #HASH = 0. ITEM NAME NOT IN THIS AREA. # 
          TEST;              #LOOP TO NEXT AREA HASH TABLE.#
        GETAREAENTRY(HASHTABLINDX);   #READ UP AREA ENTRY FROM DIREC. # 
        CKQUALIFIERS;        #VALIDATE QUALIFIER ITEMS. # 
        IF UNIQUENAME THEN   #PRIMARY ITEM NAME NOT IN OTHER AREAS. # 
          GOTO GETNAMEND; 
        END #OF HASH TABLES LOOP. # 
      HASHTABLINDX = HASHTABLINDX - 1; #BACK TO LAST GOOD TABLE INDEX. #
 GETNAMEND: 
      IF NOT ALLFOUND THEN
       IF ALLEXCEPTSUB THEN 
         DIAGNONO(081);      #SUBSCRIPTABLE QUALIFIER OMITTED. #
       ELSE 
        DIAGNONO(074);       #ITEM NOT DEFINED. # 
      IF HASHTABLINDX NQ SAVEAREAORD THEN 
        GETAREAENTRY(SAVEAREAORD);  #RESTORE AREA ENTRY OF MATCH. # 
      IF MULTIREC[0] THEN    #MULTIPLE RECORD TYPES IN THIS AREA.      #
      BEGIN 
      DIAGNOS = 067;
      DIAGS;
      END 
      CKSUBSCRIPTS;          #VALIDATE SUBSCRIPTS. #
# RESET ITEM ARRAY AND ITEM POINTER WORD TO VALUE FOR PRIMARY ITEM.    #
      P<ITEMENTRY> = FNADDR[1];  #RESET TO PRIMARY ITEM INFO. # 
      ITMPTR = FNADDR[1] + RECPTR - AREABUFF;    #RECOVER RELATIVE ADDR#
      STDYES; 
  
  
# THIS PROC STORES AREA INDEX TABLE AND HASH TABLES FROM QU SUBSCHEMA  #
#TO CORE AD ADDRESS OLD65 AND IT THEN ZEROS OUT THE UNUSED CORE AND    #
#SETS THE BASE ARRAYS FOR RELATION ENTRIES.                            #
INITR:  
#MOVE AREAINDEX TABLE FROM SUBSCHEMA TO CORE                           #
      P<RA>=0;
      AREAINDX=OLD65; 
#ZERO OUT THE ENTIRE UNUSED CORE                                       #
      P<RA>=AREAINDX; 
      FL=B<30,30>DDLMEM;
      FOR I=0 STEP 1 UNTIL FL-AREAINDX DO RAW[I]=0; 
      P<BA>=AREAINDX; 
      GETENT(LOC(SBWORD),2,3);
      L=SBLG[0]-SBARINDXPTR[0]; #LG OF AREA INDEX#
      J=SBARINDXPTR[0];      #ADDR OF AREA INDEX IN SUBSCH8NA#
      CHKFL(P<BA>+L);        #CHECK BUFFER BIG ENOUGH FOR AREA         #
                             #INDEX TABLE                              #
      GETENT(P<BA>,L,J);
      WRITEWORD=SBARINDXPTR[0]; #ADDRESS IN QUSUBSCHEMA WHERE RELATION #
                                #ENTRY STARTS                          #
#PRESET HASH TABLE ARRAY                                               #
      FOR I=0 STEP 1 UNTIL 63 DO AHASHPTR[I]=0; 
      P<RA>=AREAINDX; 
#STORE ALL HASH TABLES IN CORE FROM SUBSCHEMA  FOLLOWING AREA INDEX    #
#TABLE                                                                 #
      P<BA>=AREAINDX; 
      HASHADDR=AREAINDX+L;
      K=HASHADDR; 
      FOR   M=0 STEP 1 UNTIL 63 DO
#MOVE ALL HASH TABLES FROM SUBSCHEMA TO CORE AND STORE HASH TABLE      #
#POINTERS IN ARRAY AHASHTBLE                                           #
         BEGIN
         AREADESADD=BARPTR[0];
         GETENT(LOC(AREAENTRY),2,AREADESADD);  #GET HASH TABLE POINTER# 
         I=AREADESADD+HASHPTR[0];  #ADDR OF HASH TABLE# 
         GETENT(LOC(J),1,I);     #GET LENGTH OF HASH TABLE# 
         J=J+10;             #HASH TABLE LENGTH + 10# 
         P<RA>=K; 
         CHKFL(P<RA>+J);     #CHECK BUFFER BIG ENOUGH FOR HASH TABLE   #
         GETENT(P<RA>,J,I);  #STORE HASH TABLE IN CORE                 #
         AHASHPTR[M]=P<RA>;  #STORE HASH TABLE POINTER IN ARRAY        #
         P<BA>=P<BA>+BARNAMLG[0]+1; 
         K=K+J; 
         IF P<BA> GQ HASHADDR THEN M=63; #FORCE LOOP ENDING#
         END
      AREABUFF=K;            #CORE ADDR FOR REC ENTRIES#
      NBRRL=0;               #INITIALISE NBR OF RELATIONS#
      RELATIONBASE=AREABUFF+AREALG;  #CORE ADDR FOR RELATION ENTRIES# 
*IF DEF,DEBUG1
         SNATCHO("AREAINDX",AREAINDX);
         SNATCHO("AREABUFF",AREABUFF);
         SNATCHO("HASHADDR",HASHADDR);
         SNATCHO("RELATIONBASE",RELATIONBASE);
         SNATCHO("AREALG",AREALG);
*ENDIF
      STDNO;
  
#STORE CURRENT DATA NAME IN ARRAY FIELDN                               #
ITMNAM: 
      FIELDNAMELG=FIELDNAMELG+1; #INCREMENT LEVEL OF QUAL#
      IF FIELDNAMELG GR FIELDNAMEMAX THEN 
         DIAGNONO(062);      #MAX QUALIFICATION LEVEL REACHED. #
      FN[FIELDNAMELG]=CWC[0]; 
      FN1[FIELDNAMELG]=CWC[1];
      FN2[FIELDNAMELG]=CWC[2];
      FNLG[FIELDNAMELG]=CURLENG;
      STDYES; 
  
# ACCUMULATES LEFT PARENTHESIS FOR RESTRICT CLAUSE                     #
OPENPAR:  
      OPENP=OPENP+1;         #INCREMENT BY 1# 
      STDYES; 
  
# SET RESTRICT FLAG AND STORE RECORD NAME OF RESTRICT CLAUSE IN  ARRAY #
#RECORDNAME                                                            #
RECNAME:  
    RESFLAG=TRUE;            #SET NOW CRACKING RESTRICT CLAUSE FLAG#
      RELTRFLAG=TRUE;        #SET CALL PROC RELTRVSD FLAG#
      NBRRES=NBRRES+1;       #ACCUMULATE NBR OF RESTRICT CLAUSES# 
      AA=0;                  #SET RECEIVER CHAR POSITION FOR RESTRICT  #
                             #CLAUSE                                   #
      GETCURNAM(CWRD);
      FOR I=0 STEP 1 UNTIL 2 DO RECNAM[I]="          "; #PRESET ARRAY#
      FOR I=0 STEP 1 UNTIL CURLENW-1 DO 
         RECNAM[I]=CWC[I];   #STORE RESTRICT CLAUSE RECORD NAME#
      STDYES; 
  
#TO CHECK RECORD IN THE AREA TRAVERSED BY THE RELATION                 #
#AND TO CHECK ONLY ONE RESTRICT CLAUSE FOR THE RECORD                  #
RELTRVSD: 
      IF NOT RELTRFLAG THEN STDYES; 
      RELTRFLAG=FALSE;
      FOR I=CURRENTRANK STEP 1 WHILE RELDBIRECADR[I] NQ RECPTR DO 
         IF I GQ RELDBIRECIDX THEN   #REACHED LAST JOIN  DBI REC ENTRY #
                                     #IN ARRAY RELDBITBL               #
            DIAGNONO(084);   #RECORD NOT IN AREA TRAVERSED BY RELATION #
      IF RELDBIRESFLG[I] THEN 
         DIAGNONO(085);      #MORE THAN ONE RESTRICT CLAUSE FOR RECORD #
      RELDBIRESFLG[I]=TRUE;  #SET FLAG FOR RECORD HAS RESTRICT CLAUSE  #
      CURRENTRANK = I + 1;   #ONLY GO THRU TABLE ONCE.  SAVE POSITION. #
      STDYES; 
  
#RESET ARRAY FIELDN                                                    #
RESETNAM: 
      FOR I=1 STEP 1 UNTIL FIELDNAMEMAX DO
         BEGIN
         FN[I]="          ";
         FN1[I]="          "; 
         FN2[I]="          "; 
         FN3[I]=0;
         END
      FIELDNAMELG=0;         #RESET LEVEL NUMBER TO 0#
      STDYES; 
  
# SET SOURCE DBI FLAG                                                  #
SOURCEDBI:  
      SOUDBI=TRUE;
      STDNO;
  
# THIS PROC CHECKS THE UNIQUENESS OF RELATION NAME AMONG ALL AREA AND  #
#OTHER RELATION NAMES. IT ALSO STORES RELATION NAME IN RELATION INDEX  #
#TABLE AND SETS BASE ARRAYS FOR RELATION ENTRIES.                      #
STRN: 
      IF CURLENG GR 30 THEN 
         BEGIN
         DIAGNOS=060;        #RELATION NAME GR 30 CHARS  #
         DIAGS; 
         END
      GETCURNAM(CWRD);
#CHECK WHETHER RELATION NAME IS UNIQUE AMONG ALL AREA NAMES            #
      P<RA>=AREAINDX; 
      FOR M=0 STEP 1 WHILE P<RA> LS HASHADDR DO 
         BEGIN
         FOR I=0 STEP 1 UNTIL  CURLENW-1 DO 
            IF RAW[I+1] NQ CWD[I] THEN GOTO AREANOEQUAL;
         DIAGNOS=061;        #RELATION NAME NOT UNIQUE AMONG AREA NAMES#
         DIAGS; 
         GOTO SETENTRY; 
AREANOEQUAL:  
         P<RA>=P<RA>+B<0,6>RAW[0]+1; #GET NEXT AREA NAME# 
         END
      P<RELATIONINDX>=RELATIONBASE; 
      L=RELNAMELEN[0];
      IF NBRRL NQ 0 THEN
         BEGIN
#CHECK UNIQUENESS OF RELATION NAME                                     #
         FOR J=1 STEP 1 UNTIL NBRRL DO
            BEGIN 
            FOR I=0 STEP 1  UNTIL CURLENW-1 DO
          IF RELNAME[I+1] NQ CWC[I] THEN GOTO RELANOEQUAL;
            DIAGNOS=061;     #RELATION NAME NOT UNIQUE AMONG OTHER     #
            DIAGS;           #RELATION NAMES                           #
            GOTO SETENTRY;
RELANOEQUAL:  
            P<RELATIONINDX>=P<RELATIONINDX>+L+1; #GET NEXT RELATION NAM#
            L=RELNAMELEN[0];
            END 
         END
#STORE RELATION NAME                                                   #
      RELNAMELEN[0]=CURLENW;
      FOR I=0 STEP 1 UNTIL CURLENW-1  DO RELNAME[I+1]=CWC[I]; 
SETENTRY: 
      AA=0; 
      NBRAR=0;
      NBRRES=0; 
      NBRRL=NBRRL+1;         #ACCUMULATES NBR OF RELATIONS# 
      RELDBIRECIDX=0;        #INITIALISE# 
      FOR I=0 STEP 1 UNTIL 64 DO
         RELDBIRECTBW[I]=0;  #INTIALIZE#
      CURRENTRANK = 0;
      RELENTRYADR[0]=WRITEWORD; 
# ADVANCE RELATION AND RESTRICT BASE ARRAYS                            #
      P<RELATIONINDX>=P<RELATIONINDX>+CURLENW+1;
      P<RELATIONHEAD>=P<RELATIONINDX>;
      P<RELATIONENTR>=P<RELATIONHEAD>+1;
      P<RESTRICTHEAD> = P<RELATIONENTR>;
      P<RESTRICTCHAR> = P<RESTRICTHEAD> + 1;
      J=P<RELATIONENTR>+1;
      CHKFL(J); 
      STDNO;
  
# THIS PROC CONVERTS SUBSCRIPT FROM DISPLAY CODE TO BINARY INTEGER     #
SUB1: 
      DISPINT=B<0,(CHARCNT*6)>CWD[0]; #DISPLAY INTEGER# 
      INTCNT=CHARCNT;        #NBR OF CHAR#
      XDTB;                  #CONVERT DISPLAY INTEGER TO BINARY INTEGER#
      FNSUB[FIELDNAMELG]=XDTBRSLT; #STORE BINARY INEGER IN FIELDN#
      STDNO;
  
# THIS SETS TARGET DBI FLAG                                            #
TARGETDBI:  
      TARDBI=TRUE;
      STDNO;
  
# THIS PROC CHECKS ITEM CLASS COMPATABLE WITH LITERALS INPUTED FOR THE #
#DATA NAME. IF NOT DIAG WILL BE ISSURED                                #
VERIFYLIT:  
      P<ITEMENTRY>=FNADDR[1]; #DATA NAME ENTRY# 
      IF ITMCLASS[0] GQ 1 AND ITMCLASS[0] LQ 5
         THEN                #ITEM CLASS IS NUMERIC BUT NOT COMPLEX    #
         IF CURTYPE LS 106   #IF NON-NUMERIC                           #
            OR CURTYPE EQ 109 #IF COMPLEX                              #
               THEN DIAGNONO(083);
      IF ITMCLASS[0] EQ 6    #ITEM CLASS IS COMPLEX                    #
         THEN IF CURTYPE LS 106  #IF NON-NUMERIC                       #
               THEN DIAGNONO(083);
      IF ITMCLASS[0] EQ 0 AND CURTYPE GR 106 THEN DIAGNONO(083);
      STDYES; 
  
#WRITE RELATION AND RESTRICT ENTRIES INTO SUBSCHEMA                    #
WRITERES:   
      J=P<RESTRICTCHAR>-P<RESTRICTHEAD>;
      IF J EQ 1 AND AA EQ 0 THEN  #NO RESTRICT CLAUSE#
         L=P<RELATIONENTR>-P<RELATIONHEAD>; 
         ELSE 
         BEGIN
         L=P<RESTRICTCHAR>-P<RELATIONHEAD>; 
         IF AA NQ 0 THEN L=L+1; 
         RELRESTADR[0]=WRITEWORD+P<RELATIONENTR>-P<RELATIONHEAD>; 
         RESRECADR[0]=RECPTR; 
      RESRANK[0] = CURRENTRANK; 
         RELNBRRES[0]=NBRRES; #STORE NBR OF RESTRICT CLAUSES IN        #
                              #RELATION ENTRIES                        #
         END
      IF ENDCOMP EQ 0 THEN   #WRITE INTO SUBSCHEMA THE  RESTRICT       #
         PUTENT(P<RELATIONHEAD>,L,WRITEWORD); #CLAUSE ONLY IF NO DDL   #
                             # COMPILATION ERRORS                      #
      WRITEWORD=WRITEWORD+L; #ADJUST LAST WORD WRITTEN ADDR IN SUBSCHEM#
      P<RA>=P<RELATIONHEAD>;
      FOR I=0 STEP 1 UNTIL L-1 DO   #ZERO OUT PREVIOUS RELATION ENTRY#
         RAW[I]=0;
      STDNO;
  
#                                                                      #
#THIS ROUTINE IS TO WRITE EACH WORD OF RESTRICT CLAUSE FROM CWRD       #
#ENTRY CONDITION:                                                      #
#        AA IS THE BEGINNING CHAR POSITION WHERE NEW WORD OF RESTRICT  #
#        CLAUSE IS TO BE WRITTEN                                       #
#        CURLENG IS NBR OF CHARS IN THE WORD. ALWAYS WRITE CURLENG+1   #
#        CHARS SO A BLANK CHAR IS WRITTEN AT END OF EACH WORD          #
#                                                                      #
WRITEWRD: 
      IF CURTYPE GR 102 AND CURTYPE LS 106 THEN  # NON-NUMERIC LITERAL #
         BEGIN               #INSERT QUOTES FOR NON-NUMERIC LITERAL IN #
                             #ARRAY CWRD                               #
         CWC1[0]=O"64";      #INSERT FIRST QUOTE                       #
         CURLENG=CURLENG+1; 
         I=CURLENG/10;       #IN WHICH CWRD WORD                       #
         J=CURLENG-I*10;     #IN WHICH CHAR                            #
         C<J,1>CWD[I]=O"64"; #INSERT SECOND QUOTE                      #
         CURLENG=CURLENG+1; 
         END
         ELSE 
         GETCURNAM(CWRD); 
      IF NOT  RESFLAG THEN STDNO; #NOT IN RESTRICT CLAUSE              #
      II=0; 
      I=0;
      J=CURLENG+1;           #NUMBER OF CHARS TO BE WRITTEN            #
      FOR M=0 STEP 1 WHILE J GR 0 DO
         BEGIN
         CHKFL(P<RESTRICTCHAR>);  #CHECK WITHIN FL                     #
         L=10-AA;            #CHAR LENGTH AVAILABLE IN RECEIVER WORD   #
         C<AA,L>RESCHARSTRNG[0]=C<I,10-I>CWC[II]; 
#MINIMUM OF L, 10-I, AND J = NUMBER OF CHARS ACTUALLY WRITTEN          #
         IF L GR J THEN L=J;
         IF L GR 10-I THEN
            L=10-I;          #NUMBER OF CHARS ACTUALLY WRITTEN         #
         K=AA+L;
         J=J-L;              #NUMBER OF CHARS STILL NEEDED WRITTEN     #
         IF K GQ 10 THEN     #REACHED RECEIVER WORD BOUNDARY           #
            BEGIN 
            P<RESTRICTCHAR>=P<RESTRICTCHAR>+1;
            AA=0; 
            END 
            ELSE
            BEGIN 
            IF J GR 0 THEN   #MORE CHARS IN SOURCE WORD                #
               AA=AA+L; 
               ELSE 
               AA=K;
            END 
         I=I+L;              #ADJUST SOURCE WORD CHAR POSITION         #
         IF I GQ 10 THEN     #REACHED SOURCE WORD BOUNDARY             #
            BEGIN 
            I=0;
            II=II+1;
            END 
         END
      EMTRESTRING = FALSE;                                               D2A147A
      RESENTRLENG[0]=P<RESTRICTCHAR>-P<RESTRICTHEAD>; 
                             #LENGTH OF RESTRICT ENTRIES               #
      IF AA EQ 0 THEN        #NOTHING IN THIS WORD YET                 #
         BEGIN
         EMTRESTRING = TRUE;
         RESENTRLENG[0]=RESENTRLENG[0]-1; 
         END
      STDNO;
  
#SET FLAG AND BASED ARRAY FOR NEXT RESTRICT CLAUSE                     #
WRTRESET: 
      RESNEXTFLAG[0]=TRUE;
      RESRECADR[0]=RECPTR;
      RESRANK[0] = CURRENTRANK; 
      IF EMTRESTRING
      THEN P<RESTRICTHEAD> = P<RESTRICTCHAR>; 
      ELSE P<RESTRICTHEAD> = P<RESTRICTCHAR> + 1; 
      EMTRESTRING = FALSE;
      P<RESTRICTCHAR>=P<RESTRICTHEAD>+1;
      STDNO;
      END 
      TERM; 
