*COMDECK     COMPASS1   - SUBROUTINES FOR FIRST CODE GENERATION PASS. 
#*        PASS1  -  SUBROUTINES FOR FIRST CODE GENERATION PASS. 
* 
*         R. H. GOODELL.     76/10/28.
* 
*         *PASS1* CONTAINS SUBROUTINES USED IN THE FIRST PASS OF THE
*         DDL CODE GENERATOR, TO PRODUCE CODE FOR A MAPPING CAPSULE.
*         THESE SUBROUTINES ARE CALLED BY THE DRIVER ROUTINES MAPKEY, 
*         MAPRD, AND MAPWR, WHICH IN TURN ARE CALLED BY THE *PASS1* 
*         INITIALISATION AND CONTROL ROUTINE. 
* 
*         CONTENTS (XDEF ENTRY POINTS). 
* 
*         PROC   BDL         BUILD DBP LIST.
*         FUNC   EXN         EXTERNAL NAME NUMBER.
*         PROC   GDC         GENERATE DBP CALL. 
*         FUNC   GTV         GET TEMPORARY VARIABLE.
*         PROC   IDP         IDENTIFY DATA-BASE PROCEDURES TO CALL. 
*         FUNC   LDN         LITERAL DESCRIPTOR NUMBER. 
*         PROC   PADV        PAD *TVAR* TO WORD BOUNDARY. 
*         PROC   PADX        PAD *TXEQ* TO WORD BOUNDARY. 
*         PROC   PASS1       INITIALISE AND CONTROL FIRST PASS. 
*         PROC   SRL         SET RECORD LENGTH. 
*         FUNC   SYN         SYMBOL NAME NUMBER.
# 
  
  
*CALL     COMDDEF            GENERAL DEFINITIONS. 
  
     STATUS  MAP  KEY, READ, WRITE ;         # *MAPX* VALUES #
  
     XREF BEGIN               # MANAGED TABLES #
  
*CALL     COMDTCON           CONSTANT VALUES. 
  
*CALL     COMDTDBP           DATA BASE PROCEDURES.
  
*CALL     COMDTDPL           DATA BASE PROCEDURE LIST POINTERS. 
  
*CALL     COMDTDPN           DATA BASE PROCEDURE NAMES (FROM SCHEMA). 
  
*CALL     COMDTEMP           TEMPORARY VARIABLES. 
  
*CALL     COMDTEPT           ENTRY POINTS.
  
*CALL     COMDTEXT           EXTERNAL NAMES.
  
*CALL     COMDTLIT           LITERALS.
  
*CALL     COMDTSCH           SCHEMA DIRECTORY (CURRENT PORTION).
  
*CALL     COMDTSUB           SUB-SCHEMA DIRECTORY + FINISHED CAPSULES.
  
*CALL     COMDTSYM           SYMBOL TABLE.
  
*CALL     COMDTVAR           VARIABLES AND APLISTS (INTERMEDIATE).
  
*CALL     COMDTXEQ           EXECUTABLE CODE + PSEUDO OPS (INTERMEDIATE)
  
          END 
*CALL     COMDREG            REGISTER INFORMATION.
  
     XREF BEGIN               # OTHER EXTERNALS # 
  
