*COMDECK     COMMAPRD   - COMPILE READ RECORD MAPPING CODE CAPSULE. 
#*        MAPRD  -  COMPILE READ RECORD MAPPING CODE CAPSULE. 
* 
*         R. H. GOODELL.     77/02/17.
*         A. C. SALACUSE.    77/03/16.
* 
*         *MAPRD* CONTROLS THE COMPILATION OF A CODE CAPSULE TO 
*         PERFORM CONVERSION OF A DATA RECORD FROM SCHEMA FORMAT
*         TO SUB-SCHEMA FORMAT, AS WHEN READING THE RECORD FROM 
*         THE DATABASE.  THIS CORRESPONDS TO THE *GET* OPERATION
*         OF THE *CDCS* DATABASE MANAGEMENT SYSTEM. 
* 
*         ON ENTRY, THE SUB-SCHEMA DIRECTORY IS IN TABLE *TSUB* 
*         WITH *SSRP* POINTING TO THE CURRENT RECORD ENTRY, AND 
*         THE CORRESPONDING SCHEMA RECORD ENTRY, POINTED TO BY
*         *SCRA*, IS IN TABLE *TSCH* ALONG WITH ALL OF ITS ITEM 
*         ENTRIES.
* 
*         MAPPING CODE IS GENERATED FOR EACH ITEM ONE AT A TIME 
*         (EXCEPT FOR IDENTICAL BLOCKS) IN THE ORDER IN WHICH THE 
*         ITEM ENTRIES OCCUR IN THE SUB-SCHEMA DIRECTORY. 
* 
*         CONTENTS (XDEF ENTRY POINTS). 
* 
*         PROC   MAPRD       COMPILE READ RECORD MAPPING CODE CAPSULE.
# 
  
  
*CALL     COMDDEF            GENERAL DEFINITIONS. 
  
     XREF BEGIN               # MANAGED TABLES #
  
*CALL     COMDTDBP           DATA BASE PROCEDURES.
  
*CALL     COMDTEMP           TEMPORARY VARIABLES. 
  
*CALL     COMDTSCH           SCHEMA DIRECTORY (CURRENT PORTION).
  
*CALL     COMDTSUB           SUB-SCHEMA DIRECTORY + FINISHED CAPSULES.
  
*CALL     COMDTSYM           SYMBOL TABLE.
  
          END 
*CALL     COMDREG            REGISTER INFORMATION.
  
     XREF BEGIN               # OTHER EXTERNALS # 
  
