*COMDECK     COMAPKEY  - COMPILE KEY ITEM MAPPING CODE CAPSULE. 
#*        MAPKEY  -  COMPILE KEY ITEM MAPPING CODE CAPSULE. 
* 
*         R. H. GOODELL.     77/02/18.
* 
*         *MAPKEY* CONTROLS THE COMPILATION OF A CODE CAPSULE TO
*         PERFORM CONVERSION OF INDIVIDUAL DATA ITEMS FROM SUB- 
*         SCHEMA FORMAT TO SCHEMA FORMAT, AS WHEN SETTING AN ITEM 
*         AS A RECORD KEY FOR RANDOM ACCESS, OR WHEN COMPARING AN 
*         ITEM WITH A USER DATA ITEM IN APPLYING A *RESTRICT* 
*         CLAUSE TO A RELATION. 
* 
*         ON ENTRY, *SSAP* POINTS TO THE AREA ENTRY IN THE SUB- 
*         SCHEMA DIRECTORY IN *TSUB*, AND *RLMI* IS THE REALMLIST 
*         INDEX FOR THE CURRENT REALM.
* 
*         THE CAPSULE GENERATED BEGINS WITH A TWO-LEVEL INDEXED 
*         JUMP TO THE PROPER CODE ROUTINES.  THE REMAINDER OF 
*         THE CAPSULE CONSISTS OF ONE MAPPING ROUTINE FOR EACH
*         ITEM IDENTIFIED IN THE SUB-SCHEMA AS A PRIMARY KEY, AN
*         ALTERNATE KEY, A MAJOR KEY, OR AN ITEM THAT IS COMPARED 
*         WITH A USER DATA-NAME IN A RESTRICT ENTRY.
* 
*         CONTENTS (XDEF ENTRY POINTS). 
* 
*         PROC   MAPKEY      COMPILE KEY ITEM MAPPING CODE CAPSULE. 
# 
  
  
*CALL     COMDDEF            GENERAL DEFINITIONS. 
  
     XREF BEGIN               # MANAGED TABLES #
  
*CALL     COMDTCON           CONSTANT VALUES. 
  
*CALL     COMDTDBP           DATA BASE PROCEDURES.
  
*CALL     COMDTEMP           TEMPORARY VARIABLES. 
  
*CALL     COMDTEPT           ENTRY POINTS.
  
*CALL     COMDTEXT           EXTERNAL NAMES.
  
*CALL     COMDTITM           KEY ITEM JUMP INDICES. 
  
*CALL     COMDTKEY           KEY ITEM JUMP VECTOR.
  
*CALL     COMDTLIT           LITERALS.
  
*CALL     COMDTREC           RECORD TYPE JUMP VECTOR. 
  
*CALL     COMDTREF           REFERENCES TO EXTERNALS (PASS 1).
  
*CALL     COMDTSCH           SCHEMA DIRECTORY (CURRENT PORTION).
  
*CALL     COMDTSUB           SUB-SCHEMA DIRECTORY + FINISHED CAPSULES.
  
*CALL     COMDTSYM           SYMBOL TABLE.
  
*CALL     COMDTXEQ           EXECUTABLE CODE + PSUEDO OPS (INTERMEDIATE)
  
*CALL     COMDTVAR           VARIABLES AND APLISTS (INTERMEDIATE).
  
          END 
*CALL     COMDREG            REGISTER INFORMATION.
  
     XREF BEGIN               # OTHER EXTERNALS # 
  
*CALL     COMDHEAD           CAPSULE HEADER TABLE.
*CALL     COMDPRFX           CAPSULE PREFIX TABLE.
          ITEM C$FKA ;             # CODE -   FETCH X1,KA,X7 #
          ITEM C$SKA ;             # CODE -   STORE X1,KA=X6 #
          ITEM C$SKL ;             # CODE -   STORE X1,KL=X6 #
          ITEM C$SKTF ;            # CODE -   STORE X1,KT=F # 
          ITEM C$SKTI ;            # CODE -   STORE X1,KT=I # 
          ITEM C$SKTS ;            # CODE -   STORE X1,KT=S # 
          ITEM C$SMKL;             # CODE -   STORE X1,MKL=X6 # 
          ITEM C$SRKP ;            # CODE -   STORE X1,RKP=X6 # 
          ITEM C$SRKW ;            # CODE -   STORE X1,RKW=X6 # 
          ITEM GETF B ;            # TRUE WHEN GENERATING READ MAPPING #
          ITEM GROUP ;             # BIT MASK FOR GROUP DATA TYPES #
          ITEM NEXT ;              # NEXT SUB-SCHEMA ITEM POINTER # 
          ITEM NREC ;              # NUMBER OF RECORDS IN REALM # 
          ITEM QBUF ;              # NAME OF SCRATCH BUFFER AREA FWA #
          ITEM QSRA ;              # NAME OF SOURCE RECORD AREA FWA # 
          ITEM QTRA ;              # NAME OF TARGET RECORD AREA FWA # 
          ITEM RECI ;              # RECORD LIST INDEX #
          ITEM RIBF B ;            # RESULT IN BUFFER FLAG #
          ITEM RLMI ;              # REALM LIST INDEX # 
          ITEM SBBP ;              # SOURCE BEGINNING BIT POSITION #
          ITEM SBWP ;              # SOURCE BEGINNING WORD POSITION # 
          ITEM SCIP ;              # SCHEMA ITEM ENTRY POINTER #
          ITEM SCNI ;              # NUMBER OF ITEMS IN SCHEMA RECORD # 
          ITEM SI ;                # SOURCE ITEM INDEX #
          ITEM SSAP ;              # SUB-SCHEMA REALM ENTRY POINTER # 
          ITEM SSIO ;              # SUB-SCHEMA ITEM ORDINAL #
          ITEM SSIP ;              # SUB-SCHEMA ITEM ENTRY POINTER #
          ITEM SSNI ;              # NUMBER OF ITEMS IN SUB-SCHEMA REC #
          ITEM SSRP ;              # SUB-SCHEMA RECORD ENTRY POINTER #
          ITEM SSRQ ;              # SUB-SCHEMA RECORD ENTRY LWA+1 #
          ITEM SW ;                # SOURCE WORD INDEX #
          ITEM TBBP ;              # TARGET BEGINNING BIT POSITION #
          ITEM TBWP ;              # TARGET BEGINNING WORD POSITION # 
          ITEM TI ;                # TARGET ITEM INDEX #
          ITEM TLEV ;              # TARGET ITEM LEVEL-NUMBER # 
          ITEM TW ;                # TARGET WORD INDEX #
          ITEM  VECTOR ;           # BIT MASK FOR VECTOR DATA TYPES # 
          ITEM X$MBUF ;            # NAME OF KEY MAPPER SCRATCH BUF FWA#
          ITEM X$MDNA ;            # NAME OF DATA NAME ADDRESS (RES) #
          ITEM X$MFIT ;            # NAME OF FILE INFO TABLE FWA #
          ITEM X$MIOR ;            # NAME OF ITEM ORDINAL (KEY/RES) # 
          ITEM X$MKEY ;            # NAME OF KEY MAPPER MODE FLAG # 
          ITEM X$MRBF ;            # NAME OF RESULT IN BUFFER FLAG #
          ITEM X$MROR ;            # NAME OF RECORD ORDINAL (KEY/RES) # 
          ITEM X$MSUB ;            # NAME OF SUB-SCHEMA RECORD AREA FWA#
          PROC ALLOC ;             # ALLOCATE TABLE SPACE # 
          PROC ASU ;               # ACCUMULATE STORAGE USED #
          PROC BDL ;               # BUILD DBP LIST # 
          PROC CRA ;               # CLEAR REGISTER ASSOCIATES #
          PROC DSR ;               # DEPOSIT STORE REGISTER # 
          PROC FINDREC ;           # GET CURRENT RECORD ENTRIES # 
          FUNC FO$AK B ;           # TRUE IF FIT CONTAINS FO=AK # 
          FUNC FO$IS B ;           # TRUE IF FIT CONTAINS FO=IS # 
          PROC GDC ;               # GENERATE DBP CALL #
          PROC GIC ;               # GENERATE ITEM CONVERSION CODE #
          PROC GXR ;               # GET X-REGISTER WITH SPECIFIED VAL #
          PROC ISSUE ;             # ISSUE INSTRUCTION TO INTERMEDIATE #
          FUNC LITCH I ;           # CHARACTER STRING (H) LITERAL # 
          FUNC LITCL I ;           # ITEM DATA CLASS CODE LITERAL # 
          FUNC LITCPLX I ;         # COMPLEX NUMBER LITERAL # 
          FUNC LITDP I ;           # DOUBLE PRECISION NUMBER LITERAL #
          FUNC LITFP I ;           # FLOATING POINT NUMBER LITERAL #
          FUNC LITINT I ;          # INTEGER LITERAL #
          FUNC LITOCT I ;          # OCTAL LITERAL #
          FUNC LITSI I ;           # SHORT INTEGER LITERAL #
          PROC PUNT ;              # PROCESS INTERNAL ERROR # 
          PROC SAR ;               # SET SPECIFIED A-REGISTER TO VALUE #
          PROC SXR ;               # SET SPECIFIED X-REGISTER TO VALUE #
          FUNC SYN I ;             # SYMBOL NAME NUMBER # 
          PROC XCDDL ;             # CONVERT TO DECIMAL LEFT JUSTIFIED #
  
          END 
  
  
