*COMDECK   COMGEN   - CODE GENERATING ROUTINES FOR DATA ITEM PROCESSING.
#*        GEN  -  CODE GENERATING ROUTINES FOR DATA ITEM PROCESSING.
* 
*         R. H. GOODELL.     77/04/27.
* 
*         *GEN* CONTAINS SUBROUTINES USED IN THE FIRST PASS OF
*         THE *DDL* CODE GENERATOR, TO PRODUCE CODE FOR MOVING, 
*         CONVERTING, AND CHECKING THE VALUES OF ELEMENTARY DATA
*         ITEM OCCURRENCES.  THESE SUBROUTINES ARE CALLED BY THE
*         DRIVER ROUTINES MAPKEY, MAPRD, AND MAPWR. 
* 
*         CONTENTS (XDEF ENTRY POINTS). 
* 
*         PROC   GBM         GENERATE BLOCK MOVE CODE.
*         PROC   GCC         GENERATE CODE TO CHECK ONE ITEM. 
*         PROC   GIC         GENERATE CODE TO CONVERT ONE ITEM. 
# 
  
  
*CALL     COMDDEF            GENERAL DEFINITIONS. 
  
     XREF BEGIN               # MANAGED TABLES #
  
*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 # 
  
          ITEM DCTN ;              # DISPLAY TO COLLATING TABLE NAME #
          ITEM FWAF B ;            # TRUE IF DC$SFWA AND DC$TFWA SET #
          ITEM LOOPL ;             # LOOP NESTING LEVEL # 
          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 RIBF B ;            # RESULT IN BUFFER FLAG #
          ITEM SBBP I ;            # SOURCE BEGINNING BIT POSITION #
          ITEM SCIP I ;            # SCHEMA ITEM ENTRY POINTER #
          ITEM SI ;                # SOURCE ITEM INDEX #
          ITEM SSIO ;              # SUB-SCHEMA ITEM ORDINA            #
          ITEM SSIP I ;            # SUB-SCHEMA ITEM ENTRY POINTER #
          ITEM SW ;                # SOURCE WORD INDEX #
          ITEM TBBP I ;            # TARGET BEGINNING BIT POSITION #
          ITEM TI ;                # TARGET ITEM INDEX #
          ITEM TW ;                # TARGET WORD INDEX #
          ITEM X$CMPR ;            # NAME OF COMPARE VALUE PROC # 
          ITEM X$CONV ;            # NAME OF CONVERT VALUE PROC # 
          ITEM X$MERF ;            # NAME OF MAPPING ERROR FLAG # 
          ITEM X$MSSO ;            # NAME OF SUB-SCHEMA ITEM ORDINAL   #
          ITEM X$SBBP ;            # NAME OF SOURCE BEGINNING BIT POS # 
          ITEM X$SFWA ;            # NAME OF SOURCE FIRST WORD ADDRESS #
          ITEM X$TBBP ;            # NAME OF TARGET BEGINNING BIT POS # 
          ITEM X$TFWA ;            # NAME OF TARGET FIRST WORD ADDRESS #
          ITEM X$XFER ;            # NAME OF TRANSFER DATA PROC # 
          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 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 LITSI I ;           # SHORT INTEGER LITERAL #
          PROC SAR ;               # SET SPECIFIED A-REGISTER TO VALUE #
          PROC SXR ;               # SET SPECIFIED X-REGISTER TO VALUE #
          FUNC SYN I ;             # SYMBOL NAME NUMBER # 
  
          END 
  
  
*CALL     COMDCF             CONSTANT FORMATS.
  
  
*CALL     COMDITEM           ITEM CLASS AND TYPE CODES. 
  
  
*CALL     COMDOPS            OPERATION CODES. 
  
  
*CALL     COMDPSOP           PSEUDO OPERATION ISSUING DEFS. 
  
  
#         LOCAL DATA. 
# 
          ITEM APLIST ;            # TSYM INDEX OF ACTUAL PARAM LIST #
  
  
          BEGIN 
  
  
  
  
#***      GBM  -  GENERATE BLOCK MOVE.
# 
          XDEF PROC GBM ; 
          PROC GBM ;
  
#         *GBM* IS CALLED TO PROCESS A SERIES OF CONSECUTIVE
*         ITEMS THAT REQUIRE NO DATA CONVERSION, REFORMATTING,
*         REARRANGING, VALIDITY CHECKING, NOR ITEM-LEVEL DATA 
*         BASE PROCEDURE CALLING, AND IN WHICH EVEN THE SLACK 
*         BYTES (IF ANY NEEDED FOR WORD ALIGNMENT) ARE THE SAME 
*         IN BOTH SOURCE AND TARGET.  MUCH EXECUTION TIME CAN 
*         BE SAVED BY TRANSFERRING SUCH A SERIES AS ONE BLOCK 
*         RATHER THAN AS INDIVIDUAL ITEMS OR OCCURRENCES.  SUCH 
*         A SERIES IS RECOGNISED AND FLAGGED AS SUCH BY THE 
*         SUB-SCHEMA COMPILER BEFORE THE CODE GENERATOR IS
*         ENTERED.  THE SUB-SCHEMA ITEM ENTRY FOR THE FIRST 
*         ITEM IN THE BLOCK GIVES THE BLOCK SIZE AND POINTS TO
*         THE FIRST ITEM FOLLOWING THE BLOCK.  MAPRD OR MAPWR 
*         DETECTS THIS AND CALLS GEN/GBM TO GENERATE A CALL TO
*         THE DATA TRANSFER SUBROUTINE. 
****
# 
          BEGIN 
  