*CALL     COMDLOOP           LOOP NESTING CONTROL TABLE.
*CALL     COMDPRFX           CAPSULE PREFIX TABLE.
          ITEM C$FWSA ;            # CODE -   FETCH X1,WSA,X6 # 
          ITEM DBPA ;              # TSYM INDEX OF DBP APLIST LABEL # 
          ITEM DCTN ;              # DISPLAY TO COLLATING TABLE NAME #
          ITEM FWAF B ;            # TRUE IF DC$SFWA AND DC$TFWA SET #
          ITEM GETF B ;            # TRUE WHEN GENERATING READ MAPPING #
          ITEM GROUP ;             # BIT MASK FOR GROUP DATA TYPES #
          ITEM LOOPL ;             # LOOP NESTING LEVEL # 
          ITEM NEXT ;              # NEXT SCHEMA ITEM POINTER # 
          ITEM NSIF B ;            # NO SOURCE ITEM FLAG #
          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 SBBP ;              # SOURCE BEGINNING BIT POSITION #
          ITEM SBWP ;              # SOURCE BEGINNING WORD POSITION # 
          ITEM SCIP ;              # SCHEMA ITEM ENTRY POINTER #
          ITEM SI ;                # SOURCE ITEM INDEX #
          ITEM SSIO ;              # SUB-SCHEMA ITEM ORDINAL #
          ITEM SSIP ;              # SUB-SCHEMA ITEM ENTRY POINTER #
          ITEM SSNI ;              # NUMBER OF ITEMS IN SUB-SCHEMA REC #
          ITEM SW ;                # SOURCE WORD INDEX #
          ITEM SSRP ;              # SUB-SCHEMA RECORD ENTRY POINTER #
          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 VARF B ;            # TRUE IF IN A VARIABLE DIMENSION #
          ITEM VECTOR ;            # BIT MASK FOR VECTOR DATA TYPES # 
          ITEM X$DPII ;            # NAME OF DBP INTERFACE ITEM LEVEL # 
          ITEM X$MERP ;            # NAME OF ERROR DBP APLIST FWA # 
          ITEM X$MFIT ;            # NAME OF FILE INFORMATION TABLE FWA#
          ITEM X$MSCH ;            # NAME OF SCHEMA RECORD AREA FWA # 
          ITEM X$MSUB ;            # NAME OF SUB-SCHEMA RECORD AREA 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 TARGER BEGINNING WORD POS #
          PROC ALLOC ;             # ALLOCATE TABLE SPACE # 
          PROC BDL ;               # BUILD DBP LIST # 
          PROC CRA ;               # CLEAR REGISTER ASSOCIATES #
          PROC DSR ;               # DEPOSIT STORE REGISTER # 
          PROC FXR ;               # FIND X-REGISTER WITH SPECIFIED VAL#
          PROC GAR ;               # GET A-REGISTER WITH SPECIFIED VAL #
          PROC GBM ;               # GENERATE BLOCK MOVE #
          PROC GCC ;               # GENERATE CHECK CODE #
          PROC GDC ;               # GENERATE DBP CALL #
          PROC GIC ;               # GENERATE ITEM CONVERSION CODE #
          PROC GLC ;               # GENERATE LOOP CODE # 
          PROC GXR ;               # GET X-REGISTER WITH SPECIFIED VAL #
          PROC IDP ;               # IDENTIFY DATA-BASE PROCS TO CALL # 
          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 SAR ;               # SET SPECIFIED A-REGISTER TO VALUE #
          PROC SLC ;               # SET LOOP CONTROLS #
          PROC SXR ;               # SET SPECIFIED X-REGISTER TO VALUE #
          FUNC SYN I ;             # SYMBOL NAME NUMBER # 
          PROC SRL ;               # SET RECORD LENGTH #
  
          END 
  
  
*CALL     COMDCF             CONSTANT FORMATS.
  
  
*CALL     COMDDBPE           DATA BASE PROCEDURE ENTRY CODES. 
  
  
*CALL     COMDITEM           DIRECTORY ITEM ENTRY CLASS AND TYPE CODES. 
  
  
*CALL     COMDOPS            OPERATION CODES. 
  
  
*CALL     COMDPSOP           PSEUDO OPERATION ISSUING DEFS. 
  
  
#         LOCAL DATA. 
# 
          ITEM APLIST ;            # TSYM INDEX OF ACTUAL PARAM LIST #
          ITEM DBPF B ;            # TRUE IF ITEM IS RESULT OF A DBP #
          ITEM DONE B ;            # LOOP CONTROL FLAG #
          ITEM ERRA = 0 ;          # NON-ZERO IF ANY *ON ERROR* DBP # 
          ITEM FIRST B ;           # FLAGS USED IN END-AROUND SEARCH #
          ITEM FOUND B ;            # OF SUB-SCHEMA ITEM ENTRIES #
          ITEM I ;                 # INTEGER TEMPORARY #
          ITEM LOOPFLAG;           # ZERO VALUE FLAGS END OF LOOP      #
          ITEM NNUL = 0 ;          # NON-NULL OCCURRENCE JUMP LABEL IND#
          ITEM NULL = 0 ;          # NULL OCCURRENCE LABEL TSYM INDEX # 
          ITEM PL ;                # POINT LOCATION (+=LEFT, -=RIGHT) # 
  
  
  
  
#***      MAPRD  -  COMPILE READ RECORD MAPPING CODE CAPSULE. 
  
          PROC MAPRD
  