*CALL     COMDCF             CONSTANT FORMATS.
  
  
*CALL     COMDDBPE           DATA BASE PROCEDURE ENTRY CODES. 
  
  
*CALL     COMDITEM           ITEM CLASS AND TYPE CODES. 
  
  
*CALL     COMDOPS            OPERATION CODES. 
  
  
*CALL     COMDPSOP           PSEUDO OPERATION ISSUING DEFS. 
  
  
#         LOCAL DATA. 
# 
          ITEM A C (WC) ;          # CHARACTER TEMPORARY #
          ITEM I, J, K, L, M, N ;  # INTEGER TEMPORARIES #
          ITEM DBPF B ;            # TRUE IF ITEM IS RESULT OF A DBP #
          ITEM GICL ;              # LABEL OF ITEM CONVERSION CODE #
          ITEM ITMX ;              # KEY ITEM INDICES LABEL TSYM INDEX #
          ITEM KEYF B ;            # TRUE IF CURRENT ITEM IS A KEY #
          ITEM KEYJ ;              # KEY ITEM SWITCH LABEL TSYM INDEX # 
          ITEM KIRC ;              # KEY ITEM ROUTINE COUNT # 
          ITEM MKEL ;              # MAJOR KEY EXIT LABEL              #
          ITEM RECJ ;              # RECORD SWITCH LABEL TSYM INDEX # 
          ITEM RECS ;              # SYMBOL TABLE OFFSET TO FIRST REC.X#
          ITEM RECZ ;              # SYMBOL TABLE OFFSET TO -RECORDT-  #
          ITEM RESF B ;            # TRUE IF CURRENT ITEM IS A RESTRICT#
          ITEM SSLP ;              # LATEST SUB-SCHEMA ITEM POINTER # 
          ITEM W ;                 # CURRENT VFD WORD # 
  
  
  
  
#***      MAPKEY  -  COMPILE KEY ITEM MAPPING CODE CAPSULE. 
  
          PROC MAPKEY 
  
*         A KEY MAPPING CAPSULE BEGINS WITH A PROLOGUE THAT DOES
*         THE FOLLOWING.
*         -  EXTRACT KA FROM THE FIT, OR FETCH DB$MDNA, AND 
*            SAVE IN DB$MSUB. 
*         -  IF THE REALM HAS JUST ONE RECORD TYPE THEN JUMP
*            TO *REC.1*, ELSE USE A JUMP VECTOR TO GO TO *REC.N*
*            WHERE N IS OBTAINED FROM THE CONVERSION TABLE *RECORDT*. 
*            THE TABLE *RECORDT* CONTAINS A LIST OF VALID RECORD
*            ORDINALS FROM THE REALM LIST.  THEY ARE CONTAINED IN 
*            TWELVE BIT BYTES FROM RIGHT TO LEFT IN SUCCESSIVE WORDS. 
*            N IS THE INDEX INTO THE TABLE TO LOCATE THE RECORD 
*            ORDINAL SPECIFIED IN DB$MROR.
*         NEXT IS THE EPILOGUE CODE, WHICH UPDATES EITHER THE 
*         KA IN THE FIT, OR THE VALUES OF DB$MDNA AND DB$MRBF,
*         AND RETURNS TO *CDCS*.
*         NEXT IS AN ITEM MAPPING ROUTINE FOR EACH DATA ITEM
*         THAT NEEDS ONE.  THE INDIVIDUAL ITEM MAPPING ROUTINES 
*         ARE ENTIRELY INDEPENDENT OF EACH OTHER.  EACH CONTAINS
*         ESSENTIALLY THE SAME CODE AS THE CORRESPONDING WRITE/ 
*         REWRITE RECORD MAPPING CODE CAPSULE BUT WITH THE
*         FOLLOWING DIFFERENCES.
*         -  THE ROUTINE CONTAINS CODE TO MAP JUST THIS ONE ITEM
*            (ALTHOUGH IT COULD BE A GROUP ITEM).  IF IT HAS
*            AN *OCCURS* CLAUSE, ONLY THE FIRST OCCURRENCE IS 
*            USED - NO LOOP CODE IS GENERATED.
*         -  IF THE ITEM IS A PRIMARY, ALTERNATE, OR MAJOR KEY, 
*            THE GENERATED CODE CONVERTS THE VALUE OF THE ITEM
*            AND ALSO CHANGES THE KL, KT, RKP, AND RKW FIELDS,
*            AS NEEDED, IN THE FIT TO REFLECT THE SCHEMA RECORD 
*            FORMAT.
*         -  IF THE ITEM IS A RECORD QUALIFIER, THE GENERATED 
*            CODE CONVERTS THE VALUE OF THE ITEM WITHOUT
*            CHANGING THE FIT.
*         -  IF THE ITEM CAN BE USED IN BOTH WAYS, THE GENERATED
*            CODE INCLUDES A TEST OF AN ARGUMENT (DB$MKEY) BY 
*            WHICH THE CALLER INDICATES WHICH KIND OF PROCESSING
*            IS WANTED. 
*         -  FOR EACH OF THE ABOVE CASES, IF THE KEY VALUE
*            CANNOT BE CONVERTED IN PLACE, THE GENERATED CODE 
*            LEAVES THE CONVERTED VALUE IN A SCRATCH AREA POINTED 
*            TO BY DB$MBUF. 
*         -  THE ONLY KINDS OF DATA BASE PROCEDURES CALLED ARE
*            THOSE FOR *ACTUAL RESULT* AND *ENCODING*.
*         AFTER ALL OF THE ITEM MAPPING ROUTINES FOR A RECORD 
*         TYPE, THE CAPSULE CONTAINS A SWITCH MECHANISM CONSISTING
*         OF THE FOLLOWING. 
*         -  THE ROUTINE *REC.N* WHICH USES THE ITEM ORDINAL
*            GIVEN AS AN ARGUMENT (DB$MIOR) TO GET A MAPPING
*            ROUTINE ORDINAL FROM THE KEY ITEM INDEX TABLE, AND 
*            USES THIS ORDINAL TO JUMP TO THE PROPER ROUTINE
*            VIA THE KEY ITEM JUMP VECTOR.
*         -  THE KEY ITEM INDEX TABLE CONTAINS M+1 ENTRIES OF 
*            LOG2 (N+1) BITS EACH, WHERE M IS THE NUMBER OF 
*            ITEMS IN THE RECORD TYPE AND N IS THE NUMBER OF
*            ITEM MAPPING ROUTINES FOR THE RECORD IN THE CAPSULE. 
*            THESE ENTRIES OCCUPY AS MANY WORDS AS NEEDED, PACKED 
*            INTO WORDS AS TIGHTLY AS POSSIBLE WITHOUT SPANNING 
*            WORD BOUNDARIES. 
*         -  THE KEY ITEM JUMP VECTOR CONTAINS ONE HALF-WORD
*            FOR EACH KEY ITEM MAPPING ROUTINE. 
*         EACH ITEM MAPPING ROUTINE ENDS BY JUMPING TO THE
*         EPILOGUE CODE MENTIONED ABOVE.
* 
*         A KEY MAPPING CODE CAPSULE CAN REFERENCE THE FOLLOWING
*         EXTERNAL SYMBOLS. 
*         PROC DB$DPII - DATABASE PROCEDURE INTERFACE, ITEM LEVEL.
*         ITEM DB$MBUF - FWA OF SCRATCH AREA FOR RESULT VALUE.
*         ITEM DB$MDNA - (DATA NAME ADDRESS) FWA OF ITEM VALUE. 
*         ITEM DB$MERF - ERROR FLAG SET BY DC$CONV ETC. 
*         ITEM DB$MFIT - FWA OF FILE INFORMATION TABLE. 
*         ITEM DB$MIOR - ITEM ORDINAL.
*         ITEM DB$MKEY - MODE FLAG -  0 = RESTRICT,  1 = KEY. 
*         ITEM DB$MRBF - OUTPUT FLAG - TRUE IF RESULT IN BUFFER.
*         ITEM DB$MROR - RECORD ORDINAL.
*         ITEM DB$MSUB - FWA OF SOURCE ITEM AREA. 
*         PROC DC$CONV - CONVERT ITEM VALUE.
*         ITEM DC$SBBP - SOURCE ITEM BEGINNING BIT POSITION.
*         ITEM DC$SBWP - SOURCE ITEM BEGINNING WORD POSITION. 
*         ITEM DC$SFWA - SOURCE ITEM FIRST WORD ADDRESS.
*         ITEM DC$TBBP - TARGET ITEM BEGINNING BIT POSITION.
*         ITEM DC$TBWP - TARGET ITEM BEGINNING WORD POSITION. 
*         ITEM DC$TFWA - TARGET ITEM FIRST WORD ADDRESS.
*         PROC DC$XFER - TRANSFER DATA. 
****
# 
          BEGIN 
  
          GETF = FALSE ;
          QSRA = X$MSUB ; 
          QBUF = X$MBUF ; 
          KIRC = 0 ;
          SI = 0 ;
          TI = 0 ;
          PRFXKIND = "KEY" ;
          CALL CRA ;                    # CLEAR REGISTER ASSOCIATES # 
  
