*COMDECK  COMMAPWR  - COMPILE WRITE/REWRITE RECORD MAPPING CODE CAPSULE.
#*        MAPWR  -  COMPILE WRITE/REWRITE RECORD MAPPING CODE CAPSULE.
* 
*         R. H. GOODELL.     76/10/21.
* 
*         *MAPWR* CONTROLS THE COMPILATION OF A CODE CAPSULE TO 
*         PERFORM CONVERSION OF A DATA RECORD FROM SUB-SCHEMA 
*         FORMAT TO SCHEMA FORMAT, AS WHEN WRITING OR REWRITING 
*         THE RECORD TO A DATABASE.  THIS CORRESPONDS TO THE
*         *STORE* AND *MODIFY* OPERATIONS 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 SCHEMA DIRECTORY. 
* 
*         CONTENTS (XDEF ENTRY POINTS). 
* 
*         PROC   MAPWR       COMPILE WRITE/REWRITE RECORD MAPPING CODE. 
# 
  
  
*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 SCIO ;              # SCHEMA ITEM ORDINAL #
          ITEM SCIP ;              # SCHEMA ITEM ENTRY POINTER #
          ITEM SCNI ;              # NUMBER OF ITEMS IN SCHEMA RECORD # 
          ITEM SI ;                # SOURCE ITEM INDEX #
          ITEM SSIO ;              # SUB-SCHEMA ITEM ORDINAL           #
          ITEM SSIP ;              # SUB-SCHEMA ITEM ENTRY POINTER #
          ITEM SSRP ;              # SUB-SCHEMA RECORD ENTRY POINTER #
          ITEM SW ;                # SOURCE WORD INDEX #
          ITEM TBBP ;              # TARGET BEGINNING BIT POSITION #
          ITEM TBWP ;              # TARGET BEGINNING WORD POSITION # 
          ITEM TI ;                # TARGET ITEM INDEX #
          ITEM TLEV ;              # TARGET ITEM LEVEL-NUMBER # 
          ITEM TW ;                # TARGET WORD INDEX #
          ITEM 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 ON-ERROR DBP APLIST FWA #
          ITEM X$MFIT ;            # NAME OF FILE INFORMATION TABLE FWA#
          ITEM X$MMOD ;            # NAME OF WRITE MAPPING MODE FLAG #
          ITEM X$MSCH ;            # NAME OF SCHEMA RECORD AREA FWA # 
          ITEM X$MSUB ;            # NAME OF SUB-SCHEMA RECORD AREA FWA#
          ITEM X$NLFL ;            # NAME OF NULL FILL ITEM PROCEDURE # 
          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 #
          ITEM X$TFWA ;            # NAME OF TARGET FIRST WORD ADDRESS #
          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 MODA = 0 ;          # DBP APLIST ADDRESS FOR MODIFY #
          ITEM NNUL = 0 ;          # NON-NULL OCCURRENCE JUMP LABEL IND#
          ITEM NULL = 0 ;          # NULL OCCURRENCE LABEL TSYM INDEX # 
          ITEM PL ;                # POINT LOCATION (+=LEFT, -=RIGHT) # 
          ITEM SKIP = 0 ;          # JUMP AROUND ITEM LABEL TSYM INDEX #
          ITEM STOA = 0 ;          # DBP APLIST ADDRESS FOR STORE # 
          ITEM TC S:CLASS ;        # TARGET ITEM DATA CLASS # 
  
  
  
  
#***      MAPWR  -  COMPILE WRITE/REWRITE RECORD MAPPING CODE CAPSULE.
  
          PROC MAPWR
  