*CALL     COMDLOOP           LOOP NESTING CONTROL TABLE.
*CALL     COMDPRFX           CAPSULE PREFIX TABLE.
          ITEM C$SRL ;             # CODE -   STORE X1,RL=X6 #
          ITEM DBPA I ;            # TSYM INDEX OF DBP APLIST LABEL # 
          ITEM DBPI I ;            # TSYM INDEX OF DBP NAME LIST LABEL #
          ITEM END1 I ;            # DYNAMIC AREA FWA FOR THIS OVERLAY #
          ITEM GETF B ;            # TRUE WHEN GENERATING READ MAPPING #
          ITEM ILOC I ;            # LOCATION COUNTER FOR TXEQ #
          ITEM INTW U ;            # INSTRUCTION WORD GOING TO TXEQ # 
          ITEM IPAR I ;            # PARCEL NUMBER OF INSTR. (0-3) #
          ITEM IPOS I ;            # BEGINNING BIT POSITION OF INSTR. # 
          ITEM LOOPL ;             # LOOP NESTING LEVEL # 
          ITEM MAPX S:MAP ;        # PASS 1 MODE INDICATOR #
          ITEM NSIF B ;            # NO SOURCE ITEM FLAG #
          ITEM OLD65 ;             # LWA+1 OF THIS OVERLAY #
          ITEM SBBP I ;            # SOURCE BEGINNING BIT POSITION #
          ITEM SBWP I ;            # SOURCE BEGINNING WORD POSITION # 
          ITEM SCIP I ;            # SCHEMA ITEM ENTRY POINTER #
          ITEM SSIP I ;            # SUB-SCHEMA ITEM ENTRY POINTER #
          ITEM SSRP I ;            # SUB-SCHEMA RECORD ENTRY POINTER #
          ITEM TBBP I ;            # TARGET BEGINNING BIT POSITION #
          ITEM TBWP I ;            # TARGET BEGINNING WORD POSITION # 
          ITEM VARF B ;            # TRUE IF IN A VARIABLE DIMENSION #
          ITEM VBLW U ;            # INSTRUCTION WORD GOING TO TVAR # 
          ITEM VLOC I ;            # LOCATION COUNTER FOR TVAR #
          ITEM VPAR I ;            # PARCEL NUMBER (0-3) FOR TVAR # 
          ITEM VPOS I ;            # NEXT BIT POSITION IN VBLW #
          ITEM XPOS I ;            # NEXT BIT POSITION IN INTW #
          ITEM X$DPII ;            # NAME OF DBP INTERFACE ITEM LEVEL # 
          ITEM X$MFIT ;            # NAME OF FILE INFORMATION TABLE FWA#
          ITEM X$SBBP ;            # NAME OF SOURCE BEGINNING BIT POS # 
          ITEM X$SBWP ;            # NAME OF SOURCE BEGINNING WORD POS #
          ITEM X$TBBP ;            # NAME OF TARGET BEGINNING BIT POS # 
          ITEM X$TBWP ;            # NAME OF TARGET BEGINNING WORD POS #
          PROC ALLOC ;             # ALLOCATE TABLE SPACE # 
          PROC ASU ;               # ACCUMULATE STORAGE USED #
          PROC CRA ;               # CLEAR REGISTER ASSOCIATES #
          PROC DSR ;               # DEPOSIT STORE REGISTER # 
          PROC GXR ;               # GET X-REGISTER WITH SPECIFIED VAL #
          PROC ISSUE ;             # ISSUE INSTRUCTION TO INTERMEDIATE #
          FUNC LITCL I ;           # ITEM DATA CLASS CODE LITERAL # 
          FUNC LITEC I ;           # DBP ENTRY CODE LITERAL # 
          FUNC LITINT I ;          # INTEGER LITERAL #
          FUNC LITSI I ;           # SHORT INTEGER LITERAL #
          PROC MAPKEY ;            # COMPILE KEY MAPPING CODE CAPSULE # 
          PROC MAPRD ;             # COMPILE READ RECORD MAPPING CODE # 
          PROC MAPWR ;             # COMPILE WRITE/REWRITE RECORD CODE #
          PROC MOVEI ;             # MOVE DATA, INDIRECT ADDRESS #
          FUNC OCTAL C (WC) ;      # CONVERT HALF-WORD TO OCTAL # 
          PROC SAR ;               # SET SPECIFIED A-REGISTER TO VALUE #
          PROC SDA ;               # SET DYNAMIC AREA BASE ADDRESS #
          PROC SXR ;               # SET SPECIFIED X-REGISTER TO VALUE #
          FUNC XSFW C (WC) ;       # SPACE FILL WORD #
          FUNC XZFN C (WC) ;       # ZERO FILL NAME # 
  
          END 
  
  
*CALL     COMDCF             CONSTANT FORMATS.
  
  
*CALL     COMDDBPE           DATA BASE PROCEDURE ENTRY CODES. 
  
  
*CALL     COMDOPS            OPERATION CODES. 
  
  
*CALL     COMDPSOP           PSEUDO OPERATION ISSUING DEFS. 
  
  
#         LOCAL DATA. 
# 
  
  
  
  
#***      PASS1  -  INITIALISE AND CONTROL FIRST PASS OF A CAPSULE. 
  
          PROC PASS1
  