#         GENERATE PROLOGUE CODE. 
# 
          CALL SXR (3, RK"EXV", X$MDNA, 0) ;      # GEN SA3 =XDB$MDNA  #
          CALL SXR (4, RK"EXV", X$MKEY, 0) ;      # GEN SA4 =XDB$MKEY  #
          CALL SXR (1, RK"EXV", X$MFIT, 0) ;      # GEN SA1 =XDB$MFIT  #
          ISSUE (OP"SXXB", 7, 3, 0) ;             # GEN SX7 X3         #
          I = TSYML ; 
          ISSUE (XNO, RT"SYM") ;                  # GEN ZR,X4 TAG      #
          ISSUE (OP"XC", XC"ZR", 4, I) ;
          ISSUE (C$FKA, 0, 0, 0) ;                # GEN FETCH X1,KA,X7 #
          ISSUE (XLABEL, I) ;                     # GEN TAG LABEL      #
          CALL CRA ;                              # CLEAR REG. ASSOC. # 
          CALL SAR (7, RK"EXT", QSRA, 0) ;        # GEN SA7 =XDB$MSUB  #
  
#         CONSTRUCT RECORD TYPE JUMP VECTOR.
# 
          ALLOC (P<TREC>, NREC) ;            # ALLOCATE RECORD TABLE #
          J = TSYML ; 
          RECS = TSYML ;
          ALLOC (P<TSYM>, NREC +1) ;         # RESERVE SYMBOL ENTRIES  #
          FOR  I = 1 THRU NREC  DO
               BEGIN
               CALL XCDDL (I, A, N) ;        # CONSTRUCT SYMBOL NAME #
               SYMW [J] = 0 ;                 #       REC.NNN       # 
               C<0,4> SYMW [J] = "REC." ; 
               C<4,3> SYMW [J] = A ;
               J = J + 1 ;                    # POINTING TO SYMBOL #
               END
          SYMW [J] = 0 ;
          C<0,7> SYMW [J] = "RECORDT" ;      # DEFINE SYMBOL -RECORDT- #
          RECZ = J ;
  
          IF  NREC EQ 1                      # IF ONLY ONE RECORD TYPE #
  
#         GENERATE INITIAL CODE IF NO RECORD SELECTION NEEDED.
# 
          THEN BEGIN
               ISSUE (XNO, RT"EXT") ;             # GEN SA2 =XDB$MIOR  #
               ISSUE (OP"SABK", 2, 0, X$MIOR) ; 
               ISSUE (OP"SXXK", 7, 2, -1) ;       # GEN SX7 X2-1       #
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"JP", 0, 0, RECS) ;       # GEN JP  REC.1      #
               END
  
#         GENERATE RECORD TYPE SELECTION CODE.
# 
          ELSE BEGIN                         # IF MULTIPLE RECORD TYPES#
               ISSUE (XNO, RT"EXT") ; 
               ISSUE (OP"SABK", 1, 0, X$MROR) ;   # GEN SA1 =XDB$MROR  #
               ISSUE (XNO, RT"EXT") ;             # GEN SA2 =XDB$MIOR  #
               ISSUE (OP"SABK", 2, 0, X$MIOR) ; 
               ISSUE (OP"MASK", 0, 0, 48) ;       # GEN MX0 -12        #
               ISSUE (OP"SXBK", 6, 0, 00) ;       # GEN SX6 0          #
               ISSUE (OP"MASK", 5, 0, 59) ;       # GEN MX5 -1         #
               ISSUE (OP"SXXK", 7, 2, -1) ;       # GEN SX7 X2-1       #
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"SABK", 3, 0, RECZ);      # GEN SA3 RECORDT    #
               L = TSYML ;
               ISSUE (XLABEL, L) ;                # GEN LABEL   -LOOP- #
               ISSUE (OP"ANDN", 4, 3, 0) ;        # GEN BX4 -X0*X3     #
               ISSUE (OP"ISUB", 4, 4, 1) ;        # GEN IX4 X4-X1      #
               M = TSYML ;
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"XC", XC"ZR", 4, M) ;     # GEN ZR  X4,LOOPX   #
               ISSUE (OP"ISUB", 6, 6, 5) ;        # GEN IX6 X6-X5      #
               ISSUE (OP"RIGHTK", 3, 0, 12) ;     # GEN AX3 12         #
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"XC", XC"NZ", 3, L) ;     # GEN NZ  X3,LOOP    #
               ISSUE (OP"SAAK", 3, 3, 1) ;        # GEN SA3 A3+1       #
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"XC", XC"NZ", 3, L) ;     # GEN NZ  X3,LOOP    #
               ISSUE (XSCON, 1) ; 
               ALLOC (P<TXEQ>, 1) ;               # GEN PS             #
               XEQW [TXEQL -1] = 0 ;
  
               ISSUE (XLABEL, M) ;                # GEN LABEL  -LOOPX- #
               ISSUE (OP"LEFTK", 6, 0, WL-1) ;    # GEN LX6 -1         #
               ISSUE (OP"SBXB", 7, 6, 0) ;        # GEN SB7 X6         #
               RECJ = TSYML ; 
               ISSUE (XNO, RT"SYM") ;             # GEN JP  RECJ+B7    #
               ISSUE (OP"JP", 7, 7, RECJ) ; 
  
