1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . S E Q U E N T I A L _ I O --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
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 Ada
.Unchecked_Conversion
;
40 with System
.Byte_Swapping
;
42 with System
.File_Control_Block
;
44 with System
.Storage_Elements
;
46 with Interfaces
.C_Streams
; use Interfaces
.C_Streams
;
48 package body Ada
.Sequential_IO
is
50 package FIO
renames System
.File_IO
;
51 package FCB
renames System
.File_Control_Block
;
52 package SIO
renames System
.Sequential_IO
;
53 package SSE
renames System
.Storage_Elements
;
55 SU
: constant := System
.Storage_Unit
;
57 subtype AP
is FCB
.AFCB_Ptr
;
58 subtype FP
is SIO
.File_Type
;
60 function To_FCB
is new Ada
.Unchecked_Conversion
(File_Mode
, FCB
.File_Mode
);
61 function To_SIO
is new Ada
.Unchecked_Conversion
(FCB
.File_Mode
, File_Mode
);
63 use type System
.Bit_Order
;
64 use type System
.CRTL
.size_t
;
66 procedure Byte_Swap
(Siz
: in out size_t
);
73 procedure Byte_Swap
(Siz
: in out size_t
) is
74 use System
.Byte_Swapping
;
77 when 32 => Siz
:= size_t
(Bswap_32
(U32
(Siz
)));
78 when 64 => Siz
:= size_t
(Bswap_64
(U64
(Siz
)));
79 when others => raise Program_Error
;
87 procedure Close
(File
: in out File_Type
) is
89 FIO
.Close
(AP
(File
)'Unrestricted_Access);
97 (File
: in out File_Type
;
98 Mode
: File_Mode
:= Out_File
;
103 SIO
.Create
(FP
(File
), To_FCB
(Mode
), Name
, Form
);
110 procedure Delete
(File
: in out File_Type
) is
112 FIO
.Delete
(AP
(File
)'Unrestricted_Access);
119 function End_Of_File
(File
: File_Type
) return Boolean is
121 return FIO
.End_Of_File
(AP
(File
));
128 function Form
(File
: File_Type
) return String is
130 return FIO
.Form
(AP
(File
));
137 function Is_Open
(File
: File_Type
) return Boolean is
139 return FIO
.Is_Open
(AP
(File
));
146 function Mode
(File
: File_Type
) return File_Mode
is
148 return To_SIO
(FIO
.Mode
(AP
(File
)));
155 function Name
(File
: File_Type
) return String is
157 return FIO
.Name
(AP
(File
));
165 (File
: in out File_Type
;
171 SIO
.Open
(FP
(File
), To_FCB
(Mode
), Name
, Form
);
178 procedure Read
(File
: File_Type
; Item
: out Element_Type
) is
179 Siz
: constant size_t
:= (Item
'Size + SU
- 1) / SU
;
183 FIO
.Check_Read_Status
(AP
(File
));
185 -- For non-definite type or type with discriminants, read size and
186 -- raise Program_Error if it is larger than the size of the item.
188 if not Element_Type
'Definite
189 or else Element_Type
'Has_Discriminants
192 (AP
(File
), Rsiz
'Address, size_t
'Size / System
.Storage_Unit
);
194 -- If item read has non-default scalar storage order, then the size
195 -- will have been written with that same order, so byte swap it.
197 if Element_Type
'Scalar_Storage_Order /= System
.Default_Bit_Order
then
201 -- For a type with discriminants, we have to read into a temporary
202 -- buffer if Item is constrained, to check that the discriminants
205 pragma Extensions_Allowed
(On
);
206 -- Needed to allow Constrained reference here
208 if Element_Type
'Has_Discriminants
209 and then Item
'Constrained
212 RsizS
: constant SSE
.Storage_Offset
:=
213 SSE
.Storage_Offset
(Rsiz
- 1);
215 type SA
is new SSE
.Storage_Array
(0 .. RsizS
);
217 for SA
'Alignment use Standard
'Maximum_Alignment;
218 -- We will perform an unchecked conversion of a pointer-to-SA
219 -- into pointer-to-Element_Type. We need to ensure that the
220 -- source is always at least as strictly aligned as the target.
222 type SAP
is access all SA
;
223 type ItemP
is access all Element_Type
;
225 pragma Warnings
(Off
);
226 -- We have to turn warnings off for function To_ItemP,
227 -- because it gets analyzed for all types, including ones
228 -- which can't possibly come this way, and for which the
229 -- size of the access types differs.
231 function To_ItemP
is new Ada
.Unchecked_Conversion
(SAP
, ItemP
);
233 pragma Warnings
(On
);
237 pragma Unsuppress
(Discriminant_Check
);
240 FIO
.Read_Buf
(AP
(File
), Buffer
'Address, Rsiz
);
241 Item
:= To_ItemP
(Buffer
'Access).all;
246 -- In the case of a non-definite type, make sure the length is OK.
247 -- We can't do this in the variant record case, because the size is
248 -- based on the current discriminant, so may be apparently wrong.
250 if not Element_Type
'Has_Discriminants and then Rsiz
> Siz
then
254 FIO
.Read_Buf
(AP
(File
), Item
'Address, Rsiz
);
256 -- For definite type without discriminants, use actual size of item
259 FIO
.Read_Buf
(AP
(File
), Item
'Address, Siz
);
267 procedure Reset
(File
: in out File_Type
; Mode
: File_Mode
) is
269 FIO
.Reset
(AP
(File
)'Unrestricted_Access, To_FCB
(Mode
));
272 procedure Reset
(File
: in out File_Type
) is
274 FIO
.Reset
(AP
(File
)'Unrestricted_Access);
281 procedure Write
(File
: File_Type
; Item
: Element_Type
) is
282 Siz
: constant size_t
:= (Item
'Size + SU
- 1) / SU
;
283 -- Size to be written, in native representation
285 Swapped_Siz
: size_t
:= Siz
;
286 -- Same, possibly byte swapped to account for Element_Type endianness
289 FIO
.Check_Write_Status
(AP
(File
));
291 -- For non-definite types or types with discriminants, write the size
293 if not Element_Type
'Definite
294 or else Element_Type
'Has_Discriminants
296 -- If item written has non-default scalar storage order, then the
297 -- size is written with that same order, so byte swap it.
299 if Element_Type
'Scalar_Storage_Order /= System
.Default_Bit_Order
then
300 Byte_Swap
(Swapped_Siz
);
304 (AP
(File
), Swapped_Siz
'Address, size_t
'Size / System
.Storage_Unit
);
307 FIO
.Write_Buf
(AP
(File
), Item
'Address, Siz
);
310 end Ada
.Sequential_IO
;