*         A WRITE/REWRITE 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 (SUB-SCHEMA) RECORD
*         AREA TO THE TARGET (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. 
* 
*         IF AN ITEM IS OMITTED FROM THE SUB-SCHEMA, THE
*         GENERATED CODE WITL EITHER SET IT TO AN INITIAL 
*         VALUE (NULL-FILL) OR LEAVE IT UNDISTURBED, DEPENDING
*         ON A FLAG (DB$MMOD) BY WHICH THE CALLER INDICATES A 
*         STORE (WRITE) OR MODIFY (REWRITE) CALL TO THE CAPSULE.
* 
*         PROCESSING FOR EACH OCCURRENCE OF EACH ITEM IS DONE 
*         IN THE FOLLOWING SEQUENCE.
*         IGNORE *VIRTUAL RESULT* ITEMS.
*         CALL ITEM-LEVEL *BEFORE MODIFY/STORE* DBPS IF ANY.
*         IF ANY *ON ERROR DURING MODIFY/STORE* DBPS ARE
*         SPECIFIED, SET DB$MERP. 
*         IF AN *ACTUAL RESULT* DBP IS SPECIFIED, CALL IT.
*         IF AN *ENCODING ALWAYS* DBP IS SPECIFIED, CALL IT.
*         IF AN *ENCODING* DBP IS SPECIFIED AND THE DATA ITEM 
*         DESCRIPTIONS ARE NOT IDENTICAL, CALL IT.
*         IF NO *ACTUAL RESULT* NOR *ENCODING [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 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 MODIFY/STORE* DBPS WERE 
*         SPECIFIED, CLEAR DB$MERP. 
*         CALL ITEM-LEVEL *AFTER MODIFY/STORE* 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 WRITE/REWRITE 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$MMOD - MODE FLAG -  0 = STORE,  1 = MODIFY. 
*         ITEM DB$MSUB - FWA OF SUB-SCHEMA (SOURCE) RECORD AREA.
*         PROC DC$CMPR - COMPARE ITEM VALUES - FOR *CHECK*. 
*         PROC DC$CONV - CONVERT ITEM VALUE.
*         ITEM DC$MSCH - FWA OF SCHEMA (TARGET) RECORD AREA.
*         PROC DC$NLFL - NULL FILL ITEM VALUE.
*         ITEM DC$SBBP - SOURCE ITEM BEGINNING BIT POSITION.
*         ITEM DC$SBWP - SOURCE ITEM BEGINNING WORD POSITION. 
*         ITEM DC$SFWA - SOURCE ITEM FIRST WORD ADDRESS.
*         ITEM DC$TBBP - TARGET ITEM BEGINNING BIT POSITION.
*         ITEM DC$TBWP - TARGET ITEM BEGINNING WORD POSITION. 
*         ITEM DC$TFWA - TARGET ITEM FIRST WORD ADDRESS.
*         PROC DC$XFER - TRANSFER DATA. 
****
# 
          BEGIN 
  
          GETF = FALSE ;
          PRFXKIND = "WRITE" ;
          QSRA = X$MSUB ; 
          QTRA = X$MSCH ; 
          QBUF = X$MSCH ; 
          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 SCHEMA RECORD DESCRIPTION. 
# 
          SSIP = SSRP + SBRECNXITEMP [SSRP] ; 
          NEXT = SCRECDITMPTR ; 
          NSIF = TRUE ; 
          FOR  SCIO = 1 THRU SCNI  DO 
               BEGIN
  
#         GENERATE LOOP CODE IF PREVIOUS ITEM IS LAST OF ITS LEVEL. 
# 
               FOR  TLEV = SCITEMLEVEL [NEXT] 
                      WHILE  LOOPL NE 0 
                           AND  LLEV [LOOPL] GE TLEV
                    DO  CALL GLC ;           # GENERATE LOOP CODE # 
  
#         SET SCHEMA ITEM POINTER FOR NEW ITEM. 
# 
               SCIP = NEXT ;
               NEXT = SCIP + SCITMENTRYLG [SCIP] ;
               FWAF = FALSE ; 
  
#         IGNORE ITEM IF *VIRTUAL RESULT* ITEM. 
# 
               I = SCITMATVTP [SCIP] ;
               IF  I NE 0  AND  SCITMAVRESLT [SCIP+I] 
               THEN TEST SCIO ; 
  
#         FIND CORRESPONDING ITEM (IF ANY) IN SUB-SCHEMA RECORD DESCR.
# 
               DONE = FALSE ; 
               FIRST = TRUE ;                # END-AROUND SEARCH OF # 
               NSIF = TRUE ;                  # SUB-SCHEMA RECORD # 
               FOR  I = SSIP
                       WHILE  NSIF  AND  NOT DONE  DO 
                    BEGIN 
                    IF SBITMSCPTR [I] EQ SCIP # IF ITEM CORRESPONDS TO #
                    THEN NSIF = FALSE ;        # CURRENT SCHEMA ITEM #
                    ELSE BEGIN
                         IF  SBITMNEXTP [I] NE 0            # ADVANCE # 
                         THEN I = I + SBITMNEXTP [I] ;
                         ELSE I = SSRP + SBRECNXITEMP [SSRP] ;
                         IF  I EQ SSIP
                         THEN IF  FIRST                     # IF FULL # 
                              THEN FIRST = FALSE ;           # CIRCLE # 
                              ELSE DONE = TRUE ;
                    END  END
               IF  NOT NSIF             # IF SOURCE ITEM WAS FOUND #
               THEN BEGIN 
                    SSIP = I ;               # LIST SOURCE LINE NUMBER #
                    ISSUE (XLINE, SBITMSRCLNEN [SSIP]) ;
                    END 
          SSIO = SBITMORDINAL [SSIP] ;
  
#         SET LOOP CONTROLS IF ITEM IS A VECTOR OR REPEATING GROUP. 
# 
               IF  LOOPL EQ 0 
               THEN VARF = FALSE ;
               IF  NSIF                      # IF ITEM DOES NOT START # 
                 OR  SBITMBLOCKSZ [SSIP] EQ 0 # A NO-MAP BLOCK #
               THEN BEGIN 
                    IF  SCITMOCCINFO [SCIP] NE 0  # IF *OCCURS* CLAUSE #
                    THEN CALL SLC ;                # SET LOOP CONTROLS #
                    I = SCITMDATATYP [SCIP] ; 
                    IF  B<I> GROUP NE 0 
                    THEN TEST SCIO ;            # DONE IF GROUP ITEM #
                    END 
  
#         PROCESS ELEMENTARY ITEM OR NO-MAP BLOCK.
# 
               SKIP = 0 ; 
               CALL SIL ;                    # SET ITEM LOCATION #
               DBPF = FALSE ; 
  
#         PROCESS *BEFORE MODIFY/STORE* ITEM-LEVEL DBP CALLS, IF ANY. 
# 
               CALL PDC (DBPENT"BIMOD", DBPENT"BISTO", TRUE) ;
  
#         PROCESS *ON ERROR DURING MODIFY/STORE* ITEM-LEVEL DBP CALLS.
# 
               CALL PDC (DBPENT"EIMOD", DBPENT"EISTO", FALSE) ; 
               ERRA = MODA + STOA ;          # NZ IF ANY ERROR PROCS #
  
#         PROCESS *ACTUAL RESULT* DBP CALL, IF ANY. 
# 
               I = SCITMATVTP [SCIP] ;
               IF  I NE 0  AND  NOT SCITMAVRESLT [SCIP+I] 
               THEN BEGIN 
                    CALL BDL (SCITEMRESULT [SCIP+I]) ; # BUILD DBP LIST#
                    CALL GDC (DBPENT"ACTUAL") ;        # GEN DBP CALL # 
                    DBPF = TRUE ;            # INDICATE RESULT FROM DBP#
                    END 
  
#         PERFORM CONVERSION OF ITEM VALUE. 
# 
               ELSE CALL PCV ;               # CONVERT VALUE #
  
#         PROCESS *CHECK* CLAUSE, IF ANY. 
# 
               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                    # GEN CHECK CODE #
                         PL = SCITEMPTLOC [SCIP] ;
                         IF  NOT SCITEMPTLEFT [SCIP]
                         THEN PL = - PL ; 
                         CALL GCC (SCITEMCLASS [SCIP],
                                   SCITEMSIZE [SCIP] * CL,
                                   SCITEMSIGNFG [SCIP], 
                                   SCITEMACTLPT [SCIP], PL) ; 
                         END
                    IF  SCITMCKDBP [I]       # IF *CHECK IS PROC-NAME* #
                    THEN BEGIN
                         CALL BDL (SCITMCKPROC [I]) ; # BUILD DBP LIST #
                         CALL GDC (DBPENT"CHECK") ;   # GEN DBP CALL #
                         END
                    END 
  
#         CLEAR *ON ERROR DURING MODIFY/STORE* 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 MODIFY/STORE* ITEM-LEVEL DBP CALLS, IF ANY.
# 
               CALL PDC (DBPENT"AIMOD", DBPENT"AISTO", TRUE) ;
  
#         PROCEED TO NEXT ITEM IN RECORD. 
# 
               IF  NOT NSIF                  # IF FIRST ITEM OF BLOCK # 
                 AND SBITMBLOCKSZ [SSIP] NE 0 # OF NO-MAP ITEMS THEN #
               THEN BEGIN                      # SET POINTERS TO FIRST #
                    NEXT = SBITMNXSCPTR [SSIP] ;# ITEM FOLLOWING BLOCK #
                    SSIP = SBITMNXSSWA [SSIP] ; 
                    IF NEXT NE 0
                    THEN SCIO = SCITMORDNUM [NEXT] - 1 ;
                    ELSE SCIO = SCNI ;
                    IF SSIP EQ 0
                    THEN SSIP = SSRP + SBRECNXITEMP [SSRP] ;
                    END 
               IF SKIP NE 0                       # IF *SIL* GENERATED #
               THEN BEGIN                          # A JUMP AROUND #
                    ISSUE (XLABEL, SKIP) ;          # GEN SKIP LABEL #
                    CALL CRA ;                      # CLEAR REG. ASSOC #
                    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 ;
  
  
  
  
#***      GNF  -  GENERATE NULL FILL. 
# 
          PROC GNF ;
  
#         *GNF* IS CALLED BY *PCV* FOR AN ITEM THAT IS PRESENT IN 
*         THE SCHEMA BUT NOT IN THE SUB-SCHEMA, OR FOR AN ITEM
*         OCCURRENCE WHOSE VALUE IS NOT SUPPLIED BY THE USER AT 
*         EXECUTION TIME (EITHER BECAUSE THE SUB-SCHEMA DIMENSION 
*         IS FIXED AND LESS THAN THAT OF THE SCHEMA, OR BECAUSE 
*         THE DIMENSION IS VARIABLE).  *GNF* GENERATES CODE TO
*         STORE NULL VALUES (ZEROS FOR NUMERIC ITEMS, SPACES FOR
*         CHARACTER ITEMS) INTO THE ITEM OCCURRENCE.  THE CODE
*         GENERATED WILL BE EXECUTED ONLY WHEN A *STORE* OPERATION
*         IS DONE.  FOR A *MODIFY* REQUEST, THESE ITEM OCCURRENCES
*         ARE NOT AFFECTED. 
****
# 
          BEGIN 
  
          ARRAY TPIC ;             # TARGET ITEM PICTURE INFORMATION #
*CALL     COMDPICT           TARGET ITEM PICTURE ARRAY-ITEM DECLARATIONS
  
          LABEL BINARY, CHAR, DECIMAL, DONE, USEPROC ;
  
          TC = SCITEMCLASS [SCIP] ;     # GET TARGET ITEM DATA CLASS #
  
          SWITCH  PROCESS: CLASS
                    CHAR: ALPHANUMERIC,      CHAR: ALPHABETIC,
                    DECIMAL: DCNUMERIC,      DECIMAL: DCFIXED,
                    BINARY: INTEGER,         BINARY: FIXED, 
                    BINARY: FLOATNORM,       BINARY: DOUBLE,
                    BINARY: COMPLEX,         BINARY: FTNLOGICAL,
                    BINARY: FTNBOOLEAN ;
          GO TO PROCESS [TC] ;
               BEGIN
  
      BINARY:                           # NULL-FILL BINARY DATUM #
               CALL DSR ;                         # DEPOSIT STORE REG. #
               CALL SXR (CSRN, RK"CON", 0, 0) ;     # GEN SX6 0        #
               CSRI = TI ;
               CSRA = TW ;                        # SET STORE ADDRESS # 
               IF  TC EQ S"DOUBLE"
                 OR  TC EQ S"COMPLEX"             # IF TWO WORDS #
               THEN BEGIN 
                    CALL DSR ;                    # DEPOSIT STORE REG. #
                    CALL SXR (CSRN, RK"CON", 0, 0) ;    # SX7 0        #
                    CSRA = TW + 1 ;               # ADVANCE ADDRESS # 
                    END 
               GO TO DONE ;                       # FINISH UP BELOW # 
  
      DECIMAL:                          # NULL-FILL DECIMAL NUMERIC # 
               GO TO USEPROC ;
  
      CHAR:                             # NULL-FILL CHARACTER STRING #
               GO TO USEPROC ;                    # (FOR NOW) # 
  
               END                      # OF SCHEMA CLASS CASES # 
  
 USEPROC:                          # GENERATE CALL TO NULL-FILL SUBR #
  
#         GENERATE ACTUAL PARAMETER LIST AS FOLLOWS.
* 
*         LABEL     ITEM DATA CLASS CODE. 
*          + 1      SIZE, IN BITS.
*          + 2      BEGINNING BIT POSITION. 
*          + 3      FIRST WORD ADDRESS. 
*          + 4      PICTURE INFORMATION.
# 
          APLIST = TSYML ;                       # GEN LABEL OF APLIST #
          ISSUE (VLABEL, APLIST) ;
          ISSUE (VARG, RT"LIT", - LITCL                          # + 0 #
                    (SCITEMCLASS [SCIP])) ; 
          ISSUE (VARG, RT"LIT", - LITSI                          # + 1 #
                    (SCITEMSIZE [SCIP] * CL)) ; 
          IF  LOOPL EQ 0
          THEN ISSUE (VARG, RT"LIT", - LITSI (TBBP)) ;           # + 2 #
          ELSE ISSUE (VARG, RT"EXT", X$TBBP) ;
          ISSUE (VARG, RT"EXT", X$TFWA) ;                        # + 3 #
          TPICW = 0 ;                            # FORMAT PICTURE WORD #
          TSIGNF = SCITEMSIGNFG [SCIP] ;
          TSEPSN = SCITEMSIGN [SCIP] ;
          TSNLOC = SCITEMSLOC [SCIP] ;
          TACTLP = SCITEMACTLPT [SCIP] ;
          TLEFTP = SCITEMPTLEFT [SCIP] ;
          TPTLOC = SCITEMPTLOC [SCIP] ; 
          ISSUE (VARG, RT"LIT", - LITOCT (TPIC)) ;               # + 4 #
  
#         GENERATE CALL TO NULL-FILL SUBROUTINE.
# 
          CALL DSR ;                              # DEPOSIT STORE REG. #
          CALL SXR (CSRN, RK"TRA", TI, TW) ;      # SET ITEM FWA #
          CALL SAR (CSRN, RK"EXT", X$TFWA, 0) ; 
          CALL SAR (1, RK"SYM", APLIST, 0) ;        # GEN SA1 APLIST   #
          ISSUE (XNO, RT"EXT") ;
          ISSUE (OP"RJ", 0, 0, X$NLFL) ;            # GEN RJ  =XDC$NLFL#
          ISSUE (XFORCE, 0) ; 
          CALL CRA ;                              # CLEAR REG. ASSOC. # 
  
 DONE:                             # ALL PATHS REJOIN HERE #
          CALL DSR ;                    # DEPOSIT STORE REGISTER #
          CALL CRA ;                    # CLEAR REGISTER ASSOCIATES # 
          RETURN ;
  
          END 
  
  
  
  
#***      PCV  -  PROCESS CONVERSION OF ITEM VALUE. 
# 
          PROC PCV ;
  
#***
# 
          BEGIN 
  
          ITEM SP, TP ; 
  
          NNUL = 0 ;                         # CLEAR LABEL POINTERS # 
          NULL = 0 ;
          IF  NOT NSIF                       # IF SOURCE ITEM EXISTS #
          THEN BEGIN
               IF  LOOPL NE 0                # IF VARIABLE DIMENSION #
                 AND  NULV [LOOPL] NE 0 
               THEN BEGIN 
                    CALL GXR (I, RK"VAL", TEMV [NULV [LOOPL]], 0) ; 
                    NULL = TSYML ;                  # GEN SA1 NULV #
                    ISSUE (XNO, RT"SYM") ;          # GEN PL,X1 NULL   #
                    ISSUE (OP"XC", XC"PL", I, NULL) ; 
                    END 
               CALL PEN ;                    # PROCESS ENCODING DBP # 
               IF  NOT DBPF 
               THEN BEGIN 
                    IF  SBITMBLOCKSZ [SSIP] NE 0
                    THEN CALL GBM ;          # GENERATE BLOCK MOVE, OR #
                    ELSE BEGIN               # GENERATE ITEM CONVERSION#
                         SP = SBITMPTLOC [SSIP] ; 
                         IF  SBITMLFTPT [SSIP] EQ 0 
                         THEN SP = - SP ; 
                         TP = SCITEMPTLOC [SCIP] ;
                         IF  NOT SCITEMPTLEFT [SCIP]
                         THEN TP = - TP ; 
                         CALL GIC (SBITMDBCLASS [SSIP], RK"SRA",
                                   SBITMUSESIZE [SSIP] * CL,
                                   SBITMJUST [SSIP], SP,
                                   SBITMACTLPT[SSIP], SBITMSIGNF[SSIP], 
                                   SCITEMCLASS [SCIP], RK"TRA", 
                                   SCITEMSIZE [SCIP] * CL, 0, TP, 
                                   SCITEMACTLPT [SCIP], 
                                   SCITEMSIGNFG [SCIP]) ; 
                    END  END
               IF  NULL NE 0
               THEN BEGIN                    # IF VARIABLE DIMENSION #
                    CALL DSR ;               # DEPOSIT STORE REGISTERS #
                    NNUL = TSYML ;
                    ISSUE (XNO, RT"SYM") ;          # GEN EQ NNUL      #
                    ISSUE (OP"EQ", 0, 0, NNUL) ;
                    ISSUE (XLABEL, NULL) ;          # GEN NULL LABEL   #
                    CALL CRA ;               # CLEAR REGISTER ASSOC. #
                    CALL GNF ;               # GENERATE NULL FILL CODE #
                    ISSUE (XLABEL, NNUL) ;   # GEN NNUL LABEL # 
                    CALL CRA ;               # CLEAR REGISTER ASSOC. #
               END  END                      # IF NO SOURCE ITEM #
          ELSE CALL GNF ;                    # GENERATE NULL FILL CODE #
          RETURN ;
  
          END 
  
  
  
  
#***      PDC  -  PROCESS DBP CALL FOR BEFORE/ERROR/AFTER MODIFY/STORE. 
# 
          PROC PDC (ECMOD, ECSTO, RJF) ;
  
          ITEM ECMOD S:DBPENT ;    # ENTRY CODE FOR MODIFY #
          ITEM ECSTO S:DBPENT ;    # ENTRY CODE FOR STORE # 
          ITEM RJF B ;             # TRUE IF *RJ* TO BE GENERATED # 
#***
# 
          BEGIN 
  
          ITEM MFRN ;              # MODE FLAG REGISTER NUMBER #
          ITEM OC S:OP ;           # OPERATION CODE = SABK OR SXBK #
          ITEM RN I ;              # REGISTER NUMBER = 1 OR 6 # 
          ITEM SI I ;              # SYMBOL INDEX # 
  
          CALL IDP (ECMOD) ;                      # CALL ... MODIFY # 
          MODA = DBPA ; 
          CALL IDP (ECSTO) ;                      # CALL ... STORE #
          STOA = DBPA ; 
          IF  MODA + STOA EQ 0                    # RETURN IF NONE #
          THEN RETURN ; 
  
          SI = TSYML ;                            # SAVE POSSIBLE SYM # 
          IF  RJF 
          THEN BEGIN                              # IF *RJ* WANTED #
               OC = OP"SABK" ;                     # THEN CAUSE CODE #
               RN = 1 ;                             # SA1 APLIST #
               END
          ELSE BEGIN                               # ELSE CAUSE CODE #
               OC = OP"SXBK" ;                      # SX6 APLIST #
               CALL DSR ;                         # DEPOSIT STORE REG. #
               RN = CSRN ;
               END
          LOCKX [RN] = TRUE ;                     # DISALLOW MFRN = RN #
          CALL DSR ;                              # DEPOSIT STORE REG. #
          CALL GXR (MFRN, RK"EXV", X$MMOD, 0) ;     # GEN SA2 =XDB$MMOD#
          IF  STOA NE 0 
          THEN BEGIN
               IF  MODA NE 0                      # IF BOTH # 
               THEN BEGIN 
                    ISSUE (XNO, RT"SYM") ;          # GEN SRN MODAPLIST#
                    ISSUE (OC, RN, 0, MODA) ; 
                    END                           # IF STORE ONLY # 
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"XC", XC"NZ", MFRN, SI) ;   # GEN NZ,X2 LABEL  #
               ISSUE (XNO, RT"SYM") ;               # GEN SRN STOAPLIST#
               ISSUE (OC, RN, 0, STOA) ;
               IF  MODA NE 0                      # IF BOTH # 
               THEN ISSUE (XLABEL, SI) ;            # GEN LABEL        #
               END
          ELSE BEGIN                              # IF MODIFY ONLY #
               ISSUE (XNO, RT"SYM") ; 
               ISSUE (OP"XC", XC"ZR", MFRN, SI) ;   # GEN ZR,X2 LABEL  #
               ISSUE (XNO, RT"SYM") ;               # GEN SRN MODAPLIST#
               ISSUE (OC, RN, 0, MODA) ;
               END                                # IF ANY #
          IF  RJF                                 # IF *RJ* WANTED #
          THEN BEGIN
               ISSUE (XNO, RT"EXT") ;               # GEN RJ  =XDB$DPII#
               ISSUE (OP"RJ", 0, 0, X$DPII) ; 
               CALL CRA ;                         # CLEAR REG. ASSOC. # 
               IF  MODA EQ 0  OR  STOA EQ 0       # IF NOT BOTH # 
               THEN ISSUE (XLABEL, SI) ;            # GEN LABEL        #
               ELSE ISSUE (XFORCE, 0) ; 
               END                                # IF *RJ* NOT WANTED #
          ELSE BEGIN
               REGX [RN] = 0 ;                      # GEN SA6 =XDB$MERP#
               CALL SAR (RN, RK"EXT", X$MERP, 0) ;
               CALL CRA ;                         # CLEAR REG. ASSOC.  #
               IF  MODA EQ 0  OR  STOA EQ 0       # IF NOT BOTH # 
               THEN ISSUE (XLABEL, SI) ;            # GEN LABEL        #
               END
          RETURN ;
  
          END 
  
  
  
  
#***      PEN  -  PROCESS *ENCODING* DBP CALL, IF ANY.
# 
          PROC PEN ;
  
  
#***
# 
          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] EQ 0 
                      AND  (SCITEMALWAYS [I]
                            OR  NOT SBITMIDNTICL [SSIP])
                    THEN CALL BDL (SCITEMCODER [I]) ; 
                    DONE = NOT SCITEMCNEXT [I] ;
                    END 
               IF  TDBPL NE 0                # IF ANY PROCS TO CALL # 
               THEN BEGIN                    # GENERATE DBP CALL #
                    CALL GDC (DBPENT"ENCODE") ; 
                    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 SOURCE ITEM LOCATION. 