*         A READ RECORD MAPPING CODE CAPSULE BEGINS WITH A
*         PROLOGUE TO GET THE SCHEMA RECORD WSA FROM THE FIT
*         AND STORE IT INTO DC$MSCH.  SUBSEQUENT CODE MOVES 
*         DATA ITEMS FROM THE SOURCE (SCHEMA) RECORD AREA TO
*         THE TARGET (SUB-SCHEMA) RECORD AREA.  ITEMS ARE 
*         PROCESSED IN THE ORDER IN WHICH THEY OCCUR IN THE 
*         TARGET RECORD DESCRIPTION.  ITEMS ARE MOVED ONE 
*         ELEMENTARY ITEM AT A TIME, AND ONE OCCURRENCE AT A
*         TIME, EXCEPT WHEN A SERIES OF ITEMS AND/OR OCCURRENCES
*         CAN BE MOVED AS A UNIT SAFELY (I.E., SAME DATA FORMAT 
*         AND WORD ALIGNMENT IN BOTH SOURCE AND TARGET RECORD 
*         IMAGES).  NOTE THAT THE CODE GENERATOR RELIES ON THE
*         SUB-SCHEMA COMPILER TO FLAG SUCH A SERIES OF ITEMS IN 
*         THE SUB-SCHEMA DIRECTORY. 
* 
*         *OCCURS* CLAUSES CAUSE GENERATION OF LOOP-CONTROL 
*         CODE, TO INITIALISE, INCREMENT, AND TEST A CONTROL
*         VARIABLE LOCAL TO THE CAPSULE.  IF LOOPS ARE NESTED,
*         MULTIPLE SUBSCRIPT VALUES ARE LINEARISED BY INDUCTION 
*         RATHER THAN CUMULATIVE MULTIPLY-AND-ADD CODE. 
* 
*         PROCESSING FOR EACH OCCURRENCE OF EACH ITEM IS DONE 
*         IN THE FOLLOWING SEQUENCE.
*         IGNORE *REDEFINES* AND *RENAMES* ITEMS. 
*         CALL ITEM-LEVEL *BEFORE GET* DBPS IF ANY. 
*         IF ANY *ON ERROR DURING GET* DBPS ARE SPECIFIED,
*         SET DB$MERP.
*         IF A *VIRTUAL RESULT* DBP IS SPECIFIED, CALL IT.
*         IF A *DECODING ALWAYS* DBP IS SPECIFIED, CALL IT. 
*         IF A *DECODING* DBP IS SPECIFIED AND THE DATA ITEM
*         DESCRIPTIONS ARE NOT IDENTICAL, CALL IT.
*         IF NO *VIRTUAL RESULT* NOR *DECODING [ALWAYS]* DBP
*         WAS CALLED, CONVERT AND/OR MOVE THE ITEM VALUE FROM 
*         SOURCE TO TARGET RECORD AREA.  DO THIS WITH IN-LINE 
*         CODE OR BY CALLING *CDCS* DATA CONVERSION OR TRANSFER 
*         ROUTINES.  IF ERROR IN CONVERSION, SET ERROR FLAG 
*         (DB$MERF) AND EXIT. 
*         IF THE ITEM IS A *VIRTUAL RESULT* AND HAS A *CHECK* 
*         CLAUSE, THEN  ... 
*              IF A *CHECK IS VALUE ...* CLAUSE THEN COMPARE
*              VALUES GIVEN BY CALLING DC$CMPR.  IF CHECK 
*              FAILS, SET ERROR FLAG (DB$MERF) AND EXIT.
*              IF A *CHECK* DBP IS GIVEN, CALL IT.
*         IF ANY *ON ERROR DURING GET* DBPS WERE SPECIFIED, 
*         CLEAR DB$MERP.
*         CALL ITEM-LEVEL *AFTER GET* DBPS IF ANY.
*         PROCEED TO NEXT ITEM OR OCCURRENCE. 
* 
*         AT THE END OF THE RECORD, IF THE SOURCE AND TARGET
*         RECORD LENGTHS DIFFER, THE CAPSULE ADJUSTS THE RECORD 
*         LENGTH (RL) IN THE FIT BEFORE RETURNING TO *CDCS*.
* 
*         A READ RECORD MAPPING CODE CAPSULE CAN REFERENCE THE
*         FOLLOWING EXTERNAL SYMBOLS. 
*         PROC DB$DPII - DATABASE PROCEDURE INTERFACE, ITEM LEVEL.
*         ARRAY DB$MDCA - DISPLAY CODE TO ASCII COLLATING TABLE.
*         ARRAY DB$MDCC - DISPLAY CODE TO COBOL COLLATING TABLE.
*         ARRAY DB$MDCU - DISPLAY CODE TO USER CODE COLLATING TABLE.
*         ARRAY DB$MDCX - DISPLAY CODE TO D.C. COLLATING TABLE. 
*         ITEM DB$MERF - ERROR FLAG SET BY DC$CONV ETC. 
*         ITEM DB$MERP - FWA OF DB$DPII APLIST FOR *ON ERROR*.
*         ITEM DB$MFIT - FWA OF FILE INFORMATION TABLE. 
*         ITEM DB$MSUB - FWA OF SUB-SCHEMA (TARGET) RECORD AREA.
*         PROC DC$CMPR - COMPARE ITEM VALUES - FOR *CHECK*. 
*         PROC DC$CONV - CONVERT ITEM VALUE.
*         ITEM DC$MSCH - FWA OF SCHEMA (SOURCE) RECORD AREA.
*         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 = TRUE ; 
          PRFXKIND = "READ" ; 
          QSRA = X$MSCH ; 
          QTRA = X$MSUB ; 
          QBUF = X$MSUB ; 
          CALL CRA ;                    # CLEAR REGISTER ASSOCIATES # 
          CALL SAR (1, RK"EXT", X$MFIT, 0) ;      # GEN SA1 =XDB$MFIT  #
          ISSUE (C$FWSA, 0, 0, 0) ;               # GEN FETCH X1,WSA,X6#
          CALL SAR (6, RK"EXT", X$MSCH, 0) ;      # GEN SA6 =XDC$MSCH  #
  
