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------------------------------------------------------------------------------
31
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)
36
37with Interfaces.C_Streams; use Interfaces.C_Streams;
38with System;
39with System.CRTL;
40with System.File_Control_Block;
41with System.File_IO;
42with System.Storage_Elements;
43with Ada.Unchecked_Conversion;
44
45package body Ada.Sequential_IO is
46
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;
51
52   SU : constant := System.Storage_Unit;
53
54   subtype AP is FCB.AFCB_Ptr;
55   subtype FP is SIO.File_Type;
56
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);
59
60   use type System.CRTL.size_t;
61
62   -----------
63   -- Close --
64   -----------
65
66   procedure Close (File : in out File_Type) is
67   begin
68      FIO.Close (AP (File)'Unrestricted_Access);
69   end Close;
70
71   ------------
72   -- Create --
73   ------------
74
75   procedure Create
76     (File : in out File_Type;
77      Mode : File_Mode := Out_File;
78      Name : String := "";
79      Form : String := "")
80   is
81   begin
82      SIO.Create (FP (File), To_FCB (Mode), Name, Form);
83   end Create;
84
85   ------------
86   -- Delete --
87   ------------
88
89   procedure Delete (File : in out File_Type) is
90   begin
91      FIO.Delete (AP (File)'Unrestricted_Access);
92   end Delete;
93
94   -----------------
95   -- End_Of_File --
96   -----------------
97
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;
102
103   ----------
104   -- Form --
105   ----------
106
107   function Form (File : File_Type) return String is
108   begin
109      return FIO.Form (AP (File));
110   end Form;
111
112   -------------
113   -- Is_Open --
114   -------------
115
116   function Is_Open (File : File_Type) return Boolean is
117   begin
118      return FIO.Is_Open (AP (File));
119   end Is_Open;
120
121   ----------
122   -- Mode --
123   ----------
124
125   function Mode (File : File_Type) return File_Mode is
126   begin
127      return To_SIO (FIO.Mode (AP (File)));
128   end Mode;
129
130   ----------
131   -- Name --
132   ----------
133
134   function Name (File : File_Type) return String is
135   begin
136      return FIO.Name (AP (File));
137   end Name;
138
139   ----------
140   -- Open --
141   ----------
142
143   procedure Open
144     (File : in out File_Type;
145      Mode : File_Mode;
146      Name : String;
147      Form : String := "")
148   is
149   begin
150      SIO.Open (FP (File), To_FCB (Mode), Name, Form);
151   end Open;
152
153   ----------
154   -- Read --
155   ----------
156
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;
160
161   begin
162      FIO.Check_Read_Status (AP (File));
163
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.
166
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);
172
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.
176
177         pragma Extensions_Allowed (On);
178         --  Needed to allow Constrained reference here
179
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);
186
187               type SA is new SSE.Storage_Array (0 .. RsizS);
188
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.
193
194               type SAP   is access all SA;
195               type ItemP is access all Element_Type;
196
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.
202
203               function To_ItemP is new Ada.Unchecked_Conversion (SAP, ItemP);
204
205               pragma Warnings (On);
206
207               Buffer : aliased SA;
208
209               pragma Unsuppress (Discriminant_Check);
210
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;
217
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.
221
222         if not Element_Type'Has_Discriminants and then Rsiz > Siz then
223            raise Program_Error;
224         end if;
225
226         FIO.Read_Buf (AP (File), Item'Address, Rsiz);
227
228      --  For definite type without discriminants, use actual size of item
229
230      else
231         FIO.Read_Buf (AP (File), Item'Address, Siz);
232      end if;
233   end Read;
234
235   -----------
236   -- Reset --
237   -----------
238
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;
243
244   procedure Reset (File : in out File_Type) is
245   begin
246      FIO.Reset (AP (File)'Unrestricted_Access);
247   end Reset;
248
249   -----------
250   -- Write --
251   -----------
252
253   procedure Write (File : File_Type; Item : Element_Type) is
254      Siz : constant size_t := (Item'Size + SU - 1) / SU;
255
256   begin
257      FIO.Check_Write_Status (AP (File));
258
259      --  For non-definite types or types with discriminants, write the size
260
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;
267
268      FIO.Write_Buf (AP (File), Item'Address, Siz);
269   end Write;
270
271end Ada.Sequential_IO;
272