#*        GENERATE DC$XFER ACTUAL PARAMETER LIST AS FOLLOWS.
* 
*         LABEL     SOURCE ITEM FIRST WORD ADDRESS. 
*          + 1      SOURCE ITEM BEGINNING BIT POSITION. 
*          + 2      TARGET ITEM FIRST WORD ADDRESS. 
*          + 3      TARGET ITEM BEGINNING BIT POSITION. 
*          + 4      NUMBER OF BITS TO MOVE. 
# 
          APLIST = TSYML ;                       # GEN LABEL OF APLIST #
          ISSUE (VLABEL, APLIST) ;
          ISSUE (VARG, RT"EXT", X$SFWA) ;                        # + 0 #
          IF  LOOPL EQ 0
          THEN ISSUE (VARG, RT"LIT", - LITSI (SBBP)) ;           # + 1 #
          ELSE ISSUE (VARG, RT"EXT", X$SBBP) ;
          ISSUE (VARG, RT"EXT", X$TFWA) ;                        # + 2 #
          IF  LOOPL EQ 0
          THEN ISSUE (VARG, RT"LIT", - LITSI (TBBP)) ;           # + 3 #
          ELSE ISSUE (VARG, RT"EXT", X$TBBP) ;
          ISSUE (VARG, RT"LIT",                                  # + 4 #
                  - LITSI (SBITMBLOCKSZ [SSIP] * CL)) ; 
  
#         GENERATE CALL TO MOVE ROUTINE.
# 
          CALL DSR ;                              # DEPOSIT STORE REG. #
          CALL SXR (6, RK"SRA", SI, SW) ;           # GEN SX6 SOURCEBWP#
          LOCKX [6] = TRUE ;
          CALL SXR (7, RK"TRA", TI, TW) ;           # GEN SX7 TARGETBWP#
          CALL SAR (6, RK"EXT", X$SFWA, 0) ;        # GEN SA6 =XDC$SFWA#
          CALL SAR (7, RK"EXT", X$TFWA, 0) ;        # GEN SA7 =XDC$TFWA#
          CALL SAR (1, RK"SYM", APLIST, 0) ;        # GEN SA1 APLIST   #
          ISSUE (XNO, RT"EXT") ;
          ISSUE (OP"RJ", 0, 0, X$XFER) ;            # GEN RJ  =XDC$XFER#
          ISSUE (XFORCE, 0) ; 
          CALL CRA ;                    # CLEAR REGISTER ASSOCIATES # 
          RETURN ;
  
          END 
  
  
  
  
#***      GCC  -  GENERATE CODE TO CHECK ONE ITEM.
# 
          XDEF PROC GCC ; 
          PROC GCC ((IC), (SZ), (SF), (AP), (PL)) ; 
  
          ITEM IC S:CLASS ;        # ITEM CLASS CODE #
          ITEM SZ ;                # SIZE IN BITS # 
          ITEM SF ;                # SIGN FLAG #
          ITEM AP ;                # ACTUAL POINT FLAG #
          ITEM PL ;                # POINT LOCATION (+=LEFT, -=RIGHT) # 
  
#         *GCC* IS CALLED TO GENERATE CODE CORRESPONDING TO 
*         THE *CHECK VALUE IS ...* CLAUSE IN THE SCHEMA SOURCE
*         DESCRIPTION FOR A DATA ITEM.
****
# 
  
          BEGIN 
  
          ITEM CKIP ;              # CHECK INFORMATION POINTER #
          ITEM CRRN ;              # COMPARE RESULT REGISTER NUMBER # 
          ITEM EFRN ;              # ERROR FLAG REGISTER NUMBER # 
          ITEM FAIL, NEXT, OKAY ;  # TSYM INDEXES OF LABELS # 
          ITEM HILOEQ ;            # TSYM INDEX OF COMPARE RESULT # 
          ITEM LITFWA ;            # TSYM INDEX OF LITERAL FWA CELL # 
          ITEM LITLEN ;            # TSYM INDEX OF LITERAL LENGTH CELL #
          ITEM LITP ;              # LITERAL VALUE FWA REL TO P<TSCH> # 
          ITEM LITS ;              # LITERAL SIZE IN CHARACTERS # 
          ITEM MULF B ;            # TRUE IF MULTIPLE VALUES SPECIFIED #
          ITEM NLIT ;              # NUMBER OF LITERALS SPECIFIED # 
          ITEM NOTF B ;            # TRUE IF *NOT* IN SYNTAX #
          ITEM PART ;              # PARTITION OF LITERAL POINTER WORD #
          ITEM RNGF B ;            # TRUE IF *THRU* IN SYNTAX # 
  
          CALL DSR;                # DEPOSIT STORE REGISTERS           #
          SXR (6, RK"CON", SSIO, 0);         # SX6 SSIO                #
          SAR (6, RK"EXT", X$MSSO, 0);       # SA6 =XDB$MSSO           #
          CALL DSR; 
          HILOEQ = SYN ("HILOEQ") ;               # GET SYMBOL INDEX #
          IF  SYMA [HILOEQ] EQ 0
          THEN BEGIN                              # IF NOT DEFINED #
               ISSUE (VLABEL, HILOEQ) ; 
               ISSUE (VBSS, 1) ;                  # GEN HILOEQ BSS 1   #
               END
          LITFWA = SYN ("LITFWA") ;               # GET SYMBOL INDEX #
          IF  SYMA [LITFWA] EQ 0
          THEN BEGIN                              # IF NOT DEFINED #
               ISSUE (VLABEL, LITFWA) ; 
               ISSUE (VBSS, 1) ;                  # GEN LITFWA BSS 1   #
               END
          LITLEN = SYN ("LITLEN") ;               # GET SYMBOL INDEX #
          IF  SYMA [LITLEN] EQ 0
          THEN BEGIN                              # IF NOT DEFINED #
               ISSUE (VLABEL, LITLEN) ; 
               ISSUE (VBSS, 1) ;                  # GEN LITLEN BSS 1   #
               END
          CKIP = SCIP + SCITEMCHECKS [SCIP] ;     # INITIALISE #
          NOTF = SCITMCKNOT [CKIP] ;               # POINTERS # 
          CKIP = CKIP + 1 ;                         # ETC. #
          LITS = 0 ;
          LITP = CKIP - 1 + SCITMCKLITP [CKIP] ;
          NLIT = SCITMCKNLIT [CKIP] ; 
          MULF = NLIT GE 3  OR  NLIT GE 2 AND NOT SCITMCKRNG2 [CKIP] ;
  
          IF  NOTF AND MULF                       # IF NEED FAIL LABEL #
            OR  NLIT EQ 2  AND  SCITMCKRNG2 [CKIP]
          THEN FAIL = SYN (TSYML) ; 
          ELSE FAIL = 0 ; 
          OKAY = SYN (TSYML) ;                    # SET OKAY LABEL #
  