#         PROCESS EACH ITEM IN SUBSCHEMA RECORD DESCRIPTION.
# 
          NEXT = SSRP + SBRECNXITEMP [SSRP] ; #SET TO FIRST ITEM# 
          LOOPFLAG = NEXT;                   # ARBITRARY NON-ZERO      #
  
          FOR SSIO = SSIO WHILE LOOPFLAG NQ 0 
          DO
               BEGIN
  
#         IGNORE *REDEFINE/RENAME* ITEM.
# 
               IF  SBITMREDEFFG [NEXT]
                 OR  SBITMLEVEL [NEXT] EQ 50
               THEN BEGIN 
                    LOOPFLAG = SBITMNEXTP [NEXT]; 
                    NEXT = NEXT + LOOPFLAG; 
                    TEST SSIO ; 
                    END 
  
#         GENERATE LOOP CODE IF PREVIOUS ITEM IS LAST OF ITS LEVEL. 
# 
               FOR  TLEV = SBITMLEVEL [NEXT]
                      WHILE  LOOPL NE 0 
                           AND  LLEV [LOOPL] GE TLEV
                    DO  CALL GLC ;           # GENERATE LOOP CODE # 
  
#         SET SUB-SCHEMA ITEM POINTER FOR NEW ITEM. 
# 
               SSIP = NEXT ;
               LOOPFLAG = SBITMNEXTP [NEXT];
               NEXT = NEXT + LOOPFLAG;
               SSIO = SBITMORDINAL [SSIP];   # SET ITEM ORDINAL        #
               SCIP = SBITMSCPTR [SSIP] ;    # SET SCHEMA ITEM POINTER #
               NSIF = SCIP EQ 0 ;            # IF TRUE NO SOURCE ITEM # 
               FWAF = FALSE ; 
                                             # LIST SOURCE LINE NUMBER #
               ISSUE (XLINE, SBITMSRCLNEN [SSIP]) ; 
  
#         SET LOOP CONTROLS IF ITEM IS A VECTOR OR REPEATING GROUP. 
# 
               IF  LOOPL EQ 0 
               THEN VARF = FALSE ;           # IF ITEM DOES NOT START # 
               IF  SBITMBLOCKSZ [SSIP] EQ 0   # A NO-MAP BLOCK #
               THEN BEGIN 
                    IF  SBITMOCCURP [SSIP] NE 0  # IF *OCCURS* CLAUSE # 
                    THEN CALL SLC ;                # SET LOOP CONTROLS #
                    I = SBITMTYPE [SSIP] ;
                    IF  B<I> GROUP NE 0 
                    THEN TEST SSIO ;            # DONE IF GROUP ITEM #
                    END 
  
#         PROCESS ELEMENTARY ITEM OR NO-MAP BLOCK.
# 
               CALL SIL ;                    # SET ITEM LOCATION #
               DBPF = FALSE ; 
  