#         GENERATE RECORD TYPE JUMP VECTOR CODE.
# 
               ISSUE (XLABEL, RECJ) ;             # GEN RECJ LABEL     #
               FOR  I = 0 THRU NREC-1  DO 
                    BEGIN                   # FOR EACH RECORD TYPE ... #
                    ISSUE (XNO, RT"SYM") ;
                    J = RECS + I ;                  # IF EVEN # 
                    IF  (I / 2) * 2  EQ  I            # GEN PL,X6 RECL #
                    THEN ISSUE (OP"XC", XC"PL", 6, J) ; 
                    ELSE ISSUE (OP"JP", 0, 0, J) ;  # IF ODD #
                    END                               # GEN JP  RECL   #
               IF  (NREC / 2) * 2  NE  NREC 
               THEN BEGIN                    # IF NREC IS ODD # 
                    ISSUE (XNO, RT"SYM") ;
                    ISSUE (OP"JP", 0, 0, "EXIT.") ;   # GEN JP  EXIT.  #
               END  END 
  
#         GENERATE EPILOGUE CODE. 
# 
          CALL CRA ;                              # CLEAR REG. ASSOC. # 
          ISSUE (XLABEL, "FINISH.") ;             # GEN FINISH. LABEL  #
          CALL SXR (2, RK"EXV", X$MBUF, 0) ;      # GEN SA2 =XDB$MBUF  #
          CALL SXR (4, RK"EXV", X$MKEY, 0) ;      # GEN SA4 =XDB$MKEY  #
          CALL SXR (1, RK"EXV", X$MFIT, 0) ;      # GEN SA1 =XDB$MFIT  #
          ISSUE (OP"SXXK", 6, 2, 0) ;             # GEN SX6 X2+0       #
          CALL SAR (6, RK"EXT", X$MDNA, 0) ;      # GEN SA6 =XDB$MDNA  #
          CALL SAR (6, RK"EXT", X$MRBF, 0) ;      # GEN SA6 =XDB$MRBF  #
          ISSUE (XNO, RT"SYM") ;                  # GEN ZR,X4 EXIT.    #
          ISSUE (OP"XC", XC"ZR", 4, "EXIT.") ;
          ISSUE (C$SKA, 0, 0, 0) ;                # GEN STORE X1,KA=X6 #
          ISSUE (XNO, RT"SYM") ;                  # GEN JP  EXIT.      #
          ISSUE (OP"JP", 0, 0, "EXIT.") ; 
  
#         PROCESS EACH RECORD TYPE. 
# 
          FOR  RECI = 1 THRU NREC  DO        # GET RECORD LIST ENTRY #
               BEGIN                         # AND SCHEMA AND SUB-   #
               IF  NREC NE 1                 # SCHEMA RECORD ENTRIES #
               THEN CALL FINDREC ;
                                             # SAVE RECORD ORDINAL     #
               RECT [RECI-1] = SBRECORDINAL [SSRP] ;
  
               IF  SBRECNOMAP [SSRP]         # IF NO-MAP RECORD # 
               THEN BEGIN 
                    CALL NKI ;                    # NO KEY ITEMS #
                    TEST RECI ; 
                    END 
               ALLOC (P<TITM>, SSNI) ;       # ALLOCATE AND CLEAR ITEM #
               FOR  I = 0 THRU SSNI-1  DO     # TO KEY INDEX TABLE #
                    ITMK [I] = 0 ;
               ALLOC (P<TKEY>, 1) ;          # SET ZERO-TH KEY ROUTINE #
               KEYL [0] = SYN ("EXIT.") ; 
  
#         PROCESS EACH ITEM ENTRY.
# 
               NEXT = SSRP + SBRECNXITEMP [SSRP] ;    # FIRST ITEM #
               FOR  SSIO = 1 THRU SSNI  DO
                    BEGIN 
                    SSIP = NEXT ;                 # SUB-SCHEMA ITEM PTR#
                    SSLP = SSIP ; 
                    NEXT = SSIP + SBITMNEXTP [SSIP] ; 
                    SCIP = SBITMSCPTR [SSIP] ;    # SCHEMA ITEM POINTER#
                    IF SBITMLEVEL[SSIP] EQ 52     # LEVEL 88           #
                    THEN BEGIN                    # DOES NOT COUNT     #
                         SSIO = SSIO -1;          # REDUCE LOOP COUNT  #
                         TEST SSIO;               # AND IGNORE IT      #
                         END
                    KEYF = SBITMKEYINFO [SSIP] NE 0 ; 
                    RESF = SBITMRLDNFLG [SSIP] ;
                    IF NOT (KEYF OR RESF)         # SKIP IF NOT A KEY  #
                    THEN BEGIN                    #  OR RESTRICT ITEM  #
                         TEST SSIO; 
                         END
                    GICL = 0 ;
                    RIBF = FALSE ;
                    QTRA = X$MSUB ; 
                    SBBP = 0 ;                    # INITIALISE #
                    SBWP = 0 ;
                    TBBP = 0 ;
                    TBWP = 0 ;
                    IF  KEYF
                    THEN BEGIN
                         IF SBITMMAJKEYF[SSIP]
                         THEN BEGIN 
                                   # GEN CODE TO SET MAJOR KEY LENGTH  #
                              CALL STF(C$SMKL,SBITMUSESIZE[SSIP]);
  
                                   # GENERATE A JUMP TO THE MAPPING    #
                                   # CODE FOR THE CONCATINATED KEY     #
                                   # GROUP OR KEY ON REPEATING GROUP.  #
                              J = KEYL[MKEL]; 
                              ISSUE (XNO, RT"SYM"); 
                              ISSUE (OP"JP",0,0,J); 
  
                              TEST SSIO;      # PROCESS NEXT ITEM      #
  
                              END 
                         ELSE BEGIN 
                              CALL SKI ;      # SET KEY INFO IN FIT    #
                         END  END 
                    IF  B<SBITMTYPE [SSIP]> GROUP EQ 0
                    THEN CALL PKI ;          # PROCESS KEY ITEM, OR # 
                    ELSE CALL PKG ;           # PROCESS KEY GROUP # 
                    IF  ITMK [SSIO-1] NE 0   # IF ANY CODE GENERATED #
                    THEN BEGIN                # FOR THIS KEY ITEM # 
                         IF  RIBF 
                         THEN A = "FINISH." ;    # IF RESULT IN BUFFER #
                         ELSE A = "EXIT." ;       # GEN JP  FINISH.    #
                         ISSUE (XNO, RT"SYM") ;    # OTHERWISE #
                         ISSUE (OP"JP", 0, 0, A) ;  # GEN JP EXIT.     #
                         END
  
#         PROCEED TO NEXT ITEM IN RECORD. 
# 
                    END 
  