#*        GENERATE DC$CMPR ACTUAL PARAMETER LIST AS FOLLOWS.
* 
*         LABEL     ERROR CODE RETURN.
*          + 1      COMPARE RESULT. 
*          + 2      DISPLAY CODE TO COLLATING SEQUENCE CONVERSION TABLE.
*          + 3      LITERAL FIRST WORD ADDRESS. 
*          + 4      LITERAL BEGINNING CHARACTER POSITION. 
*          + 5      LITERAL LENGTH IN WORDS.
*          + 6      TARGET ITEM DATA CLASS. 
*          + 7      TARGET ITEM BEGINNING BIT POSITION. 
*          + 8      TARGET ITEM FIRST WORD ADDRESS. 
*          + 9      TARGET ITEM SIZE IN BITS. 
*          +10      TARGET ITEM SIGNED FLAG.
*          +11      TARGET ITEM EXPLICIT DECIMAL POINT FLAG.
*          +12      TARGET ITEM DECIMAL POINT LOCATION (+=LEFT,-=RIGHT).
# 
          APLIST = TSYML ;                       # GEN LABEL OF APLIST #
          ISSUE (VLABEL, APLIST) ;
          ISSUE (VARG, RT"EXT", X$MERF) ;                        # + 0 #
          ISSUE (VARG, RT"SYM", HILOEQ) ;                        # + 1 #
          ISSUE (VARG, RT"EXT", DCTN) ;                          # + 2 #
          ISSUE (VARG, RT"SYM", LITFWA) ;                        # + 3 #
          ISSUE (VARG, RT"LIT", - LITSI (0)) ;                   # + 4 #
          ISSUE (VARG, RT"SYM", LITLEN) ;                        # + 5 #
          ISSUE (VARG, RT"LIT", - LITCL (IC)) ;                  # + 6 #
          IF  LOOPL EQ 0
          THEN ISSUE (VARG, RT"LIT", - LITSI (TBBP)) ;           # + 7 #
          ELSE ISSUE (VARG, RT"EXT", X$TBBP) ;
          ISSUE (VARG, RT"EXT", X$TFWA) ;                        # + 8 #
          ISSUE (VARG, RT"LIT", - LITSI (SZ)) ;                  # + 9 #
          ISSUE (VARG, RT"LIT", - LITSI (SF)) ;                  # +10 #
          ISSUE (VARG, RT"LIT", - LITSI (AP)) ;                  # +11 #
          ISSUE (VARG, RT"LIT", - LITINT (PL)) ;                 # +12 #
  