#         PROCESS *BEFORE GET* ITEM-LEVEL DBP CALLS, IF ANY.
# 
               CALL IDP (DBPENT"BIGET") ; 
               IF  DBPA NE 0  THEN BEGIN     # IF ANY PROCS TO CALL # 
                    CALL DSR ;               # DEPOSIT STORE REGISTER  #
                    ISSUE (XNO, RT"SYM") ;   # GEN SA1 APLIST # 
                    ISSUE (OP"SABK", 1, 0, DBPA) ;
                    ISSUE (XNO, RT"EXT") ;   # GEN  RJ =XDB$DPII #
                    ISSUE (OP"RJ", 0, 0, X$DPII) ;
                    CALL CRA;                # CLEAR REG. ASSOC. #
                    ISSUE (XFORCE, 0) ; 
                    END 
  
#         PROCESS *ON ERROR DURING GET* ITEM-LEVEL DBP CALLS. 
# 
               CALL IDP (DBPENT"EIGET") ; 
               IF  DBPA NE 0  THEN BEGIN
                    ERRA = DBPA ;            # NZ IF ANY ERROR PROCS #
                    CALL DSR ;               # DUMP STORE REGISTERS # 
                    ISSUE (XNO, RT"SYM") ;   # GEN SX6 ERADR #
                    ISSUE (OP"SXBK", CSRN, 0, DBPA) ; 
                    REGX [CSRN] = 0 ;        # GEN SA6 =XDB$MERP #
                    CALL SAR (CSRN, RK"EXT", X$MERP, 0) ; 
                    END 
  
#         PROCESS *VIRTUAL RESULT* DBP CALL, IF ANY.
# 
               I = SCITMATVTP [SCIP] ;
               IF  I NE 0  AND  SCITMAVRESLT [SCIP+I] 
               THEN BEGIN 
                    CALL BDL (SCITEMRESULT [SCIP+I]) ;# BUILD DBP LIST #
                    CALL GDC (DBPENT"VIRTUAL") ;      # GEN DBP CALL #
                    DBPF = TRUE ;            # INDICATE RESULT FROM DBP#
                    END 
  
#         PERFORM CONVERSION OF ITEM VALUE. 
# 
               ELSE CALL PCV ;               # CONVERT VALUE #
  
#         PROCESS *CHECK* CLAUSE, IF *VIRTUAL RESULT*.
# 
               I = SCITMATVTP [SCIP] ;
               IF  I NE 0  AND  SCITMAVRESLT [SCIP + I] 
               THEN BEGIN 
                    I = SCITEMCHECKS [SCIP]; # LOCATE CHECK INFO #
                    IF  I NE 0
                    THEN BEGIN               # IF ANY *CHECK* CLAUSE #
                         I = SCIP + I ; 
                         IF  SCITMCKVALUE [I] # IF *CHECK IS VALUE* # 
                         THEN BEGIN               # GENERATE CHECK CODE#
                              PL = SBITMPTLOC [SSIP] ;
                              IF  SBITMLFTPT [SSIP] EQ 0
                              THEN PL = - PL ;
                              CALL GCC (SBITMDBCLASS [SSIP],
                                        SBITMUSESIZE [SSIP] * CL, 
                                        SBITMSIGNF [SSIP],
                                        SBITMACTLPT [SSIP], PL) ; 
                              END 
                         IF  SCITMCKDBP [I]  # IF *CHECK IS PROC-NAME* #
                         THEN BEGIN          # BUILD DBP LIST # 
                              CALL BDL (SCITMCKPROC [I]) ;
                              CALL GDC (DBPENT"CHECK") ; # GEN DBP CALL#
                         END  END 
                    END 
  
#         CLEAR *ON ERROR DURING GET* ITEM-LEVEL DBP CALLS. 
# 
               IF  ERRA NE 0
               THEN BEGIN 
                    CALL DSR ;                    # DEPOSIT STORE REG. #
                    CALL SXR (CSRN, RK"CON", 0, 0) ;# GEN SX6 0        #
                    CALL SAR (CSRN, RK"EXT", X$MERP, 0) ; 
                    END                             # GEN SA6 =XDB$MERP#
  
#         PROCESS *AFTER GET* ITEM-LEVEL DBP CALLS, IF ANY. 
# 
               CALL IDP (DBPENT"AIGET") ; 
               IF  DBPA NE 0   THEN BEGIN    # IF ANY PROCS TO CALL # 
                    CALL DSR ;               # DEPOSIT STORE REGISTERS #
                    ISSUE (XNO, RT"SYM") ;   # GEN SA1 APLIST # 
                    ISSUE (OP"SABK", 1, 0, DBPA) ;
                    ISSUE (XNO, RT"EXT") ;    # GEN  RJ =XDB$DPII # 
                    ISSUE (OP"RJ", 0, 0, X$DPII) ;
                    CALL CRA;                # CLEAR REG. ASSOC. #
                    ISSUE (XFORCE, 0) ; 
                    END 
  
