*DECK C$ADSUB 
          IDENT  C$ADSUB
  
          MACHINE  ANY,I
          TITLE  C$ADSUB - SUBSTITUTE PARAMETER ADDRESSES 
          COMMENT  SUBSTITUTE PARAMETER ADDRESS 
          SST 
          B1=1
          SPACE  4
**        CBADSUB - SUBSTITUTE PARAMETER ADDRESSES. 
* 
* 
*         CALLING SEQUENCE: 
* 
*         SB3    FWA PARAM ASSOCIATION LIST 
*         SB4    FWA PARAM INSERTION LIST 
*         SB5    PROGRAM ENTRY POINT
*         SB6    ADDRESS OF PROGRAM NAME
*         SX3    BINARY LEVEL NUMBER
*         SX7    NUMBER OF PARAMETERS IN PD USING 
*         RJ     =XC.ADSUB
* 
*         GIVEN:  
* 
*         (A0) = FWA OF PARAMETER ADDRESS FROM CALLING ROUTINE. 
*                A1 ALSO HAS SAME ADDRESS 
*         (B3) = FWA OF PARAMETER ASSOCIATION LIST, WHICH CONSISTS
*                OF THE FOLLOWING, AND IN THE SAME ORDER, FOR EACH
*                ENTRY IN THE USING LIST: 
* 
*                VFD   12/ORD,48/0
* 
*         (B4) = FWA OF PARAMETER INSERTION LIST, WHICH CONSISTS OF 
*                ONE OF THE FOLLOWING FOR EACH PARAMETER REFERENCE: 
* 
*                VFD   12/ORD,18/INCR,12/POS,18/ADR 
* 
*         (B5) = SUBPROGRAM ENTRY POINT ADDRESS 
* 
*         (B6) = ADDRESS OF SUBPROGRAM NAME 
* 
*         (X3)   BINARY LEVEL NUMBER
*         (X7) = NUMBER OF PARAMETERS IN PD USING 
* 
*         WHERE:  
* 
*                ORD   = ORDINAL IN DNAT OF PARAMETER THIS ENTRY
*                        REFERENCES.
*                INCR  = INCREMENT TO BE ADDED TO PARAMETER ADDRESS.
*                POS   = BIT POSITION OF RIGHT-MOST BIT IN INSERTION
*                        FIELD. 
*                ADR   = ADDRESS OF WORD TO BE PROCESSED. 
* 
*         DOES: 
* 
*         CALL CBENTRY TO STACK PROGRAM NAME, RETURN, PREVIOUS BINARY 
*           LEVEL, AND PREVIOUS COLLATING SEQUENCE
*         SUBSTITUTES PARAMETER ADDRESSES IN REFERENCING INSTRUCTIONS 
*         IN CALLED SUBPROGRAM. 
* 
*         NO REGISTERS SAVED
  
  
 EXIT     BSS    0           EXIT FROM CBADSUB
          SB5    0           BINARY LEVEL IN CASE OF OLD BINARY (PRE 472
          ENTRY  C.ADSUB
 C.ADSUB  DATA   0           ENTRY / EXIT 
          SB1    1           SET B1 IN CASE CALL FROM NON-COBOL PROG
*      THE FOLLOWING TEST IS VALID ONLY IF A1 AND A0 ARE EQUAL. 
*      THIS IS THE CASE FOR SUBPROGRAMS GENERATED ON 472 AND UP 
*      ON PREVIOUS LEVELS, THEY PROBABLY WOULD NEVER BE EQUAL 
*      THERE IS NO OTHER WAY TO TEST FOR PRE 472 BINARIES - THIS CODE 
*      SHOULD PROBABLY BE REMOVED SOME TIME AFTER 5.3 IS RELEASED 
          SB2    A0 
          SB7    A1 
          NE     B2,B7,ADS00 JP IF OLE BINARY 
          SA7    PARAMCT
          SX7    B3          SAVE B3 AND B4 OVER C.ENTRY CALL 
*                            A0 IS SAVED BY C.ENTRY 
          SX6    B4 
          LX7    18 
          BX7    X7+X6
          SA7    SAVEREG
          SB3    B5 
          SB4    B6 
          SB5    X3          BINARY LEVEL 
          RJ     =XC.ENTRY
          SA2    SAVEREG
          SB4    X2          RESTORE B3 AND B4
          AX2    18 
          SB3    X2 
          SB5    B4-B1
          SA2    =XC.BINRY
          SX1    X2-6 
          NG     X1,ADS000
          SA2    PARAMCT
          ZR     X2,EXIT
 ADS000   BSS    0
          EQ     B3,B5,EXIT  RETURN IF NO PD USING LIST 
          SA1    A0          RESTORE A1 
 ADS00    BSS    0
          SB6    A1-B1       (B6) = FWA-1 OF PARAMETER ADDRESSES
          SA4    B4-B1       (A4) = FETCH POINTER 
          ZR     X1,ADERR2
          SB4    B0 
 ADS0     SA1    A1+B1
          SB4    B4+B1
          NZ     X1,ADS0
 ADS1     SA4    A4+B1       NEXT INSERTION ENTRY 
          MX7    12 
          ZR     X4,EXIT     RETURN ON ZERO ENTRY 
          BX3    X7*X4
          SB7    B0          (B7) = PARAMETER ORD 
 ADS2     SA2    B3+B7       FIND CORRESPONDING PARAMETER ORD 
          SB7    B7+B1
          ZR     X2,NOPAR    JP IF LS ITEM NOT IN PD USING LIST 
          BX6    X3-X2
          NZ     X6,ADS2
          GT     B7,B4,ADERR2      JP IF MORE PD USINGS THAN CALL USINGS
          SA1    B6+B7       FETCH PARAM ADDRESS
 ADS3     BSS    0
          SX3    X4          ADDRESS OF INSTRUCTION WORD
          AX4    18 
          MX7    -12
          BX6    -X7*X4      SHIFT COUNT
          SB5    X6 
          AX4    12 
          SX2    X4          INCREMENT
          MX6    18 
          LX6    18 
          BX1    X6*X1       PARAMETER ADDRESS
          IX7    X1+X2       ADJUSTED PARAMETER ADDRESS 
          SA2    X3          INSTRUCTION WORD 
          LX6    B5,X6
          BX6    -X6*X2      MASK OUT OLD ADDRESS 
          LX7    B5,X7       POSITION ADDRESS 
          IX6    X6+X7
          SA6    A2 
          EQ     ADS1        LOOP 
          SPACE  3
 NOPAR    BSS    0           REF TO LINKAGE ITEM NOT IN PD USING LIST 
          SX1    400000B     PUT OUT OF RANGE ADDR IN FOR EM 1 IF REFD
          EQ     ADS3 
          SPACE  3
 ADERR2   BSS    0
          SX1    #PARAM2
          SX6    =YC.MSG
          NG     X6,C.ADSUB  EXIT IF MSG NOT LOADED - NOT COBOL CONTROL 
          MX2    0
          SA3    C.ADSUB
          LX3    30 
          SX3    X3-1 
          SX6    1
          RJ     =YC.MSG     OUTPUT MESSAGE AND DIE 
  
 PARAMCT  BSS    1
 SAVEREG  BSS    1
          END 