#         PROCESS VALUE LIST. 
# 
          FOR  PART = 1  WHILE  NLIT NE 0  DO 
               BEGIN
               CALL GCL ;                    # GET CHECK LITERAL #
               CALL GCS ;                    # GEN CALL TO SUBROUTINE # 
               IF  NOT RNGF 
               THEN BEGIN                    # IF NO *THRU* # 
                    IF  NOT NOTF
                    THEN BEGIN               # OKAY IF EQ # 
                         ISSUE (XNO, RT"SYM") ; 
                         ISSUE (OP"XC", XC"ZR", CRRN, OKAY) ; 
                         END
                    ELSE IF  NOT MULF 
                         THEN BEGIN          # OKAY IF NE # 
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"NZ", CRRN, OKAY) ;
                              END 
                         ELSE BEGIN          # FAIL IF EQ # 
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"ZR", CRRN, FAIL) ;
                              END 
                    END 
               ELSE BEGIN                    # IF RANGE OF VALUES # 
                    IF  NOT MULF                  # IF ONLY ONE RANGE # 
                    THEN IF  NOT NOTF 
                         THEN BEGIN                 # FAIL IF LT 1ST #
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"MI", CRRN, FAIL) ;
                              END 
                         ELSE BEGIN                 # OKAY IF LT 1ST #
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"MI", CRRN, OKAY) ;
                              END 
                    ELSE BEGIN                    # IF MULTIPLE RANGES #
                         NEXT = TSYML ; 
                         ISSUE (XNO, RT"SYM") ;     # NEXT IF LT 1ST #
                         ISSUE (OP"XC", XC"MI", CRRN, NEXT) ; 
                         END
                    CALL GCL ;                    # PROCESS TOP VALUE # 
                    CALL GCS ;                     # OF THE RANGE # 
                    IF  NOT NOTF
                    THEN BEGIN                    # OKAY IF LE 2ND #
                         ISSUE (XNO, RT"SYM") ; 
                         ISSUE (OP"XC", XC"MI", CRRN, OKAY) ; 
                         ISSUE (XNO, RT"SYM") ; 
                         ISSUE (OP"XC", XC"ZR", CRRN, OKAY) ; 
                         END
                    ELSE IF  NOT MULF             # IF ONLY ONE RANGE # 
                         THEN BEGIN                 # OKAY IF GT 2ND #
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"ZR", CRRN, FAIL) ;
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"PL", CRRN, OKAY) ;
                              END 
                         ELSE BEGIN                 # FAIL IF LE 2ND #
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"MI", CRRN, FAIL) ;
                              ISSUE (XNO, RT"SYM") ;
                              ISSUE (OP"XC", XC"ZR", CRRN, FAIL) ;
                              END 
                    IF  MULF                      # IF MULTIPLE RANGES #
                    THEN ISSUE (XLABEL, NEXT) ;      # DEFINE LABEL # 
               END  END 
          IF  MULF AND NOTF                       # IF FALL-THROUGH # 
          THEN BEGIN                                # GEN EQ OKAY # 
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"EQ", 0, 0, OKAY) ; 
               END
          IF  FAIL NE 0                           # IF NEED FAIL LABEL #
          THEN ISSUE (XLABEL, FAIL) ;               # GEN FAIL BSS 0   #
          ISSUE (OP"SXBK", 6, 0, O"650") ;          # GEN SX6 650B     #
          ISSUE (OP"SAAB", 6, EFRN, 0) ;            # GEN SA6 A1       #
          ISSUE (XNO, RT"SYM") ;                    # GEN JP  EXIT.    #
          ISSUE (OP"JP", 0, 0, "EXIT.") ; 
          ISSUE (XLABEL, OKAY) ;                    # GEN OKAY BSS 0   #
          RETURN ;
  
  
#         GCL  -  GET CHECK LITERAL.
* 
*         EXIT   (LITS) = LITERAL SIZE. 
*                (RNGF) = RANGE FLAG. 
*                (CKIP, PART, P<LITVAL>) ADVANCED.
*                (NLIT) DECREMENTED.
# 
  
          PROC GCL ;
  
               BEGIN
  
               LABEL GCL1, GCL2, GCL3, GCLX ; 
  
               LITP = LITP + (LITS + WC - 1) / WC ; 
  
               SWITCH  WHICH  GCL1, GCL2, GCL3 ;
               GO TO WHICH [PART] ; 
                    BEGIN 
  
           GCL1:    LITS = SCITMCKLIT1 [CKIP] ; 
                    RNGF = SCITMCKRNG1 [CKIP] ; 
                    GO TO GCLX ;
  
           GCL2:    LITS = SCITMCKLIT2 [CKIP] ; 
                    RNGF = SCITMCKRNG2 [CKIP] ; 
                    GO TO GCLX ;
  
           GCL3:    LITS = SCITMCKLIT3 [CKIP] ; 
                    RNGF = SCITMCKRNG3 [CKIP] ; 
  
                    END 
  
      GCLX:    NLIT = NLIT - 1 ;             # DECREMENT NLIT # 
               PART = PART + 1 ;             # ADVANCE PARTITION NO. #
               IF  PART GE 3
               THEN BEGIN                    # IF END OF WORD # 
                    PART = 0 ;
                    CKIP = CKIP + 1 ;        # START NEXT WORD #
                    END 
               RETURN ; 
  
               END
  
  
#         GCS  -  GENERATE COMPARE SUBROUTINE CALL. 
# 
  
          PROC GCS ;
  
               BEGIN
  
               BASED ARRAY LITVAL ; ; 
               ITEM T ; 
  
               LABEL CHAR, CPLX, DOUB, FIXD, SING, GCS1 ; 
  
               CALL DSR ;                         # DEPOSIT STORE REG. #
               IF  NOT FWAF 
               THEN BEGIN                         # IF DC$TFWA NOT SET #
                    CALL SXR (CSRN, RK"TRA", TI, TW) ;  # SX6 TARGETFWA#
                    CALL SAR (CSRN, RK"EXT", X$TFWA, 0) ; 
                    END                             # GEN SA6 =XDC$TFWA#
               CALL SAR (1, RK"SYM", APLIST, 0) ;   # GEN SA1 APLIST   #
               P<LITVAL> = P<TSCH> + LITP ; 
  
               SWITCH  DATACLASS: CLASS 
                         CHAR: ALPHANUMERIC, CHAR: ALPHABETIC,
                         CHAR: DCNUMERIC,    CHAR: DCFIXED, 
                         FIXD: INTEGER,      CPLX: COMPLEX, 
                         SING: FLOATNORM,    DOUB: DOUBLE  ;
               GO TO DATACLASS [SCITEMCLASS [SCIP]] ; 
                    BEGIN 
  
           CHAR:    T = - LITCH (LITS, LITVAL) ;
                    GO TO GCS1 ;
           CPLX:    T = - LITCPLX (LITVAL) ;
                    GO TO GCS1 ;
           DOUB:    T = - LITDP (LITVAL) ;
                    GO TO GCS1 ;
           FIXD:    T = - LITINT (LITVAL) ; 
                    GO TO GCS1 ;
           SING:    T = - LITFP (LITVAL) ;
  
                    END 
  
      GCS1:    CALL SXR (6, RK"LIT", T, 0) ;        # GEN SX6 =LITERAL #
               T = (LITS + WC - 1) / WC ; 
               CALL SXR (7, RK"CON", T, CF"INT") ;  # GEN SX7 LIT.W.C. #
               CALL SAR (6, RK"SYM", LITFWA, 0) ;   # GEN SA6 LITFWA   #
               CALL SAR (7, RK"SYM", LITLEN, 0) ;   # GEN SA7 LITLEN   #
               ISSUE (XNO, RT"EXT") ; 
               ISSUE (OP"RJ", 0, 0, X$CMPR) ;       # GEN RJ  =XDC$CMPR#
               ISSUE (XFORCE, 0) ;
               CALL CRA ;                         # CLEAR REG. ASSOC. # 
               CALL GXR (EFRN, RK"EXV", X$MERF, 0) ;    # SA1 =XDB$MERF#
               CALL GXR (CRRN, RK"VAL", HILOEQ, 0) ;    # SA2 HILOEQ   #
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"XC", XC"NZ", EFRN, "EXIT.") ;  # NZ,X1 EXIT.  #
               RETURN ; 
  
               END
  
          END 
  
  
  
  
