Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / a-sequio.adb
blob397a778f36f201ae28f1e44ffe9f9fbbe0e4c9a1
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . S E Q U E N T I A L _ I O --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 -- This is the generic template for Sequential_IO, i.e. the code that gets
33 -- duplicated. We absolutely minimize this code by either calling routines
34 -- in System.File_IO (for common file functions), or in System.Sequential_IO
35 -- (for specialized Sequential_IO functions)
37 with Interfaces.C_Streams; use Interfaces.C_Streams;
38 with System;
39 with System.CRTL;
40 with System.File_Control_Block;
41 with System.File_IO;
42 with System.Storage_Elements;
43 with Ada.Unchecked_Conversion;
45 package body Ada.Sequential_IO is
47 package FIO renames System.File_IO;
48 package FCB renames System.File_Control_Block;
49 package SIO renames System.Sequential_IO;
50 package SSE renames System.Storage_Elements;
52 SU : constant := System.Storage_Unit;
54 subtype AP is FCB.AFCB_Ptr;
55 subtype FP is SIO.File_Type;
57 function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
58 function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode);
60 use type System.CRTL.size_t;
62 -----------
63 -- Close --
64 -----------
66 procedure Close (File : in out File_Type) is
67 begin
68 FIO.Close (AP (File)'Unrestricted_Access);
69 end Close;
71 ------------
72 -- Create --
73 ------------
75 procedure Create
76 (File : in out File_Type;
77 Mode : File_Mode := Out_File;
78 Name : String := "";
79 Form : String := "")
81 begin
82 SIO.Create (FP (File), To_FCB (Mode), Name, Form);
83 end Create;
85 ------------
86 -- Delete --
87 ------------
89 procedure Delete (File : in out File_Type) is
90 begin
91 FIO.Delete (AP (File)'Unrestricted_Access);
92 end Delete;
94 -----------------
95 -- End_Of_File --
96 -----------------
98 function End_Of_File (File : File_Type) return Boolean is
99 begin
100 return FIO.End_Of_File (AP (File));
101 end End_Of_File;
103 ----------
104 -- Form --
105 ----------
107 function Form (File : File_Type) return String is
108 begin
109 return FIO.Form (AP (File));
110 end Form;
112 -------------
113 -- Is_Open --
114 -------------
116 function Is_Open (File : File_Type) return Boolean is
117 begin
118 return FIO.Is_Open (AP (File));
119 end Is_Open;
121 ----------
122 -- Mode --
123 ----------
125 function Mode (File : File_Type) return File_Mode is
126 begin
127 return To_SIO (FIO.Mode (AP (File)));
128 end Mode;
130 ----------
131 -- Name --
132 ----------
134 function Name (File : File_Type) return String is
135 begin
136 return FIO.Name (AP (File));
137 end Name;
139 ----------
140 -- Open --
141 ----------
143 procedure Open
144 (File : in out File_Type;
145 Mode : File_Mode;
146 Name : String;
147 Form : String := "")
149 begin
150 SIO.Open (FP (File), To_FCB (Mode), Name, Form);
151 end Open;
153 ----------
154 -- Read --
155 ----------
157 procedure Read (File : File_Type; Item : out Element_Type) is
158 Siz : constant size_t := (Item'Size + SU - 1) / SU;
159 Rsiz : size_t;
161 begin
162 FIO.Check_Read_Status (AP (File));
164 -- For non-definite type or type with discriminants, read size and
165 -- raise Program_Error if it is larger than the size of the item.
167 if not Element_Type'Definite
168 or else Element_Type'Has_Discriminants
169 then
170 FIO.Read_Buf
171 (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit);
173 -- For a type with discriminants, we have to read into a temporary
174 -- buffer if Item is constrained, to check that the discriminants
175 -- are correct.
177 pragma Extensions_Allowed (On);
178 -- Needed to allow Constrained reference here
180 if Element_Type'Has_Discriminants
181 and then Item'Constrained
182 then
183 declare
184 RsizS : constant SSE.Storage_Offset :=
185 SSE.Storage_Offset (Rsiz - 1);
187 type SA is new SSE.Storage_Array (0 .. RsizS);
189 for SA'Alignment use Standard'Maximum_Alignment;
190 -- We will perform an unchecked conversion of a pointer-to-SA
191 -- into pointer-to-Element_Type. We need to ensure that the
192 -- source is always at least as strictly aligned as the target.
194 type SAP is access all SA;
195 type ItemP is access all Element_Type;
197 pragma Warnings (Off);
198 -- We have to turn warnings off for function To_ItemP,
199 -- because it gets analyzed for all types, including ones
200 -- which can't possibly come this way, and for which the
201 -- size of the access types differs.
203 function To_ItemP is new Ada.Unchecked_Conversion (SAP, ItemP);
205 pragma Warnings (On);
207 Buffer : aliased SA;
209 pragma Unsuppress (Discriminant_Check);
211 begin
212 FIO.Read_Buf (AP (File), Buffer'Address, Rsiz);
213 Item := To_ItemP (Buffer'Access).all;
214 return;
215 end;
216 end if;
218 -- In the case of a non-definite type, make sure the length is OK.
219 -- We can't do this in the variant record case, because the size is
220 -- based on the current discriminant, so may be apparently wrong.
222 if not Element_Type'Has_Discriminants and then Rsiz > Siz then
223 raise Program_Error;
224 end if;
226 FIO.Read_Buf (AP (File), Item'Address, Rsiz);
228 -- For definite type without discriminants, use actual size of item
230 else
231 FIO.Read_Buf (AP (File), Item'Address, Siz);
232 end if;
233 end Read;
235 -----------
236 -- Reset --
237 -----------
239 procedure Reset (File : in out File_Type; Mode : File_Mode) is
240 begin
241 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode));
242 end Reset;
244 procedure Reset (File : in out File_Type) is
245 begin
246 FIO.Reset (AP (File)'Unrestricted_Access);
247 end Reset;
249 -----------
250 -- Write --
251 -----------
253 procedure Write (File : File_Type; Item : Element_Type) is
254 Siz : constant size_t := (Item'Size + SU - 1) / SU;
256 begin
257 FIO.Check_Write_Status (AP (File));
259 -- For non-definite types or types with discriminants, write the size
261 if not Element_Type'Definite
262 or else Element_Type'Has_Discriminants
263 then
264 FIO.Write_Buf
265 (AP (File), Siz'Address, size_t'Size / System.Storage_Unit);
266 end if;
268 FIO.Write_Buf (AP (File), Item'Address, Siz);
269 end Write;
271 end Ada.Sequential_IO;