#         PROCEED TO NEXT ITEM IN RECORD. 
# 
                                             # IF FIRST ITEM OF BLOCK # 
               IF   SBITMBLOCKSZ [SSIP] NE 0  # OF NO-MAP ITEMS THEN #
               THEN BEGIN                      # SET POINTERS TO FIRST #
                    NEXT = SBITMNXSSWA [SSIP] ;  # ITEM FOLLOWING BLOCK#
                    LOOPFLAG = NEXT;         # ZERO AT END OF RECORD   #
               END  END 
  
  
#         FINISH UNCOMPLETED LOOPS IF ANY.
# 
          FOR  TLEV = 0 
               WHILE  LOOPL NE 0
               DO  CALL GLC ;                # GENERATE LOOP CODE # 
  
#         COMPLETE GENERATION OF CAPSULE. 
# 
          CALL DSR ;                         # DEPOSIT STORE REGISTER # 
          CALL SRL ;                         # STORE RECORD LENGTH #
          ISSUE (XNO, RT"SYM") ;             # GEN  JP  EXIT.          #
          ISSUE (OP"JP", 0, 0, "EXIT.") ; 
          RETURN ;
  
  
  
  
  
#***      PCV  -  PROCESS CONVERSION OF ITEM VALUE. 
# 
          PROC PCV ;
  
#***
# 
          BEGIN 
  
          ITEM SP, TP ; 
  
          CALL PDE ;                         # PROCESS DECODING DBP # 
          IF  NOT DBPF
          THEN BEGIN
               IF  SBITMBLOCKSZ [SSIP] NE 0 
               THEN CALL GBM ;               # GENERATE BLOCK MOVE, OR #
               ELSE BEGIN                    # GENERATE ITEM CONVERSION#
                    SP = SCITEMPTLOC [SCIP] ; 
                    IF  NOT SCITEMPTLEFT [SCIP] 
                    THEN SP = - SP ;
                    TP = SBITMPTLOC [SSIP] ;
                    IF  SBITMLFTPT [SSIP] EQ 0
                    THEN TP = - TP ;
                    CALL GIC (SCITEMCLASS [SCIP], RK"SRA",
                              SCITEMSIZE [SCIP] * CL, 0, SP,
                              SCITEMACTLPT [SCIP], SCITEMSIGNFG [SCIP], 
                              SBITMDBCLASS [SSIP], RK"TRA", 
                              SBITMUSESIZE [SSIP] * CL, 
                              SBITMJUST [SSIP], TP, 
                              SBITMACTLPT [SSIP], SBITMSIGNF [SSIP]) ;
               END  END 
          RETURN ;
  
          END 
  
  
  
  
#***      PDE  -  PROCESS *DECODING* DBP CALL, IF ANY.
# 
          PROC PDE ;
  
  
#***
# 
          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 
                    IF  SCITEMENCODE [I] NE 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                    # GENERATE DBP CALL #
                    CALL GDC (DBPENT"DECODE") ; 
                    DBPF = TRUE ;            # INDICATE RESULT FROM DBP#
               END  END 
          RETURN ;
  
          END 
  
  
  
  
#***      SIL  -  SET ITEM LOCATION.
# 
          PROC SIL ;
  
#***
# 
          BEGIN 
  
          ITEM I, J, K, M, V ;     # INTEGER TEMPORARIES #
  
#         SET TARGET ITEM LOCATION. 
# 
          TBWP = SBITMBWP [SSIP] ;           # SET BEGINNING WORD # 
          TBBP = SBITMBBP [SSIP] ;            # AND BIT POSITIONS # 
          TI = 0 ;
          TW = TBWP ;                        # SET ITEM + WORD INDEXES #
  
#         SET SOURCE ITEM LOCATION. 
# 
          SBWP = SCITEMPBWP [SCIP] ;         # SET BEGINNING WORD # 
          SBBP = SCITEMBBP  [SCIP] ;          # AND BIT POSITIONS # 
          SI = 0 ;
          SW = SBWP ;                        # SET ITEM + WORD INDEXES #
  