****
# 
          BEGIN 
  
          ITEM A C (WC) ;          # CHARACTER TEMPORARY #
          ITEM I, J ;              # INTEGER TEMPORARIES #
  
          LABEL KEY, READ, WRITE, EXIT ;
  
          IF  END1 NE OLD65             # IF 1ST CALL OF THIS OVERLAY  #
          THEN BEGIN                     # (END1 = HHA), THEN SET END1 #
               END1 = OLD65 ;             # TO ITS TRUE VALUE, AND SET #
               CALL SDA (END1) ;           # DYNAMIC AREA BASE ADDRESS #
               END
          ILOC = 3 ;                    # INITIALISE LOCATION COUNTER # 
          INTW = 0 ;                    # AND RELATED CELLS # 
          IPAR = 0 ;
          IPOS = 0 ;
          VBLW = 0 ;
          VLOC = O"400000" ;
          VPAR = 0 ;
          VPOS = 0 ;
          XPOS = 0 ;
          ISSUE (XLABEL, 0) ;           # DEFINE ENTRY POINT #
          ALLOC (P<TEPT>, 1) ;                    #         ENTRY  NAME#
          SYMN [0] = XSFW (PRFXCAP) ; 
          EPTN [0] = SYMN [0] ;         # DEFINE ENTRY SYMBOL # 
          EPTA [0] = SYMA [0] ; 
          ISSUE (XSUBR, 0) ;                      # NAME    SUBR       #
          SBBP = 0 ;
          SBWP = 0 ;
          TBBP = 0 ;
          TBWP = 0 ;
          VARF = FALSE ;
          FOR  LOOPL = 1 THRU 3  DO     # CLEAR LOOP NESTING TABLE #
               BEGIN
               LOOP0 [LOOPL] = 0 ;
               LOOP1 [LOOPL] = 0 ;
               LOOP2 [LOOPL] = 0 ;
               LOOP3 [LOOPL] = 0 ;
               END
          LOOPL = 0 ; 
  
          SWITCH  GEN: MAP
                    KEY: KEY,  READ: READ,  WRITE: WRITE ;
          GO TO GEN [MAPX] ;
               BEGIN
  
      KEY:     CALL MAPKEY ;
               GO TO EXIT ; 
  
      READ:    CALL MAPRD ; 
               GO TO EXIT ; 
  
      WRITE:   CALL MAPWR ; 
  
               END
  
 EXIT:    FOR  I = 1 THRU TEMPL  DO          # FOR EACH TEMP VAR ... #
               BEGIN
               J = TEMV [I-1] ;                   # GET TSYM INDEX #
               A = OCTAL (I) ;
               C<0,1> SYMW [J] = "V" ;            # CREATE SYMBOL NAME #
               C<1,6> SYMW [J] = C<4,6> A ;        #     *VNNNNNN*    # 
               ISSUE (VLABEL, J) ;
               ISSUE (VBSS, 1) ;                  # GEN NAME BSS 1     #
               END
          CALL ASU ;                         # ACCUMULATE STORAGE USED #
          TEMPL = 0 ;                        # CLEAR TEMP VAR TABLE # 
          TDPLL = 0 ;                         # AND DBP LIST POINTERS # 
          IF  TXEQL NE 0
          THEN BEGIN
               ISSUE (XFORCE, RT"NO") ;      # COMPLETE BOTH OF THE # 
               ISSUE (VFORCE, RT"NO") ;       # INTERMEDIATE CODE  #
               ALLOC (P<TXEQ>, 1) ;            # TABLES TO NEXT   # 
               ALLOC (P<TVAR>, 1) ;             # WORD BOUNDARY  #
               XEQW [TXEQL-1] = INTW ;
               VARW [TVARL-1] = VBLW ;
               END
          RETURN ;
  
  
  
  
#***      BDL  -  BUILD DATA BASE PROCEDURE LIST. 
# 
          XDEF PROC BDL ; 
          PROC BDL ((PN)) ; 
  
          ITEM PN U ;              # PROCEDURE NAME # 
  
#         ADDS NAME TO TDBP IF NOT ALREADY THERE. 
*         LOOKS UP NAME IN TDPN TO GET ITS ORDINAL. 
****
# 
          BEGIN 
  
          ITEM I ;
  
          DBPN [TDBPL] = PN ; 
          FOR  I = 0  STEP 1                 # SEARCH TDBP #
               WHILE  DBPN [I] NE PN
               DO  BEGIN  END 
          IF  I NE TDBPL                     # RETURN IF FOUND #
          THEN RETURN ; 
          ALLOC (P<TDBP>, 1) ;               # ALLOCATE NEW TDBP ENTRY #
          DPNM [0] = PN ; 
          FOR  I = TDPNL-1 STEP -1           # SEARCH TDPN TO GET # 
               WHILE  DPNM [I] NE PN          # PROCEDURE ORDINAL # 
               DO  BEGIN  END 
          DBPN [TDBPL-1] = PN ;              # CONSTUCT TDBP ENTRY #
          DBPO [TDBPL-1] = I ;
          RETURN ;
  
          END 
  
  
  
  
#***      EXN  -  EXTERNAL NAME NUMBER. 
# 
          XDEF FUNC EXN ; 
          FUNC EXN (N) I ;
  
          ITEM N U ;               # EXTERNAL NAME #
  
#         RETURNS THE TEXT INDEX OF EXTERNAL SYMBOL NAME (N). 
*         ADDS THE NAME TO TEXT IF NOT ALREADY THERE. 
****
# 
          BEGIN 
  
          ITEM A C (WC), K I ;
  
          IF  B<0,ZL> N EQ 0            # IF ARGUMENT IS ALREADY AN # 
          THEN BEGIN                     # INTEGER THEN RETURN IT # 
               EXN  = N ; 
               RETURN ; 
               END
          A = " " ;                     # ZERO FILL NAME #
          C<0,NC> A = XZFN (C<0,NC> N) ;
          EXTN [TEXTL] = A ;
          FOR  K = 0  STEP 1            # SEARCH EXTERNAL NAME TABLE #
               WHILE  EXTN [K] NE A      # AND SET K = INDEX OF NAME #
               DO  BEGIN  END 
          IF  K EQ TEXTL
          THEN BEGIN                    # IF NOT FOUND #
               ALLOC (P<TEXT>, 1) ; 
               EXTN [K] = A ;                # MAKE NEW TEXT ENTRY #
               EXTA [K] = -1 ;
               END
          EXN = K ;                     # RETURN EXTERNAL INDEX # 
          RETURN ;
  
          END 
  
  
  
  