#***      GIC  -  GENERATE CODE TO CONVERT ONE ITEM.
# 
          XDEF PROC GIC ; 
          PROC GIC ((SC), (SK), (SS), (SJ), (SP), (SA), (SF), 
                    (TC), (TK), (TS), (TJ), (TP), (TA), (TF)) ; 
  
          ITEM SC S:CLASS ;        # SOURCE ITEM CLASS CODE # 
          ITEM SK S:RK ;           # SOURCE ITEM KIND - SRA OR TRA #
          ITEM SS ;                # SOURCE ITEM SIZE IN BITS # 
          ITEM SJ ;                # SOURCE ITEM JUSTIFIED RIGHT FLAG # 
          ITEM SP ;                # SOURCE ITEM POINT LOCATION # 
          ITEM SA ;                # SOURCE ITEM ACTUAL POINT FLAG #
          ITEM SF ;                # SOURCE ITEM SIGNED FLAG #
          ITEM TC S:CLASS ;        # TARGET ITEM CLASS CODE # 
          ITEM TK S:RK ;           # TARGET ITEM KIND - SRA OR TRA #
          ITEM TS ;                # TARGET ITEM SIZE IN BITS # 
          ITEM TJ ;                # TARGET ITEM JUSTIFIED RIGHT FLAG # 
          ITEM TP ;                # TARGET ITEM POINT LOCATION # 
          ITEM TA ;                # TARGET ITEM ACTUAL POINT FLAG #
          ITEM TF ;                # TARGET ITEM SIGNED FLAG #
  