#         GENERATE CODE TO CALCULATE ITEM LOCATIONS.
# 
          IF  LOOPL NE 0
          THEN BEGIN                              # IF OCCURRENCE # 
               CALL DSR ;                         # DEPOSIT STORE REG. #
  
#         GENERATE CODE TO CALCULATE SOURCE ITEM LOCATION.
# 
               SI = SCIP ;                   # SET SOURCE POINTERS FOR #
               SW = 0 ;                       # SUBSCRIPTED ITEM #
               CALL GXR (V, RK"VAL", TEMV [SOFV [LOOPL]], 0) ;
                                                    # GEN SAV SOFFSETV #
               IF  NOT SOBF [LOOPL] 
               THEN BEGIN                         # IF OFFSET IN WORDS #
                    IF SBWP NE 0
                      AND  B<SCITMDATATYP[SCIP]> VECTOR EQ 0
                    THEN BEGIN                      # GEN SXM NWORDS   #
                         CALL GXR (M, RK"CON", SBWP, 0) ; 
                         ISSUE (OP"IADD", 6, V, M) ;       # IX6 XV+XM #
                         END
                    ELSE ISSUE (OP"LEFTB", 6, 0, V) ;       # LX6 XV   #
                    REGX [6] = 0 ;
                    CALL SXR (7, RK"CON", SBBP, 0) ;
                    LOCKX [V] = FALSE ;             # GEN SX7 NBITS    #
                    END 
                                                  # IF OFFSET IN BITS # 
               ELSE BEGIN 
                    CALL GAR (M, RK"LIT", -LITFP (WL * 1.0), 0) ; 
                    LOCKX [M] = TRUE ;              # GEN SAM =60.0    #
                    K = SBWP * WL + SBBP ;
                    IF  K NE 0
                      AND  B<SCITMDATATYP[SCIP]> VECTOR EQ 0
                    THEN BEGIN
                         CALL GXR (I, RK"CON", K, CF"INT") ;
                         LOCKX [6] = TRUE ;            # GEN SXI NBITS #
                         CALL FXR (J, RK"NUL", 0, 0) ;  #     + NWORDS #
                         LOCKX [6] = FALSE ;
                         REGX  [J] = 0 ;
                         ISSUE (OP"IADD", J, V, I) ;   # GEN IXJ XV+XI #
                         END
                    ELSE J = V ;
                    LOCKX [J] = TRUE ;
                    CALL FXR (K, RK"NUL", 0, 0) ; 
                    ISSUE (OP"PACK", K, 0, J) ;        # GEN PXK XK    #
                    REGX  [K] = 0 ; 
                    LOCKX [K] = TRUE ;
                    LOCKX [V] = FALSE ; 
                    CALL FXR (V, RK"NUL", 0, 0) ; 
                    ISSUE (OP"FDIV", V, K, M) ;        # GEN FXV XK/XM #
                    REGX  [K] = 0 ; 
                    REGX  [V] = 0 ; 
                    LOCKX [V] = TRUE ;
                    CALL FXR (I, RK"NUL", 0, 0) ; 
                    ISSUE (OP"UNPK", I, 7, V) ;        # GEN UXI,B7 XV #
                    REGX [V] = 0 ;
                    LOCKX [I] = TRUE ;
                    LOCKX [6] = TRUE ;
                    CALL FXR (K, RK"CON", WL, 0) ;
                    IF  K LT 0
                    THEN BEGIN
                         K = 0 ;                       # GEN SXK 60    #
                         IF  LOCKX [0]
                         THEN CALL FXR (K, RK"NUL", 0, 0) ; 
                         CALL SXR (K, RK"CON", WL, CF"INT") ; 
                         END
                    LOCKX [K] = TRUE ;
                    ISSUE (OP"LEFTB", 6, 7, I) ;       # GEN LX6 XI,B7 #
                    REGX [I] = 0 ;
                    LOCKX [6] = TRUE ;
                    CALL GXR (V, RK"NUL", 0, 0) ; 
                    ISSUE (OP"DMUL", V, 6, K) ;        # GEN IXV X6*XK #
                    ISSUE (OP"ISUB", 7, J, V) ;        # GEN IX7 XJ-XV #
                    REGX [V] = 0 ;
                    LOCKX [J] = FALSE ; 
                    END 
               CALL SAR (6, RK"EXT", X$SBWP, 0) ; # GEN SA6 =XDC$SBWP  #
               CALL SAR (7, RK"EXT", X$SBBP, 0) ; # GEN SA7 =XDC$SBBP  #
               END
  