#         GENERATE KEY ITEM INDEX TABLE FOR RECORD. 
# 
               IF  TKEYL EQ 1                # IF JUMP VECTOR IS EMPTY #
               THEN BEGIN 
                    CALL NKI ;                    # NO KEY ITEMS #
                    TEST RECI ; 
                    END 
               L = SBRECSRCLNEN [SSRP] ;     # ISSUE SOURCE LINE NUMBER#
               ISSUE (XLINE, L) ;             # OF SUB-SCHEMA REC DESC #
               M = 1 ;
               FOR  N = 0 STEP 1             # N = NUMBER OF BITS PER # 
                    WHILE  M LT TKEYL         # KEY ITEM INDEX #
                    DO  M = M + M ; 
               M = WL / N ;                  # M = NO. OF INDICES / WD #
               K = (SSNI + M - 1) / M ;      # K = NUMBER OF WORDS #
               ITMX = TSYML ; 
               ISSUE (XLABEL, ITMX) ;        # GEN ITMX LABEL          #
               ISSUE (XSVFD, K + N * 2**18   # GEN K WORDS OF THE FORM #
                           + TITML * 2**24) ; #   VFD N/Q1,...N/QM,L/  #
               J = TXEQL ;
               ALLOC (P<TXEQ>, K) ;          # ALLOCATE THE (K) WORDS # 
               L = M * N ;
               W = 0 ;                       # CLEAR VFD WORD # 
               K = 0 ;
               FOR  I = 1 THRU TITML  DO     # FOR EACH Q ... # 
                    BEGIN 
                    B<K,N> W = ITMK [I-1] ;       # BUILD VFD WORD #
                    K = K + N ; 
                    IF  K EQ L                    # IF WORD IS FULL # 
                    THEN BEGIN
                         XEQW [J] = W ;           # STORE IN CODE TABLE#
                         J = J + 1 ;
                         W = 0 ;                  # START NEXT WORD # 
                         K = 0 ;
                    END  END
               XEQW [J] = W ;                # STORE LAST VFD WORD #
  
#         GENERATE KEY ITEM ROUTINE SELECTION CODE FOR RECORD.
# 
               L = RECS + RECI -1 ;               # GEN REC.NNN LABEL  #
  
#         GENERATE TABLE USED TO TRANSLATE RECORD ORDINAL TO RECORD    #
#         TYPE JUMP INDEX.
# 
          IF NREC NQ 1
          THEN BEGIN
               K = (NREC +9) / 5 ;                # NUMBER OF WORDS    #
               ISSUE (XLABEL, RECZ) ;             # GEN LABEL -RECORDT-#
               ISSUE (XSVFD, K + 12 *2**18        # GEN VFD 12/N5,12/N4#
                      + (NREC + 5)  *2**24) ;     #  12/N3,12/N2,12/N1 #
               J = TXEQL ;
               ALLOC (P<TXEQ>, K) ;               # ALLOCATE AN EXTRA  #
               W = 0 ;
               K = WL ; 
               FOR I = 0 THRU (NREC -1)           # POPULATE THE TABLE #
               DO   BEGIN 
                    IF K EQ 0 
                    THEN BEGIN                    # A WORD IS ASSEMBLED#
                         XEQW [J] = W ;           # WRITE THE ASSEMBLY #
                         J = J +1 ; 
                         W = 0 ;
                         K = WL ; 
                         END
                    K = K -12 ; 
                    B<K,12> W = RECT [I] ;        # INSERT EACH ORDINAL#
                    END 
               XEQW [J] = W ;                     # WRITE FINAL ASSEMBL#
               XEQW [J+1] = 0;                    # ZERO THE EXTRA WORD#
               END
               ISSUE (XLABEL, L) ;
               ISSUE (OP"SXBK", 1, 0, M) ;        # GEN SX1 M          #
               ISSUE (OP"PACK", 2, 0, 1) ;        # GEN PX2 X1         #
               ISSUE (OP"PACK", 3, 0, 7) ;        # GEN PX3 X7         #
               ISSUE (OP"NORM", 2, 0, 2) ;        # GEN NX2            #
               ISSUE (OP"FDIV", 4, 3, 2) ;        # GEN FX4 X3/X2      #
               ISSUE (OP"SXBK", 2, 0, N) ;        # GEN SX2 N          #
               ISSUE (OP"UNPK", 0, 7, 4) ;        # GEN UX0,B7 X4      #
               ISSUE (OP"LEFTB", 5, 7, 0) ;       # GEN LX5 X0,B7      #
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"SAXK", 3, 5, ITMX) ;     # GEN SA3 ITMX+X5    #
               ISSUE (OP"DMUL", 6, 5, 1) ;        # GEN IX6 X5*X1      #
               ISSUE (OP"MASK", 0, 0, WL-N) ;     # GEN MX0 -N         #
               ISSUE (OP"ISUB", 4, 7, 6) ;        # GEN IX4 X7-X6      #
               ISSUE (OP"DMUL", 5, 4, 2) ;        # GEN IX5 X4*X2      #
               ISSUE (OP"SBXK", 6, 5, N) ;        # GEN SB6 X5+N       #
               ISSUE (OP"LEFTB", 3, 6, 3) ;       # GEN LX3 B6         #
               ISSUE (OP"ANDN", 7, 3, 0) ;        # GEN BX7 -X0*X3     #
               ISSUE (OP"LEFTK", 7, 0, WL-1) ;    # GEN LX7 -1         #
               ISSUE (OP"SBXB", 7, 7, 0) ;        # GEN SB7 X7         #
               KEYJ = TSYML ; 
               ISSUE (XNO, RT"SYM") ;             # GEN JP  KEYJ+B7    #
               ISSUE (OP"JP", 7, 7, KEYJ) ; 
  
#         GENERATE KEY ITEM JUMP VECTOR CODE. 
# 
               ISSUE (XLABEL, KEYJ) ;             # GEN KEYJ LABEL     #
               FOR  I = 0 THRU TKEYL-1  DO
                    BEGIN                    # FOR EACH KEY ROUTINE ...#
                    ISSUE (XNO, RT"SYM") ;
                    J = KEYL [I] ;                # IF EVEN # 
                    IF  (I / 2) * 2  EQ  I          # GEN PL,X7 KEYL   #
                    THEN ISSUE (OP"XC", XC"PL", 7, J) ; 
                    ELSE ISSUE (OP"JP", 0, 0, J) ;  # IF ODD #
                    END                               # GEN JP  KEYL   #
               IF  (TKEYL / 2) * 2  NE  TKEYL 
               THEN BEGIN                         # IF TKEYL IS ODD # 
                    ISSUE (XNO, RT"SYM") ;
                    ISSUE (OP"JP", 0, 0, "EXIT.") ;   # GEN JP  EXIT.  #
                    END 
  
#         PROCEED TO NEXT RECORD TYPE.
# 
               CALL ASU ;                    # ACCUMULATE STORAGE USED #
               TITML = 0 ;
               TKEYL = 0 ;                   # CLEAR ITEM, KEY TABLES # 
               END
  
#         COMPLETE GENERATION OF CAPSULE. 
# 
          TRECL = 0 ;                        # CLEAR RECORD TABLE # 
          IF  KIRC EQ 0 
          THEN BEGIN
               TCONL = 0 ;                   # IF NO KEY ITEM ROUTINES #
               TEMPL = 0 ;                    # WERE GENERATED, CLEAR  #
               TEPTL = 0 ;                     # ALL TABLES THAT WOULD #
               TEXTL = 0 ;                      # HAVE BEEN CLEARED BY #
               TLITL = 0 ;                       # VARIOUS ROUTINES IN #
               TREFL = 0 ;                        # PASS TWO           #
               TSYML = 0 ;
               TVARL = 0 ;
               TXEQL = 0 ;                   # INDICATE NULL CAPSULE #
               END
          RETURN ;
  
  
  
  
#***      BKR  -  BEGIN KEY ITEM MAPPING ROUTINE. 
# 
          PROC BKR ;
  