#         ENTRY  (SBBP, SBWP, SI, SW) = SOURCE ITEM LOCATION. 
*                (TBBP, TBWP, TI, TW) = TARGET ITEM LOCATION. 
* 
*         *GIC* IS CALLED TO GENERATE WHATEVER CODE IS NEEDED TO
*         CONVERT OR REFORMAT AN ELEMENTARY DATA ITEM OCCURRENCE. 
*         DEPENDING ON THE COMBINATION OF SOURCE AND TARGET DATA
*         CLASSES AND OTHER ATTRIBUTES, *GIC* MAY GENERATE A
*         SMALL AMOUNT OF IN-LINE CODE, OR A CALL TO A DATA 
*         CONVERSION SUBROUTINE OR THE DATA TRANSFER ROUTINE. 
****
# 
          BEGIN 
  
          ITEM D, R ;              # REGISTER NUMBERS # 
          ITEM SV, TV ;            # REGISTER KINDS FOR VALUES #
  
          LABEL CHAR, DNUM, FIXD, REAL ;
          LABEL FDNUM, FFIXD, FREAL ; 
          LABEL RDNUM, RFIXD, RREAL ; 
          LABEL USEPROC, XFER, DONE ; 
  
          IF  SC EQ S"FTNLOGICAL"      # IF SOURCE OR TARGET CLASS IS  #
          THEN SC = S"INTEGER";        # FTNLOGICAL, IT IS TREATED AS  #
          IF  TC EQ S"FTNLOGICAL"      # INTEGER WITHIN THIS ROUTINE   #
          THEN TC = S"INTEGER";        # ONLY (NOT CHANGED IN SUBSCH.).#
  
          IF  SC EQ S"FTNBOOLEAN"      # IF SOURCE OR TARGET CLASS IS  #
          THEN IF  TC GE S"FIXED"      # FTNBOOLEAN, IT IS TREATED     #
                 AND TC LE S"COMPLEX"  # AS REAL (FLOATNORM) OR        #
               THEN SC = S"FLOATNORM"; # INTEGER WITHIN THIS ROUTINE   #
               ELSE SC = S"INTEGER";   # ONLY (NOT CHANGED IN SUBSCH.).#
          IF  TC EQ S"FTNBOOLEAN"      # IF OTHER CLASS IS ANY FLOATING#
          THEN IF  SC GE S"FIXED"      # POINT TYPE, BOOLEAN IS TREATED#
                 AND SC LE S"COMPLEX"  # AS REAL, ELSE INTEGER.        #
               THEN TC = S"FLOATNORM";
               ELSE TC = S"INTEGER";
  
          SV = SK + 1 ; 
          TV = TK + 1 ; 
  
          SWITCH  SOURCECLASS: CLASS
                    CHAR: ALPHANUMERIC,      CHAR: ALPHABETIC,
                    DNUM: DCNUMERIC,         DNUM: DCFIXED, 
                    FIXD: INTEGER,           REAL: COMPLEX, 
                    REAL: FLOATNORM,         REAL: DOUBLE  ;
          GO TO SOURCECLASS [SC] ;
               BEGIN
  
      CHAR:                   # SOURCE ITEM IS CHARACTER STRING # 
               GO TO USEPROC ;                    # (FOR NOW) # 
  
      DNUM:                   # SOURCE ITEM IS DISPLAY NUMERIC #
               GO TO USEPROC ;
  
      FIXD:                   # SOURCE ITEM IS BINARY FIXED POINT # 
               SWITCH  FIXDCLASS: CLASS 
                         FDNUM: DCNUMERIC,      FDNUM: DCFIXED, 
                         FFIXD: INTEGER,        FREAL: COMPLEX, 
                         FREAL: FLOATNORM,      FREAL: DOUBLE  ;
               GO TO FIXDCLASS [TC] ; 
                    BEGIN 
  
           FDNUM:                  # BINARY FIXED TO DISPLAY NUMERIC #
                    GO TO USEPROC ; 
  
           FFIXD:                  # BINARY FIXED TO BINARY FIXED # 
                    IF  SP NE TP                  # IF UNLIKE SCALING # 
                    THEN GO TO USEPROC ;
                    CALL DSR ;                    # DEPOSIT STORE REG. #
                    CALL SXR (CSRN, SV, SI, SW) ;   # GET X-REG. #
                    KINDX [CSRN] = TV ; 
                    ITEMX [CSRN] = TI ;           # UPDATE REG. ASSOC. #
                    WORDX [CSRN] = TW ; 
                    CSRI = TI ; 
                    CSRA = TW ;                   # SET STORE POINTERS #
                    GO TO DONE ;
  
           FREAL:                  # BINARY FIXED TO FLOATING POINT # 
                    IF  SP NE 0                   # IF ANY SCALING #
                    THEN GO TO USEPROC ;
                    CALL DSR ;                    # DEPOSIT STORE REG. #
                    CALL GXR (R, SV, SI, SW) ;      # GET X-REG. #
                    ISSUE (OP"PACK", 0, 0, R) ;     # GEN PX0 XR       #
                    ISSUE (OP"NORM", CSRN, 0, 0) ;  # GEN NX6 X0       #
                    REGX  [CSRN] = 0 ;
                    KINDX [CSRN] = TV ;           # SET REG. ASSOC. OF #
                    ITEMX [CSRN] = TI ;            # STORE REGISTER # 
                    WORDX [CSRN] = TW ; 
                    CSRI = TI ;                   # SET STORE POINTERS #
                    CSRA = TW ; 
                    IF  TC EQ S"DOUBLE"           # IF TARGET ITEM #
                      OR  TC EQ S"COMPLEX"         # IS TWO WORDS # 
                    THEN BEGIN
                         RIBF = TRUE ;
                         QTRA = QBUF ;
                         D = 13 - CSRN ;
                         CALL SXR (D, RK"CON", 0, 0) ;  # SX7 0        #
                         REGX  [D] = REGX [CSRN] ;
                         WORDX [D] = TW + 1 ; 
                         CALL DSR ;               # DEPOSIT STORE REG. #
                         CSRA = TW + 1 ;
                         END
                    GO TO DONE ;
  
                    END            # OF BINARY FIXED POINT SOURCE CASES#
  
      REAL:                   # SOURCE ITEM IS BINARY FLOATING POINT #
               SWITCH  REALCLASS: CLASS 
                         RDNUM: DCNUMERIC,      RDNUM: DCFIXED, 
                         RFIXD: INTEGER,        RREAL: COMPLEX, 
                         RREAL: FLOATNORM,      RREAL: DOUBLE  ;
               GO TO REALCLASS [TC] ; 
                    BEGIN 
  
           RDNUM:                  # BINARY F.P. TO DISPLAY NUMERIC # 
                    GO TO USEPROC ; 
  
           RFIXD:                  # BINARY FLOATING TO FIXED POINT # 
                    IF  TP NE 0                   # IF ANY SCALING #
                    THEN GO TO USEPROC ;
                    CALL DSR ;                    # DEPOSIT STORE REG. #
                    CALL GXR (R, SV, SI, SW) ;      # GET X-REG. #
                    ISSUE (OP"UNPK", 0, 7, R) ;     # GEN UX0,B7 XR    #
                    ISSUE (OP"LEFTB", CSRN, 7, 0) ; # GEN LX6 X0,B7    #
                    REGX  [CSRN] = 0 ;
                    KINDX [CSRN] = TV ;           # SET REG. ASSOC. OF #
                    ITEMX [CSRN] = TI ;            # STORE REGISTER # 
                    WORDX [CSRN] = TW ; 
                    CSRI = TI ;                   # SET STORE POINTERS #
                    CSRA = TW ; 
                    GO TO DONE ;
  
           RREAL:                  # BINARY FLOATING TO FLOATING #
                    CALL DSR ;                    # DEPOSIT STORE REG. #
                    IF  SC EQ S"FLOATNORM"
                      AND  TC NE S"FLOATNORM"     # IF SOURCE ITEM ONE #
                    THEN BEGIN                     # WORD AND TARGET #
                         RIBF = TRUE ;              # TWO WORDS, SET #
                         QTRA = QBUF ;               # RESULT IN BUFFER#
                         END
                    IF  SC EQ S"FLOATNORM"        # IF ONLY FIRST WORD #
                      OR  SC EQ S"COMPLEX"         # OF SOURCE ITEM IS #
                          AND  TC NE S"COMPLEX"     # TO BE USED #
                    THEN BEGIN
                         CALL SXR (CSRN, SV, SI, SW) ;   # GET WORD # 
                         CSRA = TW ;              # SET STORE POINTERS #
                         CSRI = TI ;
                         IF  TC NE S"FLOATNORM"   # IF TARGET ITEM #
                         THEN BEGIN                # IS TWO WORDS # 
                              D = 13 - CSRN ; 
                              CALL SXR (D, RK"CON", 0, 0) ; # SX7 0    #
                              CALL DSR ;          # DEPOSIT STORE REG. #
                              CSRA = TW + 1 ; 
                         END  END                 # IF SOURCE = DOUBLE #
                    ELSE BEGIN                     # OR BOTH = COMPLEX #
                         CALL GXR (R, SV, SI, SW) ;         # GET 2 # 
                         CALL GXR (D, SV, SI, SW+1) ;       # WORDS # 
                         IF  SC EQ TC 
                         THEN ISSUE (OP"LEFTB", CSRN, 0, R) ;#LX6 X1   #
                         ELSE ISSUE (OP"RADD",  CSRN, R, D) ;#RX6 X1+X2#
                         REGX [CSRN] = 0 ;
                         CSRA = TW ;              # SET STORE POINTERS #
                         CSRI = TI ;
                         IF  TC NE S"FLOATNORM"   # IF TARGET ITEM #
                         THEN BEGIN                # IS TWO WORDS # 
                              D = 13 - CSRN ; 
                              IF  SC EQ TC
                              THEN CALL SXR (D, SV, SI, SW+1) ; 
                              ELSE CALL SXR (D, RK"CON", 0, 0) ;
                              CALL DSR ;          # DEPOSIT STORE REG. #
                              CSRA = TW + 1 ; 
                         END  END 
                    GO TO DONE ;
  
                    END            # OF BINARY F.P. SOURCE CASES #
  
               END            # OF SOURCE ITEM DATA CLASS CASES # 
  
 USEPROC:                # GENERATE SUBROUTINE CALL # 
          IF  SSIP NE 0 
            AND  SBITMIDNTICL [SSIP]
          THEN GO TO XFER ;                  # IF NO CONVERSION NEEDED #
  
                         # GENERATE CALL TO DATA CONVERSION SUBROUTINE #
  
          RIBF = TRUE ;            # SET RESULT IN BUFFER # 
          QTRA = QBUF ; 
  