#         GENERATE CODE TO CALCULATE TARGET ITEM LOCATION.
# 
          IF  LOOPL NE 0
          THEN BEGIN                         # SET TARGET POINTERS FOR #
               TI = SSIP ;                    # SUBSCRIPTED ITEM #
               TW = 0 ; 
               CALL GXR (V, RK"VAL", TEMV [TOFV [LOOPL]], 0) ;
                                                    # GEN SAV TOFFSETV #
               IF  NOT TOBF [LOOPL] 
               THEN BEGIN                         # IF OFFSET IN WORDS #
                    IF  TBWP NE 0 
                      AND  B<SBITMTYPE[SSIP]> VECTOR EQ 0 
                    THEN BEGIN                      # GEN SXM NWORDS   #
                         CALL GXR (M, RK"CON", TBWP, 0) ; 
                         ISSUE (OP"IADD", 6, V, M) ;   # GEN IX6 XV+XM #
                         END
                    ELSE ISSUE (OP"LEFTB", 6, 0, V) ;  # GEN LX6 XV    #
                    REGX [6] = 0 ;
                    CALL SXR (7, RK"CON", TBBP, 0) ;
                    LOCKX [V] = FALSE ;             # GEN SX7 NBITS    #
                    END 
                                                  # IF OFFSET IN BITS # 
               ELSE BEGIN 
                    CALL GAR (M, RK"LIT", -LITFP (WL * 1.0), 0) ; 
                    LOCKX [M] = TRUE ;              # GEN SAM =60.0    #
                    K = TBWP * WL + TBBP ;
                    IF  K NE 0
                      AND  B<SBITMTYPE[SSIP]> VECTOR EQ 0 
                    THEN BEGIN
                         CALL GXR (I, RK"CON", K, CF"INT") ;
                         LOCKX [6] = TRUE ;            # GEN SXI NBITS #
                         CALL FXR (J, RK"NUL", 0, 0) ;  #     + NWORDS #
                         LOCKX [6] = FALSE ;
                         REGX  [J] = 0 ;
                         ISSUE (OP"IADD", J, V, I) ;   # GEN IXJ XV+XI #
                         END
                    ELSE J = V ;
                    LOCKX [J] = TRUE ;
                    CALL FXR (K, RK"NUL", 0, 0) ; 
                    ISSUE (OP"PACK", K, 0, J) ;     # GEN PXK XJ       #
                    REGX  [K] = 0 ; 
                    LOCKX [K] = TRUE ;
                    LOCKX [V] = FALSE ; 
                    CALL FXR (V, RK"NUL", 0, 0) ; 
                    ISSUE (OP"FDIV", V, K, M) ;     # GEN FXV XK/XM    #
                    LOCKX [M] = FALSE ; 
                    REGX  [K] = 0 ; 
                    REGX  [V] = 0 ; 
                    LOCKX [V] = TRUE ;
                    LOCKX [6] = TRUE ;
                    CALL FXR (I, RK"NUL", 0, 0) ; 
                    ISSUE (OP"UNPK", I, 7, V) ;     # GEN UXI,B7 XV    #
                    REGX [V] = 0 ;
                    LOCKX [I] = TRUE ;
                    CALL GXR (K, RK"CON", WL, CF"INT") ;  # GEN SXK 60 #
                    ISSUE (OP"LEFTB", 6, 7, I) ;    # GEN LX6 XI,B7    #
                    REGX [I] = 0 ;
                    LOCKX [7] = TRUE ;
                    LOCKX [6] = TRUE ;
                    CALL FXR (V, RK"NUL", 0, 0) ; 
                    ISSUE (OP"DMUL", V, 6, K) ;     # GEN IXV X6*XK    #
                    ISSUE (OP"ISUB", 7, J, V) ;     # GEN IX7 XJ-XV    #
                    REGX  [V] = 0 ; 
                    REGX  [J] = 0 ; 
                    LOCKX [K] = FALSE ; 
                    END 
               CALL SAR (6, RK"EXT", X$TBWP, 0) ; # GEN SA6 =XDC$TBWP  #
               CALL SAR (7, RK"EXT", X$TBBP, 0) ; # GEN SA7 =XDC$TBBP  #
               END
  
          RETURN ;
  
          END 
  
     END  TERM