#***
# 
          BEGIN 
  
          IF  ITMK [SSIO-1] EQ 0             # IF NOT BEGUN ALREADY # 
          THEN BEGIN
               ITMK [SSIO-1] = TKEYL ;       # SETUP KEY ITEM INDEX # 
               ALLOC (P<TKEY>, 1) ;           # AND JUMP VECTOR ENTRY # 
               KEYL [TKEYL-1] = TSYML ; 
               KIRC = KIRC + 1 ;             # COUNT ITEM ROUTINES #
               ISSUE (XLINE, SBITMSRCLNEN [SSLP]) ; 
               ISSUE (XLABEL, TSYML) ;       # GEN KEY-ROUTINE LABEL #
               CALL CRA ;                    # CLEAR REGISTER ASSOC. #
               END
          IF  SSIP NE SSLP                   # PRINT SOURCE LINE NO. #
          THEN BEGIN                          # IF NOT DONE ALREADY # 
               SSLP = SSIP ;
               ISSUE (XLINE, SBITMSRCLNEN [SSIP]) ; 
               END
          RETURN ;
  
          END 
  
  
  
  
#***      NKI  -  NO KEY ITEMS. 
# 
          PROC NKI ;
  
#***
# 
          BEGIN 
  
          ITEM K, L ; 
  
          L = SBRECSRCLNEN [SSRP] ;          # ISSUE SOURCE LINE NUMBER#
          ISSUE (XLINE, L) ;                  # OF SUB-SCHEMA RECORD #
          L = RECS + RECI -1 ;                 # DESCRIPTION #
          ISSUE (XLABEL, L) ; 
          K = SYN ("EXIT.") ;                # GEN REC.NNN EQU EXIT.   #
          SYMA [L] = SYMA [K] ;              # EQUATE SYMBOL VALUE #
          ISSUE (XEQU, RT"SYM", K) ;
          CALL ASU ;                         # ACCUMULATE STORAGE USED #
          TITML = 0 ; 
          TKEYL = 0 ;                        # CLEAR ITEM, KEY TABLES # 
          RETURN ;
  
          END 
  
  
  
  
#***      PCV  -  PROCESS CONVERSION OF ITEM VALUE. 
# 
          PROC PCV ;
  
#         CALLED BY *PKI*.
****
# 
          BEGIN 
  
          ITEM GICX ; 
          ITEM SP, TP ; 
  
          CALL PEN ;                         # PROCESS ENCODING DBP # 
          GICX = 0 ;
          IF  DBPF  AND  RESF                # IF ITEM CONVERSION CODE #
            OR  NOT DBPF  AND  (RIBF          # WILL BE NEEDED #
              OR  NOT SBITMIDNTICL [SSIP])
          THEN BEGIN
               CALL BKR ;                         # BEGIN KEY ROUTINE # 
               IF  DBPF 
               THEN BEGIN                         # IF DBP CODE EXISTS,#
                    GICX = TSYML ;                 # MUST JUMP AROUND # 
                    ISSUE (XNO, RT"SYM") ;          # CONVERSION CODE # 
                    ISSUE (OP"JP", 0, 0, GICX) ;
                    END 
               IF  GICL NE 0
               THEN BEGIN                         # IF JUMP AROUND DBP #
                    ISSUE (XLABEL, GICL) ;         # CODE EXISTS, MUST #
                    GICL = 0 ;                      # HAVE LABEL FOR IT#
                    END 
               SP = SBITMPTLOC [SSIP] ; 
               IF  SBITMLFTPT [SSIP] EQ 0 
               THEN SP = - SP ;                   # PREPARE TO CALL # 
               TP = SCITEMPTLOC [SCIP] ;           # GIC TO GENERATE #
               IF  NOT SCITEMPTLEFT [SCIP]          # ITEM CONVERSION # 
               THEN TP = - TP ; 
               CALL GIC (SBITMDBCLASS [SSIP], RK"SRA",
                         SBITMUSESIZE [SSIP] * CL, SBITMJUST [SSIP],
                         SP, SBITMACTLPT [SSIP], SBITMSIGNF [SSIP], 
                         SCITEMCLASS [SCIP], RK"TRA", 
                         SCITEMSIZE [SCIP] * CL, 0, 
                         TP, SCITEMACTLPT [SCIP], SCITEMSIGNFG [SCIP]) ;
               CALL DSR ;                         # DEPOSIT STORE REG. #
               IF  GICX NE 0
               THEN ISSUE (XLABEL, GICX) ;        # LABEL FOR THE JUMP #
               END                                 # AROUND CONVERSION #
          RETURN ;
  
          END 
  
  
  
  
#***      PEN  -  PROCESS *ENCODING* DBP CALL, IF ANY.
# 
          PROC PEN ;
  
#         CALLED BY *PCV*.
****
# 
          BEGIN 
  
          ITEM DONE B ; 
          ITEM I ;
  
          IF  KEYF  AND  NOT DBPF 
          THEN BEGIN
               I = SCITMENCDPTR [SCIP] ;
               IF  I NE 0                    # IF ANY ENCODING AND/OR # 
               THEN BEGIN                     # DECODING PROCS NAMED #
                    DONE = FALSE ;
                    FOR  I = SCIP + I  STEP  1
                            WHILE  NOT DONE  DO 
                         BEGIN                        # BUILD DBP LIST #
                         IF  SCITEMENCODE [I] EQ 0
                           AND  (SCITEMALWAYS [I] 
                                 OR  NOT SBITMIDNTICL [SSIP]) 
                         THEN CALL BDL (SCITEMCODER [I]) ;
                         DONE = NOT SCITEMCNEXT [I] ; 
                         END
                    IF  TDBPL NE 0           # IF ANY PROCS TO CALL # 
                    THEN BEGIN
                         CALL TKF ;               # TEST KEY MODE FLAG #
                         RIBF = TRUE ;            # SET RESULT IN BUF # 
                         QTRA = QBUF ;
                         CALL GDC (DBPENT"ENCODE") ;   # GEN DBP CALL # 
                         DBPF = TRUE ;            # INDICATE DBP RESULT#
               END  END  END
          RETURN ;
  
          END 
  
  
  
  
#***      PKG  -  PROCESS KEY GROUP (CONCATENATED KEY). 
# 
          PROC PKG ;
  
#         CALLED BY *MAPKEY* TO GENERATE CODE FOR PROCESSING A
*         CONCATENATED KEY OR KEY ON REPEATING GROUP WHICH
*         APPEARS AS A GROUP KEY ITEM . 
****
# 
          BEGIN 
  
          ITEM SSGP ;              # SUB-SCHEMA GROUP ITEM POINTER #
          ITEM REPK B;             # KEY IS A REPEATING GROUP # 
  
  
          RIBF = TRUE ;                      # SET RESULT IN BUFFER # 
          QTRA = QBUF ; 
          TLEV = SBITMLEVEL [SSIP] ;
          SSGP = SSIP ;                      # SAVE GROUP POINTER # 
          M = 0 ; 
          N = NEXT ;
          REPK = FALSE; 
          IF SBITMOCCURP [SSIP] NE 0 THEN    # KEY IS A REPEATING GROUP#
            BEGIN 
            REPK = TRUE;
            END 
          FOR  K = SSIO + 1  STEP  1
                  WHILE  SBITMLEVEL [N] GT TLEV 
                       AND  K LE SSNI  DO 
               BEGIN                         # PROCESS EACH OF ITS #
               SSIP = N ;                     # SUBORDINATE ITEMS # 
               N = SSIP + SBITMNEXTP [SSIP] ; 
               IF  SBITMREDEFFG [SSIP]            # IGNORE REDEFINES #
                 OR  SBITMLEVEL [SSIP] EQ 50       # OR RENAMES OR #
                 OR  B<SBITMTYPE [SSIP]> GROUP NE 0 # GROUP ENTRY # 
               THEN BEGIN 
                    IF SBITMLEVEL [SSIP] EQ 52   # 88 VALUE CLAUSES    #
                    THEN BEGIN                   # HAVE NO ITEM ORDINAL#
                         K = K -1;               # REDUCE LOOP COUNT   #
                         END
                    TEST K; 
                    END 
  
