*DECK C$ENTRY 
          IDENT  C$ENTRY
          TITLE  C$ENTRY - STACK PROGRAM NAME FOR SUBPROGRAM ENTRY
          COMMENT  STACK PROGRAM NAME FOR SUBPROGRAM ENTRY
          SST 
 CBENTRY  TITLE  CBENTRY - SUBPROGRAM ENTRY 
          TITLE  C.ENTRY - STACK PROGRAM NAME 
**
*         C.ENTRY   - STACK PROGRAM NAME
* 
*         CALLING SEQUENCE
*                B3 - SUBPROGRAM ENTRY ADDRESS (ZERO IF MAIN PROGRAM) 
*                B4 - SUBPROGRAM NAME 
*                B5 - BINARY LEVEL
* 
*         DOES - STACKS PROGRAM NAME AND CALLING LINE NUMBER
*                PREVIOUS BINARY LEVEL AND C.PRGCS
* 
*         USES - B1 (SET TO 1), ALL EXCEPT A0,X0  (CMM CALLED)
* 
          ENTRY  C.ENTRY
 C.ENTRY  DATA   0
          SA1    STACK       POINTER TO NAME STACK
          SB1    1
          NZ     X1,ENTER1   JP IF NOT FIRST TIME THROUGH 
          SX1    INITSIZE*NWDS     CREATE STACK POINTER 
          LX1    30 
          SX6    LOCLSTK
          BX6    X6+X1
          SA6    A1          PUT POINTER IN STACK 
          BX1    X6 
 ENTER1   BSS    0
          LX1    30          LENGTH 
          SA2    DEPTH
          SX3    X1 
          LX1    30          REPOSITION STACK 
          SX4    X2+B1
          IX6    X4-X3
          NG     X6,ENTER2   ENOUGH ROOM
 NOS1     IFC    NE,/"OSNAME"/SCOPE / 
          SA5    =XC.TAF     GET TAF TASK FLAG
          NZ     X5,ENTER2   JP IF TAF - WILL DIAGNOSE LATER
 NOS1     ENDIF 
          SX7    B3 
          SX5    B4 
          LX5    18 
          SX6    B5 
          LX6    36 
          BX7    X5+X7
          BX7    X6+X7
          SA7    SAVEBS      SAVE B3 THROUGH B5 
          SX1    X1-LOCLSTK 
          NZ     X1,ENTER1A  JP IF NOT LOCAL STACK
          SB6    INITSIZE*2*NWDS   OVERFLOWED LOCAL STACK 
          SB5    STACK       MUST ALLOCATE LARGER ONE FROM CMM
          SB7    2
          RJ     =YC.GETBK   ALLOCATE NEW BLOCK FOR STACK 
          SB2    INITSIZE*NWDS
          SA1    LOCLSTK
          SA2    STACK
          BX6    X1 
          SA6    X2 
 ENTER1A1 BSS    0           MOVE LOCAL STACK TO NEW CMM BLOCK
          SA1    A1+B1
          BX6    X1 
          SA6    A6+B1
          SB2    B2-B1
          NE     B2,B1,ENTER1A1 
          EQ     ENTER1B
 ENTER1A  BSS    0
          SB6    A1 
          SB7    INITSIZE*NWDS
          RJ     =YC.GROWB   GROW THE BLOCK 
 ENTER1B  BSS    0
          SA1    SAVEBS      GET SAVED B REGISTERS
          SB3    X1 
          AX1    18 
          SB4    X1 
          AX1    18 
          SB5    X1 
          SA2    DEPTH
          SA1    STACK
 ENTER2   BSS    0
          SX6    X2+NWDS
          IX4    X1+X2       POINT TO CURRENT ENTRY 
          SA6    A2          SAVE NEW STACK POINTER 
          SA1    B4          NAME WORD 1
          SA2    A1+B1       NAME WORD 2
          BX7    X1 
          SA7    X4 
          SA1    A2+B1       NAME WORD 3
          BX6    X2 
          SA6    A7+B1
          BX7    X1 
          SA7    A6+B1
          MX6    0
          ZR     B3,ENTER3   JP IF MAIN PROGRAM 
          SA2    B3          GET SUBPROGRAM ENTRY ADDRESS 
          SA4    =XC.BINRY   GET OLD BINARY LEVEL 
          LX2    30 
          SX6    B5          CURRENT BINARY LEVEL 
          SA6    A4          SET C.BINARY TO IT 
          SA3    X2-1 
          MX6    30 
          BX6    -X6*X3      LINE NUMBER
          LX4    30 
          BX6    X6+X4       PLUS PREVIOUS BINARY LEVEL 
 CDCS     IFEQ   OP.DCS,OP.DCS2 
          SB2    =YC.RELTL
          NG     B2,NOCDCS0 
          SA4    =YC.RELTL
          LX4    42 
          BX6    X6+X4
 NOCDCS0  BSS    0
 CDCS     ENDIF 
 ENTER3   BSS    0
          SA6    A7+B1       SAVE BINARY LEVEL AND LINE NUMBER
          SA2    =XC.PRGCS
          SA3    C.SVA0      GET SAVED A0 FROM CALL TO SUBPROG
          MX7    60-18
          BX3    -X7*X3 
          SA4    =XC.EQCHR
          LX3    36          SAVE A0 IN BITS 36-53
          BX7    X3+X2
          LX4    54 
          BX7    X4+X7       SAVE C.EQCHR 
          SA7    A6+B1       SAVE ORIG A0 AND PROG COLL SEQ 