# 
          IF  NSIF
          THEN BEGIN                         # IF NO SOURCE ITEM #
               SBWP = -1 ;
               SBBP = 0 ;                    # RESET POINTERS # 
               SI = -1 ;
               SW = 0 ; 
               END                           # IF SOURCE ITEM EXISTS #
          ELSE BEGIN
               SBWP = SBITMBWP [SSIP] ;      # SET BEGINNING WORD # 
               SBBP = SBITMBBP [SSIP] ;       # AND BIT POSITIONS # 
               SI = 0 ; 
               SW = SBWP ;                   # SET ITEM + WORD INDEXES #
               END
  
#         SET TARGET ITEM LOCATION. 
# 
          TBWP = SCITEMPBWP [SCIP] ;         # SET BEGINNING WORD # 
          TBBP = SCITEMBBP  [SCIP] ;          # AND BIT POSITIONS # 
          TI = 0 ;
          TW = TBWP ;                        # SET ITEM + WORD INDEXES #
  
#         GENERATE CODE TO CALCULATE ITEM LOCATIONS.
# 
          IF  NSIF                           # IF NO SOURCE ITEM #
          THEN BEGIN
               CALL GXR (I, RK"EXV", X$MMOD, 0) ; 
               CALL DSR ;                           # GEN SA1 =XDB$MMOD#
               SKIP = TSYML ;                     # DEPOSIT STORE REG. #
               ISSUE (XNO, RT"SYM") ;               # GEN NZ,X1 SKIP   #
               ISSUE (OP"XC", XC"NZ", I, SKIP) ;
               END
          ELSE BEGIN
               NULL = 0 ;                    # IF SOURCE ITEM EXISTS #
               IF  LOOPL NE 0 
               THEN BEGIN                         # IF OCCURRENCE # 
                    IF  NULV [LOOPL] NE 0          # MAY BE NULL #
                    THEN BEGIN
                         CALL GXR (I, RK"VAL", TEMV [NULV [LOOPL]], 0) ;
                         CALL GXR (M, RK"EXV", X$MMOD, 0) ; 
                         CALL DSR ;                 # GEN SA1 NULL FLAG#
                         NNUL = TSYML ;             # GEN SA2 =XDB$MMOD#
                         ISSUE (XNO, RT"SYM") ;   # DEPOSIT STORE REG. #
                         ISSUE (OP"XC", XC"MI", I, NNUL) ;
                         SKIP = TSYML ;             # GEN MI,X1 NNUL   #
                         ISSUE (XNO, RT"SYM") ;     # GEN NZ,X2 SKIP   #
                         ISSUE (OP"XC", XC"NZ", M, SKIP) ;
                         ISSUE (OP"XOR", 7, 7, 7) ; # GEN BX7 X7-X7 # 
                         ISSUE (OP"MASK", 6, 0, WL-1) ; # MX6 -1 #
                         NULL = TSYML ;             # GEN EQ  NULL     #
                         ISSUE (XNO, RT"SYM") ; 
                         ISSUE (OP"EQ", 0, 0, NULL) ; 
                         ISSUE (XLABEL, NNUL) ;     # GEN NNUL LABEL   #
                         END
                    ELSE CALL DSR ;               # DEPOSIT STORE REG. #
  