#*        GENERATE DC$CONV ACTUAL PARAMETER LIST AS FOLLOWS.
* 
*         LABEL     ERROR CODE RETURN.
*          + 1      SOURCE ITEM DATA CLASS. 
*          + 2      TARGET ITEM DATA CLASS. 
*          + 3      SOURCE ITEM FIRST WORD ADDRESS. 
*          + 4      TARGET ITEM FIRST WORD ADDRESS. 
*          + 5      SOURCE ITEM BEGINNING BIT POSITION. 
*          + 6      TARGET ITEM BEGINNING BIT POSITION. 
*          + 7      SOURCE ITEM SIZE IN BITS. 
*          + 8      TARGET ITEM SIZE IN BITS. 
*          + 9      SOURCE ITEM JUSTIFIED RIGHT FLAG. 
*          +10      TARGET ITEM JUSTIFIED RIGHT FLAG. 
*          +11      SOURCE ITEM DECIMAL POINT LOCATION (+=LEFT,-=RIGHT).
*          +12      TARGET ITEM DECIMAL POINT LOCATION (+=LEFT,-=RIGHT).
*          +13      SOURCE ITEM EXPLICIT DECIMAL POINT FLAG.
*          +14      TARGET ITEM EXPLICIT DECIMAL POINT FLAG.
*          +15      SOURCE ITEM SIGNED FLAG.
*          +16      TARGET ITEM SIGNED FLAG.
# 
          APLIST = TSYML ;                       # GEN LABEL OF APLIST #
          ISSUE (VLABEL, APLIST) ;
          ISSUE (VARG, RT"EXT", X$MERF) ;                        # + 0 #
          ISSUE (VARG, RT"LIT", - LITCL (SC)) ;                  # + 1 #
          ISSUE (VARG, RT"LIT", - LITCL (TC)) ;                  # + 2 #
          ISSUE (VARG, RT"EXT", X$SFWA) ;                        # + 3 #
          ISSUE (VARG, RT"EXT", X$TFWA) ;                        # + 4 #
          IF  LOOPL EQ 0
          THEN BEGIN                                   # IF FIXED # 
               ISSUE (VARG, RT"LIT", - LITSI (SBBP)) ;           # + 5 #
               ISSUE (VARG, RT"LIT", - LITSI (TBBP)) ;           # + 6 #
               END
          ELSE BEGIN                                   # IF IN LOOP # 
               ISSUE (VARG, RT"EXT", X$SBBP) ;                   # + 5 #
               ISSUE (VARG, RT"EXT", X$TBBP) ;                   # + 6 #
               END
          ISSUE (VARG, RT"LIT", - LITSI (SS)) ;                  # + 7 #
          ISSUE (VARG, RT"LIT", - LITSI (TS)) ;                  # + 8 #
          ISSUE (VARG, RT"LIT", - LITSI (SJ)) ;                  # + 9 #
          ISSUE (VARG, RT"LIT", - LITSI (TJ)) ;                  # +10 #
          ISSUE (VARG, RT"LIT", - LITINT (SP)) ;                 # +11 #
          ISSUE (VARG, RT"LIT", - LITINT (TP)) ;                 # +12 #
          ISSUE (VARG, RT"LIT", - LITSI (SA)) ;                  # +13 #
          ISSUE (VARG, RT"LIT", - LITSI (TA)) ;                  # +14 #
          ISSUE (VARG, RT"LIT", - LITSI (SF)) ;                  # +15 #
          ISSUE (VARG, RT"LIT", - LITSI (TF)) ;                  # +16 #
  