*                            BITS 0-17  ADDR OF COLL SEQ TABLE
*                                 30-35 COLL SEQ NUMBER 
*                                 36-53 SAVED A0
*                                 54 SAVED C.EQCHR
*                                 58    SAVED FLAG
          MX6    1
          LX6    58+1 
          BX6    X6+X2
          SA6    A2          FLAG C.PRGCS AS SAVED
 NOS2     IFC    NE,/"OSNAME"/SCOPE / 
          SA1    OVFFLAG     GET OVERFLOW FLAG (FOR TAF TASKS)
          ZR     X1,C.ENTRY  JP IF NOT OVERFLOWED 
          SX1    #TAFOVF     MSG
          MX2    0           NO INSERTS 
          MX3    1           NO LINE NBR (IN STACK) 
          MX6    1           ABORT JOB
          RJ     =XC.MSG     OUTPUT MESSAGE AND ABORT JOB 
 NOS2     ELSE
          EQ     C.ENTRY
 NOS2     ENDIF 
          TITLE  C.EXITP - EXIT PROGRAM 
**
*         C.EXITP  - EXIT PROGRAM 
* 
*         DOES - RESTORES C.PRGCS AND REMOVES PROGRAM NAME FROM STACK 
* 
          ENTRY  C.EXITP
 C.EXITP  DATA   0
          SA1    DEPTH
          SX6    X1-NWDS
          SA6    A1 
          SA2    STACK
          SA4    =XC.PRGCS   GET CURRENT PROG COLL SEQ
          IX1    X6+X2
          SA2    X1+PRGCS 
          SA3    X1+PBLEV    GET PREV BINARY LEVEL + LINE NBR 
          MX6    19 
          LX6    36+19
          BX6    -X6*X2      CLEAR PROG COLL SEQ AND C.EQCHR
          AX2    36 
          SA0    X2          RESTORE A0 TO VALUE PASSED TO SUBPROG
          SA6    A4          RESTORE C.PRGCS
          AX2    18          POSITION C.EQCHR FLAG
          MX7    59 
          BX6    -X7*X2 
          SA6    =XC.EQCHR   RESTORE EQUAL CHARACTER FLAG 
          AX3    30 
          MX7    48 
          BX7    -X7*X3 
          SA7    =XC.BINRY
 CDCS2    IFEQ   OP.DCS,OP.DCS2 
          SB2    =YC.RELTL
          NG     B2,NOCDCS
          AX3    12 
          BX7    X3 
          SA7    =YC.RELTL
 NOCDCS   BSS    0
 CDCS2    ENDIF 
          LX4    30          POSITION COLL SEQ TYPE 
          SX2    X4-CS.NTV
          ZR     X2,C.EXITP  EXIT IF COLL SEQ NATIVE
*                            IF NOT NATIVE, IS IN CMM BLOCK 
          LX4    59-58+30    SAVED FLAG 
          NG     X4,C.EXITP  EXIT IF COLL SEQ WAS SAVED 
          LX4    58+1 
          BX6    X4 
          SA6    =SEXITPOC
          SB7    A6 
          RJ     =YC.FREBK   FREE THE TABLE 
          EQ     C.EXITP
 C.CLSTK  TITLE  C.CLSTK - CLEAR PROGRAM NAME STACK 
**
*         C.CLRSTK - CLEAR PROGRAM NAME STACK 
* 
*         DOES - RESETS THE PROGRAM NAME STACK AND RELEASES ANY CMM 
*                BLOCKS WHICH MAY BE ASSIGNED 
*                STACK IS RESET TO INCLUDE MAIN PROG ONLY - MAINLY FOR
*                TAF RE-ENTRANT TASKS 
          ENTRY  C.CLSTK
 C.CLSTK  DATA   0
          SA1    STACK
          SX1    X1-LOCLSTK 
          ZR     X1,LOCAL1   JP IF NOT A CMM BLOCK
          SB7    STACK
          RJ     =YC.FREBK   GO FREE CMM BLOCK
          SX7    LOCLSTK
          SX1    INITSIZE*NWDS
          LX1    30 
          BX7    X7+X1
          SA7    STACK       RESET STACK TO LOCAL STORAGE 
 LOCAL1   BSS    0
          SX6    NWDS 
          SA6    DEPTH
          EQ     C.CLSTK     RETURN 
          EJECT 
 INITSIZE EQU    10 
 NWDS     EQU    "STKSIZ" 
 PRGCS    EQU    4
 PBLEV    EQU    3           LOCN OF PREVIOUS BINARY LEVEL
 DEPTH    DATA   0
*      SAVEBS MUST IMMEDIATELY PRECEDE STACK FOR OLD ABSOLUTE BINARY
*      CHECK IN C$PRTRC.
 SAVEBS   BSS    1           SAVE B REGISTERS 
 STACK    DATA    0 
 LOCLSTK  BSS    INITSIZE*NWDS
*      THIS CODE MUST FOLLOW (IMMEDIATELY) STACK - USED FOR TAF STACK 
*          OVERFLOW TESTING AND SAVING LAST ITEM
 NOS3     IFC    NE,/"OSNAME"/SCOPE / 
 OVFFLAG  DATA   0,0,0,0,0
 NOS3     ENDIF 
          ENTRY  C.DEPTH
 C.DEPTH  EQU    DEPTH
          ENTRY  C.STACK
 C.STACK  EQU    STACK
          ENTRY  C.SVA0      SAVED A0 FROM ENTRY TO SUBPROGRAM
*                            THIS IS BECAUSE FTN EXPECTS IT 
 C.SVA0   DATA   0
          END 