#***      GDA  -  GENERATE DATA BASE PROCEDURE APLIST.
# 
          PROC GDA (EC) ; 
  
          ITEM EC S:DBPENT ;       # ENTRY CODE # 
  
#         ENTRY  (DBPI) = TSYM INDEX OF PROC NAME LIST LABEL (FROM GDL).
*                (TDBPL) = NUMBER OF NAMES. 
*                (SCIP) = SCHEMA ITEM POINTER.
*                (SSIP) = SUB-SCHEMA ITEM POINTER.
* 
*         EXIT   (DBPA) = TSYM INDEX OF APLIST LABEL. 
*                (TDBPL) = 0. 
* 
*         GENERATES ACTUAL PARAMETER LIST FOR DB$DPII AS FOLLOWS. 
* 
*         LABEL     FWA LIST OF DBP"S TO CALL.
*          + 1      NUMBER OF DBP"S TO CALL.
*          + 2      ENTRY CODE VALUE. 
*          + 3      TARGET ITEM FWA (REL TO WSA FWA). 
*          + 4      TARGET ITEM BBP.
*          + 5      TARGET ITEM SIZE (BITS).
*          + 6      TARGET ITEM CLASS.
*          + 7      SOURCE ITEM FWA (REL TO WSA FWA). 
*          + 8      SOURCE ITEM BBP.
*          + 9      SOURCE ITEM SIZE (BITS).
*          +10      SOURCE ITEM CLASS.
****
# 
          BEGIN 
  
          ITEM SCCL, SCSZ, SSCL, SSSZ ; 
  
          SCCL = SCITEMCLASS [SCIP] ;        # EXTRACT SCHEMA ITEM #
          SCSZ = SCITEMSIZE [SCIP] * CL ;     # CLASS AND SIZE #
          SSCL = SBITMDBCLASS [SSIP] ;       # EXTRACT SUB-SCHEMA ITEM #
          SSSZ = SBITMUSESIZE [SSIP] * CL ;   # CLASS AND SIZE #
          DBPA = TSYML ;                     # GENERATE CODE  ...  #
          ISSUE (VLABEL, DBPA) ;                               # LABEL #
          ISSUE (VARG, RT"SYM", DBPI) ;                        #  + 0  #
          ISSUE (VARG, RT"LIT", - LITSI (TDBPL)) ;             #  + 1  #
          ISSUE (VARG, RT"LIT", - LITEC (EC)) ;                #  + 2  #
          IF  LOOPL NE 0
          THEN BEGIN                         # IF IN LOOP # 
               ISSUE (VARG, RT"EXT", X$TBWP) ;                 #  + 3  #
               ISSUE (VARG, RT"EXT", X$TBBP) ;                 #  + 4  #
               END
          ELSE BEGIN                         # IF FIXED # 
               ISSUE (VARG, RT"LIT", - LITSI (TBWP)) ;         #  + 3  #
               ISSUE (VARG, RT"LIT", - LITSI (TBBP)) ;         #  + 4  #
               END
          IF  GETF
          THEN BEGIN                         # IF TARGET = SUB-SCHEMA # 
               ISSUE (VARG, RT"LIT", - LITSI (SSSZ)) ;         #  + 5  #
               ISSUE (VARG, RT"LIT", - LITCL (SSCL)) ;         #  + 6  #
               END
          ELSE BEGIN                         # IF TARGET = SCHEMA # 
               ISSUE (VARG, RT"LIT", - LITSI (SCSZ)) ;         #  + 5  #
               ISSUE (VARG, RT"LIT", - LITCL (SCCL)) ;         #  + 6  #
               END
          IF  NSIF                      # IF NO SOURCE ITEM EXISTS #
          THEN BEGIN
               ISSUE (VARG, RT"LIT", - LITINT (-1)) ;          #  + 7  #
               ISSUE (VARG, RT"LIT", - LITSI (0)) ;            #  + 8  #
               IF  GETF 
               THEN BEGIN                    # IF SOURCE = SCHEMA # 
                    ISSUE (VARG, RT"LIT", - LITSI (SSSZ)) ;    #  + 9  #
                    ISSUE (VARG, RT"LIT", - LITCL (SSCL)) ;    #  +10  #
                    END 
               ELSE BEGIN                    # IF SOURCE = SUB-SCHEMA # 
                    ISSUE (VARG, RT"LIT", - LITSI (SCSZ)) ;    #  + 9  #
                    ISSUE (VARG, RT"LIT", - LITCL (SCCL)) ;    #  +10  #
               END  END 
          ELSE BEGIN                    # IF SOURCE ITEM DOES EXIST # 
               IF  LOOPL NE 0 
               THEN BEGIN                    # IF IN LOOP # 
                    ISSUE (VARG, RT"EXT", X$SBWP) ;            #  + 7  #
                    ISSUE (VARG, RT"EXT", X$SBBP) ;            #  + 8  #
                    END 
               ELSE BEGIN                    # IF FIXED # 
                    ISSUE (VARG, RT"LIT", - LITSI (SBWP)) ;    #  + 7  #
                    ISSUE (VARG, RT"LIT", - LITSI (SBBP)) ;    #  + 8  #
                    END 
               IF  GETF 
               THEN BEGIN                    # IF SOURCE = SCHEMA # 
                    ISSUE (VARG, RT"LIT", - LITSI (SCSZ)) ;    #  + 9  #
                    ISSUE (VARG, RT"LIT", - LITCL (SCCL)) ;    #  +10  #
                    END 
               ELSE BEGIN                    # IF SOURCE = SUB-SCHEMA # 
                    ISSUE (VARG, RT"LIT", - LITSI (SSSZ)) ;    #  + 9  #
                    ISSUE (VARG, RT"LIT", - LITCL (SSCL)) ;    #  +10  #
               END  END 
          ALLOC (P<TDBP>, - TDBPL) ;         # CLEAR DBP LIST # 
          RETURN ;
  
          END 
  
  
  
  