#         STORE SUB-SCHEMA ITEM ORDINAL IN DB$MSSO                     #
  
          CALL DSR;                # DEPOSIT STORE REGISTERS           #
          SXR (6, RK"CON", SSIO, 0);         # SX6 SSIO                #
          SAR (6, RK"EXT", X$MSSO, 0);       # SA6 =XDB$MSSO           #
#         GENERATE CALL TO CONVERSION SUBROUTINE. 
# 
          CALL DSR ;                              # DEPOSIT STORE REG. #
          CALL SXR (CSRN, SK, SI, SW) ;             # GEN SX6 SOURCEFWA#
          CALL SXR (13-CSRN, TK, TI, TW) ;          # GEN SX7 TARGETFWA#
          CALL SAR (CSRN, RK"EXT", X$SFWA, 0) ;     # GEN SA6 =XDC$SFWA#
          CALL SAR (13-CSRN, RK"EXT", X$TFWA, 0) ;  # GEN SA7 =XDC$TFWA#
          FWAF = TRUE ;                           # FLAG FWA-S SET #
          CALL SAR (1, RK"SYM", APLIST, 0) ;        # GEN SA1 APLIST   #
          ISSUE (XNO, RT"EXT") ;
          ISSUE (OP"RJ", 0, 0, X$CONV) ;            # GEN RJ  =XDC$CONV#
          ISSUE (XFORCE, 0) ; 
          CALL CRA ;                              # CLEAR REG. ASSOC. # 
          ISSUE (XNO, RT"EXT") ;
          ISSUE (OP"SABK", 1, 0, X$MERF) ;          # GEN SA1 =XDB$MERF#
          ISSUE (XNO, RT"SYM") ;                    # GEN NZ,X1 EXIT.  #
          ISSUE (OP"XC", XC"NZ", 1, "EXIT.") ;
          GO TO DONE ;
  
 XFER:                   # GENERATE CALL TO DATA TRANSFER SUBROUTINE #
  
          IF  QTRA EQ QSRA
          THEN GO TO DONE ; 
  
#*        GENERATE DC$XFER ACTUAL PARAMETER LIST AS FOLLOWS.
* 
*         LABEL     SOURCE ITEM FIRST WORD ADDRESS. 
*          + 1      SOURCE ITEM BEGINNING BIT POSITION. 
*          + 2      TARGET ITEM FIRST WORD ADDRESS. 
*          + 3      TARGET ITEM BEGINNING BIT POSITION. 
*          + 4      SIZE IN BITS. 
# 
          APLIST = TSYML ;                       # GEN LABEL OF APLIST #
          ISSUE (VLABEL, APLIST) ;
          ISSUE (VARG, RT"EXT", X$SFWA) ;                        # + 0 #
          IF  LOOPL EQ 0
          THEN ISSUE (VARG, RT"LIT", - LITSI (SBBP)) ;           # + 1 #
          ELSE ISSUE (VARG, RT"EXT", X$SBBP) ;
          ISSUE (VARG, RT"EXT", X$TFWA) ;                        # + 2 #
          IF  LOOPL EQ 0
          THEN ISSUE (VARG, RT"LIT", - LITSI (TBBP)) ;           # + 3 #
          ELSE ISSUE (VARG, RT"EXT", X$TBBP) ;
          ISSUE (VARG, RT"LIT", - LITSI (TS)) ;                  # + 4 #
  
#         GENERATE CALL TO DATA TRANSFER SUBROUTINE.
# 
          CALL DSR ;                              # DEPOSIT STORE REG. #
          CALL SXR (CSRN, SK, SI, SW) ;             # GEN SX6 SOURCEFWA#
          CALL SXR (13-CSRN, TK, TI, TW) ;          # GEN SX7 TARGETFWA#
          CALL SAR (CSRN, RK"EXT", X$SFWA, 0) ;     # GEN SA6 =XDC$SFWA#
          CALL SAR (13-CSRN, RK"EXT", X$TFWA, 0) ;  # GEN SA7 =XDC$TFWA#
          FWAF = TRUE ;                           # FLAG FWA-S SET #
          CALL SAR (1, RK"SYM", APLIST, 0) ;        # GEN SA1 APLIST   #
          ISSUE (XNO, RT"EXT") ;
          ISSUE (OP"RJ", 0, 0, X$XFER) ;            # GEN RJ  =XDC$XFER#
          ISSUE (XFORCE, 0) ; 
          CALL CRA ;                              # CLEAR REG. ASSOC. # 
  
                         # ALL PATHS REJOIN HERE #
 DONE:  
          RETURN ;
  
          END 
  
     END  TERM
