-- $Source: /commtar/monoBANK/CICS_INTF/fc.bdy,v $ -- $Revision: 1.18 $ $Date: 88/05/13 16:05:22 $ $Author: chris $ with System; use System; with Host_Character_Pkg; with System; with Temp_IO; package body CICS_File_Control is package HC renames Host_Character_Pkg; package TIO renames Temp_IO; subtype Halfword is integer range -2**15 .. 2**15-1; File_Name_Len : constant Integer := 8; -- maximum length of a file name on MVS Bits_Per_SU : constant Integer := 8; -- number of bits per storage unit since X'Size returns the number -- of bits and we need to know the number of SUs Debugging : constant Boolean := True; -- flag to surround debugging output. ------------------------------------------------------------------ -- Visible Subprograms procedure Read( File : in File_Type; Element : out Element_Type; Key : in Key_Type; Generic_Key : in Boolean :=False; Gt_Eq : in Boolean := False; Update : in Boolean := False ) is procedure CICS_Read( File : HC.Host_String; Element : out Element_Ptr_Type; -- pointer to area Len : out Halfword; Key : System.Address; -- address of Key. Key_Len : Halfword; -- if key_len is not 0 then the key is -- generic Gt_Eq : Boolean; Update : Boolean ); pragma Interface(AIE_ASSEMBLER, CICS_Read); pragma Link_Name(CICS_Read, "CIC$READ"); Elt_Ptr : Element_Ptr_Type; Len : Halfword; Local_Key : constant Key_Type := Key; Key_Len : Halfword:= 0; begin if Generic_Key then Key_Len := (Local_Key'Size)/Bits_Per_SU; end if; CICS_Read(HC.To_Padded_Host_String(File, File_Name_Len), Elt_Ptr, Len, Local_Key'Address, Key_Len, Gt_Eq, Update); if Element_Type'Constrained = False and then Element_Type'Size/Bits_Per_SU <= Len then -- if the type is unconstrained then the element type size -- must be larger that the amount passed back. if Debugging then TIO.Put_Line("Element is unconstrained"); TIO.Put_Line("Element_Length: " & Integer'image(Element_Type'Size/Bits_Per_SU) & " Actual Len: " & Integer'image(Len)); end if; raise DATA_ERROR; elsif Element_Type'Constrained =True and then Element'Size/Bits_Per_SU /= Len then -- otherwise if type is constrained then the element size must -- be the same as the data passed back if Debugging then TIO.Put_Line("Element is constrained"); TIO.Put_Line("Element_Length: " & Integer'image(Element_Type'Size/Bits_Per_SU) & " Actual Len: " & Integer'image(Len)); end if; raise DATA_ERROR; else -- everything should be okay. Element := Elt_Ptr.all; end if; end Read; procedure Write( File : in File_Type; From : in Element_Type; Key : in Key_Type ) is procedure CICS_Write( File : HC.Host_String; -- string From : in System.Address; -- pointer to area Len : Halfword; Key : System.Address; -- address of Key. Key_Len : Halfword ); pragma Interface(AIE_ASSEMBLER, CICS_Write); pragma Link_Name(CICS_Write, "CIC$WRIT"); Len : Halfword; Key_Len : Halfword; Local_Key : constant Key_Type := Key; begin Len := From'Size/Bits_Per_SU; Key_Len := Local_Key'Size/Bits_Per_SU; CICS_Write(HC.To_Padded_Host_String(File, File_Name_Len), From'Address, Len, Local_Key'Address, Key_Len); end Write; procedure Rewrite( File : in File_Type; From : in Element_Type ) is procedure CICS_Rewrite( File : HC.Host_String; -- string From : in System.Address; -- pointer to area Len : Halfword ); pragma Interface(AIE_ASSEMBLER, CICS_Rewrite); pragma Link_Name(CICS_Rewrite, "CIC$REWR"); Len : Halfword; begin Len := From'Size/Bits_Per_SU; CICS_Rewrite(HC.To_Padded_Host_String(File, File_Name_Len), From'Address, Len); end Rewrite; procedure Delete( File : in File_Type; Key : in Key_Type; Generic_Key : in Boolean := False ) is procedure CICS_Delete( File : HC.Host_String; -- string Key : System.Address; -- pointer to area KeyLen : Halfword ); pragma Interface(AIE_ASSEMBLER, CICS_Delete); pragma Link_Name(CICS_Delete, "CIC$DEL1"); Key_Len : Halfword := 0; Local_Key : constant Key_Type := Key; begin if Generic_Key then Key_Len := (Local_Key'Size)/Bits_Per_SU; end if; CICS_Delete(HC.To_Padded_Host_String(File, File_Name_Len), Local_Key'Address, Key_Len); end Delete; procedure Delete( File : in File_Type ) is procedure CICS_Delete( File : in HC.Host_String); pragma Interface(AIE_ASSEMBLER, CICS_Delete); pragma Link_Name(CICS_Delete, "CIC$DEL2"); begin CICS_Delete(HC.To_Padded_Host_String(File, File_Name_Len)); end Delete; procedure Unlock( File : in File_Type ) is procedure CICS_Unlock( File : in HC.Host_String); pragma Interface(AIE_ASSEMBLER, CICS_Unlock); pragma Link_Name(CICS_Unlock, "CIC$UNLK"); begin CICS_Unlock(HC.To_Padded_Host_String(File, File_Name_Len)); end Unlock; procedure Start_Browse( File : in File_Type; Key : in Key_Type; Generic_Key : in Boolean := False; Gt_Eq : in Boolean := False ) is procedure CICS_Start_Browse( File : HC.Host_String; Key : System.Address; Key_Len : Halfword; Gt_Eq : Boolean ); pragma Interface(AIE_ASSEMBLER, CICS_Start_Browse); pragma Link_Name(CICS_Start_Browse, "CIC$STBR"); Key_Len : Halfword := 0; begin if Generic_Key then Key_Len := (Key'Size)/Bits_Per_SU; end if; CICS_Start_Browse(HC.To_Padded_Host_String(File, File_Name_Len), Key'Address, Key_Len, Gt_Eq); end Start_Browse; procedure Read_Next( File : in File_Type; Element_Ptr : out Element_Ptr_Type; Key : in out Key_Type ) is procedure CICS_Read_Next( File : HC.Host_String; Elt : out Element_Ptr_Type; -- pointer to area Len : out Halfword; Key : in out System.Address; -- address of Key. Key_Len : in Halfword ); pragma Interface(AIE_ASSEMBLER, CICS_Read_Next); pragma Link_Name (CICS_Read_Next, "CIC$RDNT"); Elt_Ptr : Element_Ptr_Type; Len : Halfword; Key_Len : Halfword; Key_Ptr : System.Address; begin Key_Len := Key'Size / Bits_Per_SU; Key_Ptr := Key'Address; CICS_Read_Next(HC.To_Padded_Host_String(File, File_Name_Len), Elt_Ptr, Len, Key_Ptr, Key_Len); if Element_Type'Constrained = False and then Element_Type'Size/Bits_Per_SU <= Len then -- if the type is unconstrained then the element type size -- must be larger that the amount passed back. raise DATA_ERROR; elsif Element_Type'Constrained =True and then Element_Type'Size/Bits_Per_SU /= Len then -- otherwise if type is constrained then the element size must -- be the same as the data passed back raise DATA_ERROR; else -- everything should be okay. Element_Ptr := Elt_Ptr; end if; end Read_Next; procedure Read_Prev( File : in File_Type; Element_Ptr : out Element_Ptr_Type; Key : in out Key_Type ) is procedure CICS_Read_Prev( File : HC.Host_String; Elt : out Element_Ptr_Type; -- pointer to area Len : out Halfword; Key : in out System.Address; -- address of Key. Key_Len : in Halfword ); pragma Interface(AIE_ASSEMBLER, CICS_Read_Prev); pragma Link_Name(CICS_Read_Prev, "CIC$RDPR"); Elt_Ptr : Element_Ptr_Type; Len : Halfword; Key_Len : Halfword; Key_Ptr : System.Address; begin Key_Len := Key'Size / Bits_Per_SU; Key_Ptr := Key'Address; CICS_Read_Prev(HC.To_Padded_Host_String(File, File_Name_Len), Elt_Ptr, Len, Key_Ptr, Key_Len); if Element_Type'Constrained = False and then Element_Type'Size/Bits_Per_SU <= Len then -- if the type is unconstrained then the element type size -- must be larger that the amount passed back. raise DATA_ERROR; elsif Element_Type'Constrained =True and then Element_Type'Size/Bits_Per_SU /= Len then -- otherwise if type is constrained then the element size must -- be the same as the data passed back raise DATA_ERROR; else -- everything should be okay. Element_Ptr := Elt_Ptr; end if; end Read_Prev; procedure Reset_Browse( File : in File_Type; Key : in Key_Type; Generic_Key : in Boolean := False; Gt_Eq : Boolean := False ) is procedure CICS_Reset_Browse( File : HC.Host_String; Key : System.Address; Key_Len : Halfword; Gt_Eq : Boolean ); pragma Interface(AIE_ASSEMBLER, CICS_Reset_Browse); pragma Link_Name(CICS_Reset_Browse, "CIC$RSBR"); Key_Len : Halfword :=0; begin if Generic_Key then Key_Len := (Key'Size)/Bits_Per_SU; end if; CICS_Reset_Browse(HC.To_Padded_Host_String(File, File_Name_Len), Key'Address, Key_Len, Gt_Eq); end Reset_Browse; procedure End_Browse( File : File_Type ) is procedure CICS_End_Browse( File : in HC.Host_String); pragma Interface(AIE_ASSEMBLER, CICS_End_Browse); pragma Link_Name(CICS_End_Browse, "CIC$ENBR"); begin CICS_End_Browse(HC.To_Padded_Host_String(File, File_Name_Len)); end End_Browse; end CICS_File_Control; -- $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$