#***      GDC  -  GENERATE DATA BASE PROCEDURE CALL.
# 
          XDEF PROC GDC ; 
          PROC GDC (EC) ; 
  
          ITEM EC S:DBPENT ;       # ENTRY CODE # 
  
#         ENTRY  (TDBP) = LIST OF PROC NAMES AND ORDINALS.
*                (SCIP) = SCHEMA ITEM POINTER.
*                (SSIP) = SUB-SCHEMA ITEM POINTER.
* 
*         GENERATES CODE -
*         TO TVAR - PROC NAME LIST (IF NOT ALREADY THERE).
*                   APLIST FOR PROC CALL. 
*         TO TXEQ - SA1 APLIST
*                   RJ  =XDB$DPII 
*                   (FORCE UPPER).
****
# 
          BEGIN 
  
          CALL DSR ;                         # DEPOSIT STORE REGISTER # 
          CALL GDL ;                         # GENERATE DBP NAME LIST # 
          CALL GDA (EC) ;                    # GENERATE DBP APLIST #
          ISSUE (XNO, RT"SYM") ;
          ISSUE (OP"SABK", 1, 0, DBPA) ;            # GEN SA1 APLIST   #
          ISSUE (XNO, RT"EXT") ;
          ISSUE (OP"RJ", 0, 0, X$DPII) ;            # GEN RJ  =XDB$DPII#
          ISSUE (XFORCE, 0) ; 
          CALL CRA ;                         # CLEAR REGISTER ASSOC. #
          RETURN ;
  
          END 
  
  
  
  
#***      GDL  -  GENERATE DATA BASE PROCEDURE LIST.
# 
          PROC GDL ;
  
#         ENTRY  (TDBP) = LIST OF DBP NAMES AND ORDINALS (FROM BDL).
* 
*         EXIT   (DBPI) = TSYM INDEX OF LIST LABEL (FOR GDA). 
* 
*         GENERATES CODE IN TVAR -
*         LABEL     CON   0L FIRST NAME + ORDINAL 
*          + 1      CON   0L SECOND NAME + ORDINAL
*                   ET CETERA.
*         ALSO CREATES A TDPL ENTRY FOR THE LIST. 
*         AVOIDS GENERATING DUPLICATE LISTS.
*         THIS DBP LIST WILL BE REFERENCED IN THE APLIST
*         GENERATED BY *GDA*. 
****
# 
          BEGIN 
  
          ITEM I, J, K ;
  
#         SEARCH TDPL FOR MATCHING PROC NAME LIST.
# 
          FOR  I = 0 THRU TDPLL-1  DO 
               BEGIN
               IF  TDBPL LE DPLN [I]
               THEN BEGIN 
                    J = DPLA [I] ;
                    FOR  K = 0 THRU TDBPL-1  DO 
                         BEGIN
                         IF  DBPW [K] NE VARW [J+K] 
                         THEN TEST I ;
                         END
                    DBPI = DPLS [I] ;             # MATCH FOUND # 
                    RETURN ;
               END  END 
  
#         NO MATCH FOUND - ADD LIST TO TVAR.
# 
          ALLOC (P<TDPL>, 1) ;               # ALLOCATE NEW TDPL ENTRY #
          DBPI = TSYML ;                     # NOTE SYMBOL INDEX #
          ISSUE (VLABEL, DBPI) ;                    # GEN LABEL        #
          ISSUE (VSCON, TDBPL) ;                    # GEN CON OLNAME+N #
          DPLN [TDPLL-1] = TDBPL ;
          DPLA [TDPLL-1] = TVARL ;           # CONSTRUCT TDPL ENTRY # 
          DPLS [TDPLL-1] = DBPI ; 
          I = TVARL ;                        # ALLOCATE AND MOVE DBP #
          ALLOC (P<TVAR>, TDBPL) ;            # LIST TO TVAR #
          MOVEI (TDBPL, P<TDBP>, P<TVAR> + I) ; 
          RETURN ;
  
          END 
  
  
  
  
