-- $Source: /commtar/monoBANK/RTS/tKgtxnst.ada,v $ 
-- $Revision: 1.2 $ $Date: 88/07/01 03:04:57 $ $Author: stt $ 
with RTS_CICS_Transaction_Storage_Pkg;
generic
    type Object is limited private;
      --| type of object being allocated
      --| Must be constrained, or have defaults for discriminants.
      --| May not preallocate if unconstrained.
    type Pointer is access Object;
      --| Access type to object being allocated
      --| (This is user-supplied so may have mutually-recursive
      --| data structures.)
package CICS_Transaction_Storage_Pkg is
    --| Overview
    --| This package allocates storage which is available
    --| during a CICS transaction, but which is automatically
    --| deallocated at transaction exit.
    --| It also allows explicit deallocation via Free.
    
    type Offset is private;
      --| Private type used to hold offset within transaction
      --| storage
      
    function Pre_Allocate return Offset;
      --| Allocate space for Object to be allocated for each
      --| transaction.  Space will be initialized to zeros/nulls.
      --| NOTE: This function is normally called during lib-unit elab.
      --| If called later, it actually does the allocation.
      --| This means that a generic package can use Pre_Allocate and
      --| still work if it is instantiated after lib-unit elaboration.
    
    function Ptr(O : Offset) return Pointer;
      --| Get pointer to area allocated for this transaction,
      --| given its offset.
      --| Raise Allocation_Error if called during lib-unit elaboration.
    pragma Inline(Ptr);
      
    function Allocate return Pointer;
      --| Allocate space which will be automatically freed
      --| at transaction exit, or explicitly by Free.
      --| Space will be initialized to zeros/nulls.
      --| NOTE: This function may only be called after lib-unit elab
      
    function Allocate(Initial_Value : Object) return Pointer;
      --| Allocate space initialized by Initial_Value.
      --| NOTE: This function may only be called after lib-unit elab
    
    procedure Free(Ptr : in out Pointer);
      --| Free space allocated by Allocate.
      --| Ptr is set to null prior to return.
      --| NOTE: This procedure may be called at most once for
      --| pointer returned by Allocate.
      
    Allocation_Error : exception renames
      RTS_CICS_Transaction_Storage_Pkg.Allocation_Error;
      --| Raised if attempting to allocate prior to elaboration.
      
    Unconstrained_Error : exception;
      --| Raised if trying to preallocate or allocate without initial
      --| value an unconstrained type.
private
    type Offset is new RTS_CICS_Transaction_Storage_Pkg.Offset;
end CICS_Transaction_Storage_Pkg;

with System;
with Unchecked_Conversion;
package body CICS_Transaction_Storage_Pkg is
    --| Overview
    --| This package allocates storage which is available
    --| during a CICS transaction, but which is automatically
    --| deallocated at transaction exit.
    --| It also allows explicit deallocation via Free.
    
    package TXS renames RTS_CICS_Transaction_Storage_Pkg;
    
    Bits_Per_Aligned_Word : constant := Integer'SIZE;
    SUs_Per_Aligned_Word : constant :=
      Bits_Per_Aligned_Word/System.Storage_Unit;
    
    Object_Size : constant Integer :=
      (Object'SIZE + (Bits_Per_Aligned_Word - 1))/Bits_Per_Aligned_Word *
      SUs_Per_Aligned_Word;  --| Aligned size
      
    function To_Ptr is new Unchecked_Conversion(
      System.Address, Pointer
    );
    
    function To_Addr is new Unchecked_Conversion(
      Pointer, System.Address
    );
    
    function Pre_Allocate return Offset is
      --| Allocate space for Object to be allocated for each
      --| transaction.
      --| NOTE: This function is normally called during lib-unit elab.
      --| If called later, it actually does the allocation.
      --| This means that a generic package can use Pre_Allocate and
      --| still work if it is instantiated after lib-unit elaboration.
    begin
	if not Object'CONSTRAINED then
	    raise UNCONSTRAINED_ERROR;
	end if;
	return Pre_Allocate(Object_Size);
    end Pre_Allocate;
    
    function Ptr(O : Offset) return Pointer is
      --| Get pointer to area allocated for this transaction,
      --| given its offset.
    begin
	return To_Ptr(Addr(O));
    end Ptr;
      
    function Allocate return Pointer is
      --| Allocate space which will be automatically freed
      --| at transaction exit, or explicitly by Free.
      --| Space will be initialized to zeros/nulls.
      --| NOTE: This function may only be called after lib-unit elab
    begin
	if not Object'CONSTRAINED then
	    raise UNCONSTRAINED_ERROR;
	end if;
	return To_Ptr(TXS.Allocate(Object_Size));
    end Allocate;
      
    function Allocate(Initial_Value : Object) return Pointer is
      --| Allocate space initialized by Initial_Value.
      --| NOTE: This function may only be called after lib-unit elab
        Init_Size : constant Integer :=
	  (Initial_Value'SIZE + (Bits_Per_Aligned_Word-1)) /
	    Bits_Per_Aligned_Word *
	  SUs_Per_Aligned_Word;
    begin
	return To_Ptr(TXS.Allocate(Init_Size, Initial_Value'ADDRESS));
    end Allocate;
    
    procedure Free(Ptr : in out Pointer) is
      --| Free space allocated by Allocate.
      --| Ptr is set to null prior to return.
      --| NOTE: This procedure may be called at most once for
      --| pointer returned by Allocate.
    begin
	if Ptr /= null then
	    TXS.Free(To_Addr(Ptr));
	    Ptr := null;
	end if;
    end Free;
      
end CICS_Transaction_Storage_Pkg;
    
-- $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$