diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/a-sequio.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/a-sequio.adb | 271 |
1 files changed, 271 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/a-sequio.adb b/gcc-4.8.3/gcc/ada/a-sequio.adb new file mode 100644 index 000000000..397a778f3 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/a-sequio.adb @@ -0,0 +1,271 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the generic template for Sequential_IO, i.e. the code that gets +-- duplicated. We absolutely minimize this code by either calling routines +-- in System.File_IO (for common file functions), or in System.Sequential_IO +-- (for specialized Sequential_IO functions) + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; +with System.CRTL; +with System.File_Control_Block; +with System.File_IO; +with System.Storage_Elements; +with Ada.Unchecked_Conversion; + +package body Ada.Sequential_IO is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + package SIO renames System.Sequential_IO; + package SSE renames System.Storage_Elements; + + SU : constant := System.Storage_Unit; + + subtype AP is FCB.AFCB_Ptr; + subtype FP is SIO.File_Type; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + + use type System.CRTL.size_t; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + begin + SIO.Create (FP (File), To_FCB (Mode), Name, Form); + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + begin + return FIO.End_Of_File (AP (File)); + end End_Of_File; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_SIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + begin + SIO.Open (FP (File), To_FCB (Mode), Name, Form); + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read (File : File_Type; Item : out Element_Type) is + Siz : constant size_t := (Item'Size + SU - 1) / SU; + Rsiz : size_t; + + begin + FIO.Check_Read_Status (AP (File)); + + -- For non-definite type or type with discriminants, read size and + -- raise Program_Error if it is larger than the size of the item. + + if not Element_Type'Definite + or else Element_Type'Has_Discriminants + then + FIO.Read_Buf + (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit); + + -- For a type with discriminants, we have to read into a temporary + -- buffer if Item is constrained, to check that the discriminants + -- are correct. + + pragma Extensions_Allowed (On); + -- Needed to allow Constrained reference here + + if Element_Type'Has_Discriminants + and then Item'Constrained + then + declare + RsizS : constant SSE.Storage_Offset := + SSE.Storage_Offset (Rsiz - 1); + + type SA is new SSE.Storage_Array (0 .. RsizS); + + for SA'Alignment use Standard'Maximum_Alignment; + -- We will perform an unchecked conversion of a pointer-to-SA + -- into pointer-to-Element_Type. We need to ensure that the + -- source is always at least as strictly aligned as the target. + + type SAP is access all SA; + type ItemP is access all Element_Type; + + pragma Warnings (Off); + -- We have to turn warnings off for function To_ItemP, + -- because it gets analyzed for all types, including ones + -- which can't possibly come this way, and for which the + -- size of the access types differs. + + function To_ItemP is new Ada.Unchecked_Conversion (SAP, ItemP); + + pragma Warnings (On); + + Buffer : aliased SA; + + pragma Unsuppress (Discriminant_Check); + + begin + FIO.Read_Buf (AP (File), Buffer'Address, Rsiz); + Item := To_ItemP (Buffer'Access).all; + return; + end; + end if; + + -- In the case of a non-definite type, make sure the length is OK. + -- We can't do this in the variant record case, because the size is + -- based on the current discriminant, so may be apparently wrong. + + if not Element_Type'Has_Discriminants and then Rsiz > Siz then + raise Program_Error; + end if; + + FIO.Read_Buf (AP (File), Item'Address, Rsiz); + + -- For definite type without discriminants, use actual size of item + + else + FIO.Read_Buf (AP (File), Item'Address, Siz); + end if; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : File_Mode) is + begin + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + end Reset; + + procedure Reset (File : in out File_Type) is + begin + FIO.Reset (AP (File)'Unrestricted_Access); + end Reset; + + ----------- + -- Write -- + ----------- + + procedure Write (File : File_Type; Item : Element_Type) is + Siz : constant size_t := (Item'Size + SU - 1) / SU; + + begin + FIO.Check_Write_Status (AP (File)); + + -- For non-definite types or types with discriminants, write the size + + if not Element_Type'Definite + or else Element_Type'Has_Discriminants + then + FIO.Write_Buf + (AP (File), Siz'Address, size_t'Size / System.Storage_Unit); + end if; + + FIO.Write_Buf (AP (File), Item'Address, Siz); + end Write; + +end Ada.Sequential_IO; |