#***      GTV  -  GET TEMPORARY VARIABLE. 
# 
          XDEF FUNC GTV ; 
          FUNC GTV I ;
  
#         THE FUNCTION VALUE IS THE *TEMP* INDEX OF THE FIRST 
*         TEMPORARY VARIABLE THAT IS NOT CURRENTLY IN USE.  A 
*         NEW *TEMP* ENTRY IS CREATED IF NEEDED.  IN ANY CASE,
*         THE ENTRY IS MARKED BUSY. 
****
# 
          BEGIN 
  
          ITEM I ;
  
          TEMF [TEMPL] = FALSE ;
          FOR  I = 0  STEP 1                 # SEARCH FOR 1ST TEMP VAR #
               WHILE  TEMF [I]                # THAT IS NOT NOW IN USE #
               DO  BEGIN  END 
          IF  I EQ TEMPL                     # IF NONE FOUND #
          THEN BEGIN
               ALLOC (P<TEMP>, 1) ;          # CREATE NEW TEMP ENTRY #
               TEMV [I] = TSYML ; 
               ALLOC (P<TSYM>, 1) ;          # CREATE NEW TSYM ENTRY #
               SYMW [TSYML-1] = 0 ; 
               END
          TEMF [I] = TRUE ;                  # MARK TEMP VAR BUSY # 
          GTV = I ;                          # RETURN TEMP INDEX #
          RETURN ;
  
          END 
  
  
  
  
#***      IDP  -  IDENTIFY DATA-BASE PROCEDURES TO CALL.
# 
          XDEF PROC IDP ; 
          PROC IDP ((EC)) ; 
  
          ITEM EC S:DBPENT ;       # ENTRY CODE # 
  
#         ENTRY  (EC) = ENTRY CODE FOR DBP CALL.
* 
*         EXIT   (DBPA) = TSYM INDEX OF DB$DPII APLIST LABEL, OR
*                           0 IF NO PROCS TO BE CALLED. 
****
# 
          BEGIN 
  
          ITEM DONE B ;            # LOOP CONTROL # 
          ITEM I ;                 # INTEGER TEMPORARY #
  
          LABEL BIGET, EIGET, AIGET, XIGET ;
          LABEL BIMOD, EIMOD, AIMOD, XIMOD ;
          LABEL BISTO, EISTO, AISTO, XISTO ;
          LABEL ADD, NEXT ; 
  
          DBPA = 0 ;
          IF  SCITEMONPTR [SCIP] EQ 0        # IF NONE TO CALL #
          THEN RETURN ; 
  
          DONE = FALSE ;
          FOR  I = SCIP + SCITEMONPTR [SCIP]
                    STEP 1  WHILE  NOT DONE  DO 
               BEGIN
               SWITCH  CASE: DBPENT 
                         BIGET: BIGET,  EIGET: EIGET,  AIGET: AIGET,
                         BIMOD: BIMOD,  EIMOD: EIMOD,  AIMOD: AIMOD,
                         BISTO: BISTO,  EISTO: EISTO,  AISTO: AISTO ; 
               GO TO CASE [EC] ;
                    BEGIN 
  
           BIGET:   IF  SCITCALLBEF [I]      # CALL ... BEFORE GET #
                    THEN GO TO XIGET ;
                    ELSE GO TO NEXT ; 
           EIGET:   IF  SCITCALLERR [I]      # CALL ... ON ERROR #
                    THEN GO TO XIGET ;        # DURING GET #
                    ELSE GO TO NEXT ; 
           AIGET:   IF  SCITCALLAFT [I]      # CALL ... AFTER GET # 
                    THEN GO TO XIGET ;
                    ELSE GO TO NEXT ; 
  
           BIMOD:   IF  SCITCALLBEF [I]      # CALL ... BEFORE MODIFY # 
                    THEN GO TO XIMOD ;
                    ELSE GO TO NEXT ; 
           EIMOD:   IF  SCITCALLERR [I]      # CALL ... ON ERROR #
                    THEN GO TO XIMOD ;        # DURING MODIFY # 
                    ELSE GO TO NEXT ; 
           AIMOD:   IF  SCITCALLAFT [I]      # CALL ... AFTER MODIFY #
                    THEN GO TO XIMOD ;
                    ELSE GO TO NEXT ; 
  
           BISTO:   IF  SCITCALLBEF [I]      # CALL ... BEFORE STORE #
                    THEN GO TO XISTO ;
                    ELSE GO TO NEXT ; 
           EISTO:   IF  SCITCALLERR [I]      # CALL ... ON ERROR #
                    THEN GO TO XISTO ;        # DURING STORE #
                    ELSE GO TO NEXT ; 
           AISTO:   IF  SCITCALLAFT [I]      # CALL ... AFTER STORE # 
                    THEN GO TO XISTO ;
                    ELSE GO TO NEXT ; 
  
                    END                 # OF CASE [EC] #
  
      XIGET:   IF  SCITCALLGET [I]           # CALL ... ... GET # 
               THEN GO TO ADD ; 
               ELSE GO TO NEXT ;
      XIMOD:   IF  SCITCALLMOD [I]           # CALL ... ... MODIFY #
               THEN GO TO ADD ; 
               ELSE GO TO NEXT ;
      XISTO:   IF  SCITCALLSTO [I]           # CALL ... ... STORE # 
               THEN GO TO ADD ; 
               ELSE GO TO NEXT ;
  
      ADD:     CALL BDL (SCITEMONCALL [I]) ;   # BUILD DBP LIST # 
  
      NEXT:    DONE  =  NOT  SCITEMNEXTON [I] ; 
               END                           # OF I LOOP #
  