#         ACCUMULATE SUB-SCHEMA ITEM BEGINNING WORD AND BIT POSITIONS 
*         RELATIVE TO START OF GROUP, BY SCANNING DOMINANT ITEMS BACK 
*         TO BUT NOT INCLUDING THE KEY GROUP ITEM ENTRY.
# 
               IF REPK THEN 
                 BEGIN
                 SBBP = SBITMBBP [SSIP] + WL; 
                 SBWP = SBITMBWP [SSIP] - 1;
                 END
               ELSE 
                 BEGIN
                 SBBP = SBITMBBP [SSIP] - SBITMBBP [SSGP] + WL ;
                 SBWP = SBITMBWP [SSIP] - SBITMBWP [SSGP] - 1 ; 
                 END
  
               FOR  J = SBITMDOMADR [SSIP]
                       WHILE  J NE SSGP  DO 
                    BEGIN                                   # IGNORE   #
                    IF  SBITMTYPE [J] NE TYPE"SIMPLGRP"     # A NON-   #
                    THEN BEGIN                              # REPEATING#
                         SBBP = SBBP + SBITMBBP [J] ;       # GROUP    #
                         SBWP = SBWP + SBITMBWP [J] ; 
                         END
                    J = SBITMDOMADR [J] ; 
                    END 
               L = SBBP / WL ;
               SBBP = SBBP - L * WL ; 
               SBWP = SBWP + L ;
  
#         NOW GET THE SCHEMA ITEM BEGINNING WORD AND BIT POSITIONS
*         RELATIVE TO START OF SCHEMA ITEM THAT CORRESPONDS TO THE
*         FIRST SUB-SCHEMA ITEM IN THE KEY GROUP. 
# 
               SCIP = SBITMSCPTR [SSIP] ; 
               IF  M EQ 0 
               THEN M = SCIP ;
               IF REPK THEN 
                 BEGIN
                 TBBP = SCITEMBBP [SCIP] + WL;
                 TBWP = SCITEMPBWP [SCIP] - 1;
                 END
               ELSE 
                 BEGIN
                 TBBP = SCITEMBBP [SCIP] - SCITEMBBP [M] + WL ; 
                 TBWP = SCITEMPBWP [SCIP] - SCITEMPBWP [M] - 1 ;
                 END
  
               L = TBBP / WL ;
               TBBP = TBBP - L * WL ; 
               TBWP = TBWP + L ;
               CALL PKI ;                         # PROCESS KEY ITEM #
               END
# 
*         SET MAJOR KEY EXIT LABEL (MKEL) TO THE SYMBOL TABLE ORDINAL OF
*         THE LABEL GENERATED FOR THIS KEY GROUP. 
*         IT IS ZERO IF NO CODE WAS GENERATED.
# 
          MKEL = ITMK[SSIO-1];
          RETURN ;
  
          END 
  
  
  
  
#***      PKI  -  PROCESS KEY ITEM. 
# 
          PROC PKI ;
  
#         CALLED BY *MAPKEY* TO GENERATE CODE FOR PROCESSING ONE
*         ELEMENTARY KEY ITEM, AND BY *PKG* FOR EACH ELEMENTARY 
*         ITEM OF A GROUP (CONCATENATED KEY). 
****
# 
          BEGIN 
  
          ITEM I ;
  
          IF SCIP EQ 0               # IF ITEM NOT DEFINED IN SCHEMA   #
          THEN RETURN;
  
          DBPF = FALSE ;
          SW = SBWP ; 
          TW = TBWP ; 
          IF  KEYF                      # IF KEY ITEM # 
          THEN BEGIN
               I = SCITMATVTP [SCIP] ;       # PROCESS ACTUAL RESULT #
               IF  I NE 0                     # DBP CALL, IF ANY #
                 AND  NOT SCITMAVRESLT [SCIP+I] 
               THEN BEGIN 
                    CALL TKF ;               # TEST KEY MODE FLAG # 
                    RIBF = TRUE ;            # SET RESULT IN BUFFER # 
                    QTRA = QBUF ; 
                    CALL BDL (SCITEMRESULT [SCIP+I]) ; # BUILD DBP LIST#
                    CALL GDC (DBPENT"ACTUAL") ;        # GEN DBP CALL # 
                    DBPF = TRUE ;            # INDICATE DBP RESULT #
               END  END 
          CALL PCV ;                    # PROCESS CONVERSION OF VALUE # 
          IF  GICL NE 0 
          THEN BEGIN                    # GEN GICL LABEL               #
               ISSUE (XLABEL, GICL) ;    # IF NOT ALREADY DONE #
               GICL = 0 ; 
               END
# 
*         IF THE KEY IS A PRIMARY OR ALTERNATE THEN 
*         SET MAJOR KEY EXIT LABEL (MKEL) TO THE SYMBOL TABLE ORDINAL OF
*         THE LABEL GENERATED FOR THIS KEY ITEM.
*         IT IS ZERO IF NO CODE WAS GENERATED.
# 
          IF SBITMKEYFLG[SSIP]
             OR SBITMALTKEYF[SSIP]
          THEN BEGIN
               MKEL = ITMK[SSIO-1]; 
               END
          RETURN ;
  
          END 
  
  
  
  
#***      SKI  -  SET KEY INFORMATION IN FIT. 
# 
          PROC SKI ;
  
#         *SKI* GENERATES CODE, IF ANY IS NEEDED, TO RESET THE
*         FIELDS KEY LENGTH (KL), KEY TYPE (KT), RECORD KEY 
*         POSITION (RKP), AND RECORD KEY WORD (RKW) IN THE FILE 
*         INFORMATION TABLE (FIT), TO REFLECT DIFFERENCES BETWEEN 
*         THE SCHEMA AND SUB-SCHEMA IN THE SIZE, TYPE, AND
*         LOCATION OF THE KEY ITEM BEING PROCESSED. 
****
# 
          BEGIN 
  
          ITEM I, J, K, L ; 
          ITEM SCKL, SCKT S:CLASS, SCKP, SCKW ; 
          ITEM SSKL, SSKT S:CLASS, SSKP, SSKW ; 
  
#         GENERATE CODE TO SET  KL = KEY LENGTH.
# 
          SSKL = SBITMUSESIZE [SSIP] ;       # SUB-SCHEMA ITEM SIZE # 
          IF  SCIP NE 0                     # ITEM EXISTS IN SCHEMA    #
          THEN SCKL = SCITEMSIZE [SCIP] ;    # SCHEMA ITEM SIZE # 
          ELSE BEGIN
               SCKL = 0 ;                    # IF CONCATENATED KEY #
               TLEV = SBITMLEVEL [SSIP] ; 
               I = NEXT ;                         # MUST SUM SIZES OF # 
               FOR  J = SSIO + 1  STEP  1           # ITS CONSTITUENT # 
                       WHILE  SBITMLEVEL [I] GT TLEV  # ELEMENTARY #
                            AND  J LE SSNI  DO          # ITEMS # 
                    BEGIN 
                    K = SBITMSCPTR [I] ;
                    IF  K NE 0
                      AND  SCITMDATATYP [K] EQ TYPE"ELEMEN" 
                    THEN SCKL = SCKL + SCITEMSIZE [K] ; 
                    I = I + SBITMNEXTP [I] ;
               END  END 
          IF  SCKL NE SSKL                   # IF SIZES NOT THE SAME #
          THEN BEGIN
               CALL STF (C$SKL, SCKL) ;      # GEN STORE FIT,KL=SCKL   #
               END
  
