-- $Header: /commtar/monoBANK/RTS/dio.bdy,v 1.52 87/11/18 15:17:22 offer Exp $ -- $Source: /commtar/monoBANK/RTS/dio.bdy,v $ -- $Revision: 1.52 $ -- $Date: 87/11/18 15:17:22 $ -- $Author: offer $ pragma revision ("$Revision: 1.52 $"); with System; with Unchecked_Deallocation; with RTS_TGT_Basic_IO; pragma Elaborate(RTS_TGT_Basic_IO); package body Direct_IO is package BIO renames RTS_TGT_Basic_IO; type Element_Array_Type is array(1..1) of Element_Type; Item_Bits : Natural; Internal_Error : exception; DIO_Mode_To_BIO_Mode : constant array(File_Mode) of BIO.File_Mode := (In_File => BIO.In_File, Out_File => BIO.Out_File, InOut_File => BIO.InOut_File); BIO_Mode_To_DIO_Mode : constant array(BIO.File_Mode range BIO.In_File .. BIO.InOut_File) of File_Mode := (BIO.In_File => In_File, BIO.Out_File => Out_File, BIO.InOut_File => InOut_File); procedure File_Free is new Unchecked_Deallocation(File_Record, File_Type); procedure Create (File : in out File_Type; Mode : in File_Mode := InOut_File; Name : in String := ""; Form : in String := "") is Handle : BIO.File_Type; begin if File /= null then raise Status_Error; end if; BIO.Create(Handle, DIO_Mode_To_BIO_Mode(Mode), Name, Form, BIO.Direct_IO, Item_Bits); File := new File_Record'(Mode => Mode, Handle => Handle); end Create; procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := "") is Handle : BIO.File_Type; begin if File /= null then raise Status_Error; end if; BIO.Open(Handle, DIO_Mode_To_BIO_Mode(Mode), Name, Form, BIO.Direct_IO, Item_Bits); File := new File_Record'(Mode => Mode, Handle => Handle); end Open; procedure Close(File : in out File_Type) is begin if File = null then raise Status_Error; end if; BIO.Close(File.Handle); File_Free(File); File := null; end Close; procedure Delete(File : in out File_Type) is begin if File = null then raise Status_Error; end if; BIO.Delete(File.Handle); File_Free(File); File := null; end Delete; procedure Reset(File : in out File_Type; Mode : in File_Mode) is begin if File = null then raise Status_Error; end if; BIO.Switch_Mode(File => File.Handle, Old_Mode => DIO_Mode_To_BIO_Mode(File.Mode), New_Mode => DIO_Mode_To_BIO_Mode(Mode)); -- Update file record to reflect new mode if File.Mode = Mode then -- Mode wasn't changed, so we need to reposition file pointer -- explicitly BIO.Reset(File.Handle); else -- Mode was changed, so Switch_Mode repositioned -- file pointer for us. File.Mode := Mode; end if; end Reset; procedure Reset(File : in out File_Type) is begin if File = null then raise Status_Error; end if; BIO.Reset(File.Handle); end Reset; function Mode(File : in File_Type) return File_Mode is begin if File = null then raise Status_Error; end if; return File.Mode; end Mode; function Name(File : in File_Type) return String is begin if File = null then raise Status_Error; end if; return BIO.Name(File.Handle); end Name; function Form(File : in File_Type) return String is begin if File = null then raise Status_Error; end if; return BIO.Form(File.Handle); end Form; function Is_Open (File : in File_Type) return Boolean is begin return File /= null; end Is_Open; procedure Read(File : in File_Type; Item : out Element_Type) is Amount_Read : Natural; Local_Item : Element_Array_Type; begin if File = null then raise Status_Error; end if; if File.Mode = Out_File then raise Mode_Error; end if; Amount_Read := BIO.ReadBits(File.Handle, Local_Item'Address, Item_Bits); if Amount_Read = 0 then raise End_Error; elsif Amount_Read /= Item_Bits then -- These are fixed_sized records here, if something else got -- in the file (foreign_io ?), it is very bad. (Offer) raise Data_error; else Item := Local_Item(1); end if; end Read; procedure Read(File : in File_Type; Item : out Element_Type; From : Positive_Count) is begin Set_Index(File, From); Read(File, Item); end Read; procedure Write(File : in File_Type; Item : in Element_Type) is Local_Item : Element_Array_Type; Amount_Written : Natural; begin if File = null then raise Status_Error; end if; if File.Mode = In_File then raise Mode_Error; end if; Local_Item(1) := Item; Amount_Written := BIO.WriteBits(File.Handle, Local_Item'Address, Item_Bits); if Amount_Written /= Item_Bits then raise Internal_Error; end if; end Write; procedure Write(File : in File_Type; Item : in Element_Type; To : Positive_Count) is begin Set_Index(File, To); Write(File, Item); end Write; procedure Set_Index(File : in File_Type; To : in Positive_Count) is begin if File = null then raise Status_Error; end if; BIO.Set_Index(File.Handle, Item_Bits * (Integer(To) - 1)); end Set_Index; function Index(File : in File_Type) return Positive_Count is Bit_Index : integer; begin if File = null then raise Status_Error; end if; Bit_Index := BIO.Index(File.Handle); return Positive_Count(Bit_Index / Item_Bits + 1); end Index; function Size ( File : in File_Type) return Count is Bit_Size : integer; begin if File = null then raise Status_Error; end if; Bit_Size := BIO.Size(File.Handle); return Count(Bit_Size / Item_Bits); end Size; function End_Of_File(File : in File_Type) return Boolean is begin if File = null then raise Status_Error; end if; if File.Mode = Out_File then raise Mode_Error; end if; return Index(File) > Size(File); end End_Of_File; begin declare -- So object is thrown away after elaboration Element_Array : Element_Array_Type; begin Item_Bits := Element_Array'Size; end; end Direct_IO; -- $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$