#         IF  ANY PROCS ARE TO BE CALLED, GENERATE PROC NAME
*         LIST AND APLIST INTO OBJECT CODE. 
# 
          IF  TDBPL NE 0
          THEN BEGIN
               CALL GDL ;               # GENERATE DBP NAME LIST #
               CALL GDA (EC) ;          # GENERATE DBP APLIST # 
               END
          RETURN ;
  
          END 
  
  
  
  
#***      LDN  -  LITERAL DESCRIPTOR NUMBER.
# 
          XDEF FUNC LDN ; 
          FUNC LDN (A) I ;
  
          ITEM A I ;               # LOC OF LITERAL DESCRIPTOR #
  
#         RETURNS THE TLIT INDEX OF THE LITERAL WHOSE DESCRIPTOR
*         BEGINS AT LOCATION (A).  ADDS THE LITERAL DESCRIPTOR TO 
*         TLIT IF NOT ALREADY THERE.
****
# 
          BEGIN 
  
          BASED ARRAY LITD ;       # LITERAL DESCRIPTOR # 
               BEGIN
               ITEM DL I (0, 0, 6) ;    # LENGTH OF VALUE IN TCON # 
               ITEM DA I (0, 6,18) ;    # INDEX OF VALUE IN LITD #
               ITEM DC I (0,24,18);     # CHAR LENGTH OF LITERAL #
               ITEM DN I (0,42,18);     # LENGTH OF THIS LITD ENTRY # 
               ITEM DW ;                # LITERAL WORD #
               END
          ITEM K, L, M, N, T, W ; 
          LABEL LDN1, LDN2 ;
  
          IF A GE 0                     # IF ALREADY CONVERTED #
          THEN BEGIN
               LDN = A ;                # RETURN ARGUMENT UNCHANGED # 
               RETURN ; 
               END                      # ELSE (A) = NEGATIVE OF FWA OF#
          P<LITD> = - A ;               # ARRAY SIMILAR TO A TLIT ENTRY#
          L = DL ;                      # FOLLOWED BY A TCON ENTRY #
          M = DA ;
          T = TCONL - L ;               # SEARCH FOR A MATCHING VALUE # 
          FOR  N = 0 THRU T  DO          # ALREADY IN CONSTANT TABLE #
               BEGIN
               FOR  W = 0 THRU L-1  DO       # COMPARE VALUE WORDS #
                    BEGIN 
                    IF  DW [M+W] NE CONW [N+W]
                    THEN TEST N ; 
                    END 
               DA = N ;                 # FOUND, SET POINTER FIELD #
               GO TO LDN1 ;             # GO LOOK FOR DESCRIPTOR #
               END
          DA = TCONL ;                  # NOT FOUND, ADD VALUE WORDS #
          ALLOC (P<TCON>, L) ;           # TO CONSTANT VALUE TABLE #
          MOVEI (L, P<LITD> + M, P<TCON> + DA) ;
          GO TO LDN2 ;                  # GO MAKE DESCRIPTOR FOR IT # 
  
 LDN1:    T = TLITL - 1 ;                # TRY TO FIND DESCRIPTOR # 
          FOR  K = 0  STEP LITN [K]  UNTIL T  DO
               BEGIN
               N = LITN [K] - 1 ; 
               FOR  W = 0 THRU N  DO         # COMPARE DESCRIPTOR # 
                    BEGIN 
                    IF  LITW [K+W] NE DW [W]
                    THEN TEST K ; 
                    END 
               DA = M ;                 # FOUND, K = INDEX OF # 
               LDN = K ;                 # DESCRIPTOR IN TLIT # 
               RETURN ; 
               END
  
 LDN2:    K = TLITL ;                   # MAKE NEW DESCRIPTOR # 
          N = DN ;
          ALLOC (P<TLIT>, N) ;
          MOVEI (N, P<LITD>, P<TLIT> + K) ; 
          DA = M ;
          LDN = K ;                     # K = INDEX INTO TLIT # 
          RETURN ;
  
          END 
  
  
  
  
#***      PADV  -  PAD *TVAR* TO WORD BOUNDARY. 
# 
          XDEF PROC PADV ;
          PROC PADV ; 
  