#         GENERATE CODE TO SET  KT = KEY TYPE.
# 
          SSKT = SBITMDBCLASS [SSIP] ;       # SUB-SCHEMA DATA CLASS #
          L = 1 ;                           # DUMMY LOOP EXIT FLAG     #
          FOR  I = NEXT  STEP  SBITMNEXTP [I] 
                  WHILE  SCIP EQ 0 AND L NQ 0  DO 
               BEGIN                          # FIND FIRST ELEMENTARY # 
               SCIP = SBITMSCPTR [I] ;         # ITEM IN SCHEMA # 
               IF  SBITMNEXTP [I] EQ 0
               THEN BEGIN 
                    L = 0 ;                    # LAST ITEM PROCESSED   #
                    TEST I ;
                    END 
               IF  SCIP NE 0
                 AND  SCITMDATATYP [SCIP] NE TYPE"ELEMEN" 
               THEN SCIP = 0 ;
               END
          SCKT = SCITEMCLASS [SCIP] ;        # SCHEMA ITEM DATA CLASS # 
          K = 0 ; 
          IF  SCKT EQ S"INTEGER"             # IF SCHEMA IS INTEGER # 
          THEN BEGIN
               IF  SSKT NE S"INTEGER"        # IF SUB-SCHEMA IS NOT # 
                 AND  SSKT NE S"FTNLOGICAL"  # INTEGER OR FTN TYPES    #
                 AND  SSKT NE S"FTNBOOLEAN"  # EQUIVALENT TO INTEGER   #
               THEN K = C$SKTI ;                  # GEN STORE X1,KT=I  #
               END
          ELSE
          IF  SCKT GE S"FIXED"               # IF SCHEMA IS FLOATING #
            AND  SCKT LE S"FLOATNORM" 
          THEN BEGIN
               IF  SSKT LT S"FIXED"          # IF SUB-SCHEMA IS NOT # 
                 OR  SSKT GT S"COMPLEX"      # FLOATING OR FTN TYPES   #
                   AND  SSKT NE S"FTNBOOLEAN"# EQUIVALENT TO FLOATING  #
               THEN K = C$SKTF ;                  # GEN STORE X1,KT=F  #
               END
          ELSE BEGIN                         # IF SCHEMA IS OTHER # 
               IF  SSKT GE S"INTEGER"        # IF SUB-SCHEMA IS    #
                 AND  SSKT LE S"FLOATNORM"   # FIXED OR FLOATING       #
                   AND   SSKT LE S"COMPLEX"  # FIXED OR FLOATING       #
                 OR  SSKT EQ S"FTNLOGICAL"   # OR FTN TYPES EQUIVALENT #
                 OR  SSKT EQ S"FTNBOOLEAN"   # TO FIXED OR FLOATING    #
               THEN K = C$SKTS ;                  # GEN STORE X1,KT=S  #
               END
          IF  K NE 0  AND  FO$IS             # IF CODE NEEDED # 
          THEN CALL STF (K, -1) ;             # GEN STORE FIT,KT=I/F/S #
  
#         GENERATE CODE TO SET  RKP, RKW = KEY LOCATION IN RECORD.
# 
          SSKL = SBITMBWP [SSIP] * WL + SBITMBBP [SSIP] ; 
          FOR  J = SBITMDOMADR [SSIP] 
                  WHILE  J NE SSRP  DO       # ACCUMULATE LOCATION #
               BEGIN                          # OF SUB-SCHEMA ITEM #
               SSKL = SSKL + SBITMBWP [J] * WL + SBITMBBP [J] ; 
               J = SBITMDOMADR [J] ;
               END                           # SET SUB-SCHEMA KEY # 
          SSKW = SSKL / WL ;                  # ITEM WORD, POSITION # 
          SSKP = (SSKL - SSKW * WL) / CL ;
          SCKL = SCITEMPBWP [SCIP] * WL + SCITEMBBP [SCIP] ;
          L = SCITRLDOMPTR [SCIP] ;  # L NE 0 IF MORE DOMINANT ITEMS   #
          FOR J = SCIP - L
                  WHILE L NE 0  DO
               BEGIN                          # OF SCHEMA ITEM #
               SCKL = SCKL + SCITEMPBWP [J] * WL + SCITEMBBP [J] ;
               L = SCITRLDOMPTR [J] ;  # L NE 0 IF MORE DOMINANT ITEMS #
               J = J - SCITRLDOMPTR [J] ; 
               END                           # SET SCHEMA KEY ITEM #
          SCKW = SCKL / WL ;                  # WORD AND POSITION # 
          SCKP = (SCKL - SCKW * WL) / CL ;
          IF  SSKP NE SCKP                   # IF DIFFERENT B.C.P. #
          THEN CALL STF (C$SRKP, SCKP) ;      # GEN STORE FIT,RKP=SCKP #
          IF  SSKW NE SCKW                   # IF DIFFERENT B.W.P. #
          THEN CALL STF (C$SRKW, SCKW) ;      # GEN STORE FIT,RKW=SCKW #
          RETURN ;
  
          END 
  
  
  
  
#***      STF  -  GENERATE CODE TO STORE VALUE INTO A *FIT* FIELD.
# 
          PROC STF (CODE, VALUE) ;
  
          ITEM CODE ;              # C$XXX ENTRY IN *CODE* TABLE #
          ITEM VALUE ;             # VALUE TO BE STORED (NONE IF < 0) # 
  
#***
# 
          BEGIN 
  
          CALL TKF ;                              # TEST KEY MODE FLAG #
          CALL SXR (1, RK"EXV", X$MFIT, 0) ;      # GEN SA1 =XDB$MFIT  #
          LOCKX [1] = TRUE ;
          IF  VALUE GE 0                          # GEN SX6 VALUE      #
          THEN CALL SXR (6, RK"CON", VALUE, CF"INT") ;
          ISSUE (CODE, 0, 0, 0) ;                 # GEN STORE X1,XXX=X6#
          LOCKX [1] = FALSE ; 
          REGX  [5] = 0 ;                         # CLEAR REG. ASSOC.  #
          REGX  [6] = 0 ;                         # OF REGISTERS THAT  #
          REGX  [7] = 0 ;                         # MAY BE DESTROYED   #
          REGA  [5] = 0 ;                         # BY *STORE* MACRO   #
          REGA  [6] = 0 ; 
          RETURN ;
  
          END 
  
  
  
  
#***      TKF  -  TEST KEY FLAG.
# 
          PROC TKF ;
  
#         *TKF* GENERATES CODE (IF IT IS NOT ALREADY DONE FOR THE 
*         CURRENT ITEM) TO TEST THE MODE FLAG *DB$MKEY* AND JUMP
*         TO THE ITEM CONVERSION CODE LABEL *GICL* IF IT IS ZERO
*         INDICATING A *RESTRICT* CALL RATHER THAN A *KEY* CALL.
****
# 
          BEGIN 
  
          ITEM R ;
  
          CALL BKR ;                         # BEGIN KEY ROUTINE #
          IF  KEYF  AND  RESF 
            AND  GICL EQ 0                   # IF JUMP NEEDED # 
          THEN BEGIN
               CALL GXR (R, RK"EXV", X$MKEY, 0) ; # GEN SAR =XDB$MKEY  #
               GICL = TSYML ; 
               ISSUE (XNO, RT"SYM") ;             # GEN ZR,XR GICL     #
               ISSUE (OP"XC", XC"ZR", R, GICL) ;
               END
          RETURN ;
  
          END 
  
     END  TERM