#         GENERATE CODE TO CALCULATE SOURCE ITEM LOCATION.
# 
                    SI = SSIP ;              # 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<SBITMTYPE[SSIP]> 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<SBITMTYPE[SSIP]> VECTOR EQ 0
                         THEN BEGIN 
                              CALL GXR (I, RK"CON", K, CF"INT") ; 
                              LOCKX [6] = TRUE ;            # GEN SXI  #
                              CALL FXR (J, RK"NUL", 0, 0) ;  # NBITS + #
                              LOCKX [6] = FALSE ;             # NWORDS #
                              REGX  [J] = 0 ; 
                              ISSUE (OP"IADD", J, V, I) ; 
                              END                      # GEN IXJ XV+XI #
                         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 #
                         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
                    IF  NULL NE 0                 # IF OCCURRENCE # 
                    THEN BEGIN                     # MAY BE NULL #
                         ISSUE (XLABEL, NULL) ;     # GEN NULL LABEL   #
                         CALL CRA ;                # CLEAR REG. ASSOC. #
                         END
                    CALL SAR (6, RK"EXT", X$SBWP, 0) ;  # SA6 =XDC$SBWP#
                    CALL SAR (7, RK"EXT", X$SBBP, 0) ;  # SA7 =XDC$SBBP#
               END  END 
  
#         GENERATE CODE TO CALCULATE TARGET ITEM LOCATION.
# 
          IF  LOOPL NE 0
          THEN BEGIN                         # SET TARGET POINTERS FOR #
               TI = SCIP ;                    # 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<SCITMDATATYP[SCIP]> 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<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 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