#***
# 
          BEGIN 
  
          IF  VPOS NE 0                      # IF NOT AT WORD BOUNDARY #
          THEN BEGIN
               VPOS = 0 ; 
               ALLOC (P<TVAR>, 1) ;               # STORE CURRENT WORD #
               VARW [TVARL-1] = VBLW ;
               VBLW = 0 ;                         # START NEW WORD #
               END
          RETURN ;
  
          END 
  
  
  
  
#***      PADX  -  PAD *TXEQ* TO WORD BOUNDARY. 
# 
          XDEF PROC PADX ;
          PROC PADX ; 
  
#***
# 
          BEGIN 
  
          IF  XPOS NE 0                      # IF NOT AT WORD BOUNDARY #
          THEN BEGIN
               XPOS = 0 ; 
               ALLOC (P<TXEQ>, 1) ;               # STORE CURRENT WORD #
               XEQW [TXEQL-1] = INTW ;
               INTW = 0 ;                         # START NEW WORD #
               END
          RETURN ;
  
          END 
  
  
  
  
#***      SRL  -  SET RECORD LENGTH.
# 
          XDEF PROC SRL ; 
          PROC SRL ;
  
#         CALLED BY *MAPRD* AND *MAPWR* AT THE END OF EACH RECORD 
*         MAPPING CAPSULE, TO GENERATE CODE TO STORE THE TARGET 
*         RECORD LENGTH INTO THE *RL* FIELD OF THE *FIT*. 
****
# 
          BEGIN 
  
          ITEM J ;
  
          CALL SAR (1, RK"EXT", X$MFIT, 0) ;      # GEN SA1 =XDB$MFIT  #
          LOCKX [1] = TRUE ;
          IF  VARF                                # IF TARGET REC ENDS #
          THEN BEGIN                              # WITH VAR DIM GROUP #
               LOCKX [4] = TRUE ; 
               IF  TOBF [1]                       # IF OFFSET IN BITS # 
               THEN BEGIN 
                    CALL GXR (J, RK"CON",           # GEN SX2 2**19/6+1#
                              524288 / CL + 1, CF"INT") ; 
                    ISSUE (OP"DMUL", 6, 4, J) ;     # GEN IX6 X4*X2    #
                    ISSUE (OP"RIGHTK", 6, 0, 19) ;  # GEN AX6 19       #
                    END 
               ELSE BEGIN                         # IF OFFSET IN WORDS #
                    CALL GXR (J, RK"CON", 
                              WC, CF"INT") ;        # GEN SX2 10       #
                    ISSUE (OP"DMUL", 6, 4, J) ;     # GEN IX6 X4*X2    #
               END  END 
          ELSE BEGIN
               IF  GETF                           # IF FIXED REC LENGTH#
               THEN J = SBRECLENGTH [SSRP] ;
               ELSE J = SCRECLENGTH ;               # GEN SX6 RECLENGTH#
               CALL SXR (6, RK"CON", J, CF"INT") ;
               END
          ISSUE (C$SRL, 0, 0, 0) ;                # GEN STORE X1,RL=X6 #
          RETURN ;
  
          END 
  
  
  
  
#***      SYN  -  SYMBOL NAME NUMBER. 
# 
          XDEF FUNC SYN ; 
          FUNC SYN (S) I ;
  
          ITEM S C (WC) ;          # SYMBOL NAME #
  
#         RETURNS THE TSYM INDEX OF SYMBOL NAME (S).
*         ADDS THE NAME TO TSYM IF NOT ALREADY THERE. 
****
# 
          BEGIN 
  
          ITEM A C (WC) ; 
          ITEM K, L, N, W ; 
  
          IF  B<0,ZL> S EQ 0                 # IF S = SYMBOL INDEX #
          THEN BEGIN
               K = B<ZL,AL> S ; 
               N = K - TSYML + 1 ;
               IF  N GT 0                    # IF PAST TSYM END # 
               THEN BEGIN 
                    ALLOC (P<TSYM>, N) ;
                    L = TSYML - 1 ;               # ALLOCATE WORDS #
                    FOR  W = TSYML - N THRU L  DO 
                         SYMW [W] = 0 ;                # AND CLEAR THEM#
               END  END 
          ELSE BEGIN                         # IF S = SYMBOL NAME # 
               A = XSFW (C<0,NC> S ) ;            # SPACE FILL WORD # 
               SYMW [TSYML] = A ; 
               FOR  K = 0  STEP 1                 # SEARCH TSYM # 
                    WHILE  SYMN [K] NE C<0,NC> A
                    DO  BEGIN  END
               IF  K EQ TSYML                     # IF NOT FOUND #
               THEN BEGIN 
                    ALLOC (P<TSYM>, 1) ;               # ADD NEW ENTRY #
                    SYMN [K] = A ;
                    SYMA [K] = 0 ;
               END  END 
          SYN = K ;                          # RETURN SYMBOL INDEX #
          RETURN ;
  
          END 
  
     END  TERM
