MACRO
	 GBLRAISE  &NAME
	 L     R4,GBL$X&NAME
	 B     GBLERRH
	 MEND
         MACRO
         GBLCALL   &NAME
         L     R11,GBL$&NAME
         BR    R11
         CNOP  0,4
         MEND
*
* $Source: /commtar/monoBANK/RTS/tKadaglbi.a,v $
* $Revision: 1.2 $ $Date: 88/06/24 10:50:21 $ $Author: callen $
*
         PUNCH ' ALIAS #ADAGLBI'
         SPACE
#ADAGLBI ADASTART 'Initialize an Ada Global Area',CICS=NO
*
*  This routine initializes the AIE compatible section of
*  the Ada task global area. All MVS specific initialization
*  is done elsewhere.
*
*  The AIE portion of the global area consists largely of a
*  series of small interface routines to the "true" service
*  routines that are referenced directly by generated code.
*  This module sets up these "glue" routines and initializes
*  the address constants that they must reference. ALL CODE
*  AFTER THE LABEL "STATICS" IS NOT EXECUTED AS A PART OF THIS
*  ROUTINE, BUT IS INSERTED INTO THE GLOBAL AREA.
*
*  Linkage to this routine --
*
*            L     R15,=V(#ADAGLBI)
*            BALR  R14,R15
*
*  At entry, R13 -> the AIE part of the task global area to be
*  initialized.
*
*  Registers 14-1 are used and not restored.
*
         EXTRN  #ALSTKSG        Allocate stack segment routine
         EXTRN  #RAISEXN        Raise Exception  (Internal)
         EXTRN  #RERAISE        ReRaise Exception  (Internal)
	 EXTRN  STNDRDSR        The package standard (Ada or asm)
         EXTRN  #ADAMSEC        Mark secondary stack object
         EXTRN  #ADARSEC        Release secondary stack object
         EXTRN  #ADACSEC        Copy secondary stack object
         EXTRN  #ADAASEC        Allocate secondary stack object
         SPACE
         USING  #ADAGLBI,R15    establish addressability
	 USING  GBL,RGLBL       map global area (using prefix)
*
*        The addresses of the predefined Ada exceptions are
*        in package Standard at the following magic offsets.
*        (Maybe someday I will find out where these numbers
*        come from so that I can document it...)
*
	 L      R1,=V(STNDRDSR) point to package Standard
	 LA     R0,12(R1)
	 ST     R0,GBL$XCON         Constraint_Error
	 LA     R0,20(R1)
	 ST     R0,GBL$XNUM         Numeric_Error
	 LA     R0,28(R1)
	 ST     R0,GBL$XPGM         Program_Error
	 LA     R0,36(R1)
	 ST     R0,GBL$XSTO         Storage_Error
	 LA     R0,44(R1)
	 ST     R0,GBL$XTSK         Tasking_Error
         MVC    GBLACONS(ADCONLEN),ADCONS  insert service routine addrs
*
*        All of the address constants are initialized; now insert
*        the interface routines.
*
         MVC    GBLALSTG(ALSTKLEN),ALSTKS  primary stack routine
         MVC    GBLRERR(CODELEN),CODES     insert service routine code
         MVC    GBLTICK(24),FLOATS         constants
         BR     R14                        return to adainit
         SPACE  1
#ADAGBLS DC     A(GBLSIZE)                 this external variable holds
         ENTRY  #ADAGBLS                   the size of task global area
	 DROP
	 SPACE
STATICS  DS     0H
*
* The following address constants point to service routines.
* These addresses are moved into the global area and referred
* to by the "code" portion of the global area. Be sure that
* the order of these constants matches the order specified
* in the global area mapping macro.
*
         DS     0F
ADCONS   EQU    *               Start of address constants
         DC     A(#RERAISE)     ReRaise exception
         DC     A(#RAISEXN)     Raise exception
         DC     A(#ALSTKSG)     Allocate stack segment
         DC     A(#CTLERR)      Dummy entry for controlled heap ops
         DC     A(#ADAMSEC)     Mark secondary stack object
         DC     A(#ADARSEC)     Release secondary stack object
         DC     A(#ADACSEC)     Copy secondary stack object
         DC     A(#ADAASEC)     Allocate secondary stack object
ADCONLEN EQU    *-ADCONS        length of address constant area
*
*        All of the interface routines work on the assumption
*        that register 13 points to the task global area, so set
*        up that addressability
*
         USING  GBL,RGLBL
ALSTKS   DS     0F
         GBLCALL APS            allocate primary stack space
ALSTKLEN EQU    *-ALSTKS
         SPACE  2
CODES    EQU    *               start of interface routines
         GBLCALL RR             reraise
         GBLCALL R              raise exception
         GBLRAISE CON           raise constraint error
         GBLRAISE NUM           raise numeric error
         GBLRAISE PGM           raise program error
         GBLRAISE STO           raise storage error
         GBLRAISE TSK           raise tasking error
         GBLCALL MSEC           Mark secondary stack
*
*        At some point we may want to try marking the secondary
*        stack in place, using this code:
*
*        MVC    0(8,PR1),GBLSSSEG
*        BR     RRET
*
*        This is how it works on UTS. We had problems with this
*        at one time and removed it, but should investigate
*        restoring it.
*
         GBLCALL RSEC           Release secondary stack
         GBLCALL ASEC           Allocate secondary stack
         GBLCALL CSEC           Copy secondary stack
         GBLCALL NCTL           Allocate controlled heap
         GBLCALL NCTL           Free controlled heap
         GBLCALL NCTL           Allocate default heap
CODELEN  EQU    *-CODES         length of code area
         SPACE
FLOATS   DC     XL8'4E00000080000000'    Floating point constants
         DC     XL8'4F00000008000000'    Float'First
         DC     XL8'4E00000100000000'    Float'Last
         SPACE  2
*
*        This routine gets control if an attempt is made to
*        call any of the old heap routines. All it does is
*        raise an exception.
*
         USING  #CTLERR,R11     establish addressability
#CTLERR  DS     0H
         BAL    PR1,#CTLERR1    load address of exception name
	 DC     C'Unsupported_heap_operation_attempted'
	 DC     X'00'
#CTLERR1 DS     0H
         ST     PR1,0(,R13)     save address of exception name
	 OI     0(R13),X'80'    set "EBCDIC" flag
	 LA     PR1,0(,R13)     point to exception descriptor
	 B      GBLERRH         raise exception
	 DROP
	 SPACE  2
         ADAGLOBL
	 ADAMCTL
         END
* $Cprt start$
*  
* Copyright (C) 1988 by Intermetrics, Inc. 
*  
*     This material may be used duplicated or disclosed by or for the 
* U.S. Government pursuant to the copyright license under DAR clause 
* 7-104.9(a) (May 1981). 
*  
*     This project was spnsored by the STARS Foundation 
*     Naval Research Laboratory, Washington DC 
*  
* $Cprt end$