1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                     S Y S T E M . D I R E C T _ 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
32with Ada.IO_Exceptions;          use Ada.IO_Exceptions;
33with Ada.Unchecked_Deallocation;
34with Interfaces.C_Streams;       use Interfaces.C_Streams;
35with System;                     use System;
36with System.CRTL;
37with System.File_IO;
38with System.Soft_Links;
39
40package body System.Direct_IO is
41
42   package FIO renames System.File_IO;
43   package SSL renames System.Soft_Links;
44
45   subtype AP is FCB.AFCB_Ptr;
46   use type FCB.Shared_Status_Type;
47
48   use type System.CRTL.long;
49   use type System.CRTL.size_t;
50
51   -----------------------
52   -- Local Subprograms --
53   -----------------------
54
55   procedure Set_Position (File : File_Type);
56   --  Sets file position pointer according to value of current index
57
58   -------------------
59   -- AFCB_Allocate --
60   -------------------
61
62   function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is
63      pragma Unreferenced (Control_Block);
64   begin
65      return new Direct_AFCB;
66   end AFCB_Allocate;
67
68   ----------------
69   -- AFCB_Close --
70   ----------------
71
72   --  No special processing required for Direct_IO close
73
74   procedure AFCB_Close (File : not null access Direct_AFCB) is
75      pragma Unreferenced (File);
76   begin
77      null;
78   end AFCB_Close;
79
80   ---------------
81   -- AFCB_Free --
82   ---------------
83
84   procedure AFCB_Free (File : not null access Direct_AFCB) is
85
86      type FCB_Ptr is access all Direct_AFCB;
87
88      FT : FCB_Ptr := FCB_Ptr (File);
89
90      procedure Free is new
91        Ada.Unchecked_Deallocation (Direct_AFCB, FCB_Ptr);
92
93   begin
94      Free (FT);
95   end AFCB_Free;
96
97   ------------
98   -- Create --
99   ------------
100
101   procedure Create
102     (File : in out File_Type;
103      Mode : FCB.File_Mode := FCB.Inout_File;
104      Name : String := "";
105      Form : String := "")
106   is
107      Dummy_File_Control_Block : Direct_AFCB;
108      pragma Warnings (Off, Dummy_File_Control_Block);
109      --  Yes, we know this is never assigned a value, only the tag is used for
110      --  dispatching purposes, so that's expected.
111
112   begin
113      FIO.Open (File_Ptr  => AP (File),
114                Dummy_FCB => Dummy_File_Control_Block,
115                Mode      => Mode,
116                Name      => Name,
117                Form      => Form,
118                Amethod   => 'D',
119                Creat     => True,
120                Text      => False);
121   end Create;
122
123   -----------------
124   -- End_Of_File --
125   -----------------
126
127   function End_Of_File (File : File_Type) return Boolean is
128   begin
129      FIO.Check_Read_Status (AP (File));
130      return File.Index > Size (File);
131   end End_Of_File;
132
133   -----------
134   -- Index --
135   -----------
136
137   function Index (File : File_Type) return Positive_Count is
138   begin
139      FIO.Check_File_Open (AP (File));
140      return File.Index;
141   end Index;
142
143   ----------
144   -- Open --
145   ----------
146
147   procedure Open
148     (File : in out File_Type;
149      Mode : FCB.File_Mode;
150      Name : String;
151      Form : String := "")
152   is
153      Dummy_File_Control_Block : Direct_AFCB;
154      pragma Warnings (Off, Dummy_File_Control_Block);
155      --  Yes, we know this is never assigned a value, only the tag is used for
156      --  dispatching purposes, so that's expected.
157
158   begin
159      FIO.Open (File_Ptr  => AP (File),
160                Dummy_FCB => Dummy_File_Control_Block,
161                Mode      => Mode,
162                Name      => Name,
163                Form      => Form,
164                Amethod   => 'D',
165                Creat     => False,
166                Text      => False);
167   end Open;
168
169   ----------
170   -- Read --
171   ----------
172
173   procedure Read
174     (File : File_Type;
175      Item : Address;
176      Size : Interfaces.C_Streams.size_t;
177      From : Positive_Count)
178   is
179   begin
180      Set_Index (File, From);
181      Read (File, Item, Size);
182   end Read;
183
184   procedure Read
185     (File : File_Type;
186      Item : Address;
187      Size : Interfaces.C_Streams.size_t)
188   is
189   begin
190      FIO.Check_Read_Status (AP (File));
191
192      --  If last operation was not a read, or if in file sharing mode,
193      --  then reset the physical pointer of the file to match the index
194      --  We lock out task access over the two operations in this case.
195
196      if File.Last_Op /= Op_Read
197        or else File.Shared_Status = FCB.Yes
198      then
199         if End_Of_File (File) then
200            raise End_Error;
201         end if;
202
203         Locked_Processing : begin
204            SSL.Lock_Task.all;
205            Set_Position (File);
206            FIO.Read_Buf (AP (File), Item, Size);
207            SSL.Unlock_Task.all;
208
209         exception
210            when others =>
211               SSL.Unlock_Task.all;
212               raise;
213         end Locked_Processing;
214
215      else
216         FIO.Read_Buf (AP (File), Item, Size);
217      end if;
218
219      File.Index := File.Index + 1;
220
221      --  Set last operation to read, unless we did not read a full record
222      --  (happens with the variant record case) in which case we set the
223      --  last operation as other, to force the file position to be reset
224      --  on the next read.
225
226      File.Last_Op := (if File.Bytes = Size then Op_Read else Op_Other);
227   end Read;
228
229   --  The following is the required overriding for Stream.Read, which is
230   --  not used, since we do not do Stream operations on Direct_IO files.
231
232   procedure Read
233     (File : in out Direct_AFCB;
234      Item : out Ada.Streams.Stream_Element_Array;
235      Last : out Ada.Streams.Stream_Element_Offset)
236   is
237   begin
238      raise Program_Error;
239   end Read;
240
241   -----------
242   -- Reset --
243   -----------
244
245   procedure Reset (File : in out File_Type; Mode : FCB.File_Mode) is
246      pragma Warnings (Off, File);
247      --  File is actually modified via Unrestricted_Access below, but
248      --  GNAT will generate a warning anyway.
249      --
250      --  Note that we do not use pragma Unmodified here, since in -gnatc mode,
251      --  GNAT will complain that File is modified for "File.Index := 1;"
252   begin
253      FIO.Reset (AP (File)'Unrestricted_Access, Mode);
254      File.Index := 1;
255      File.Last_Op := Op_Read;
256   end Reset;
257
258   procedure Reset (File : in out File_Type) is
259      pragma Warnings (Off, File);
260      --  See above (other Reset procedure) for explanations on this pragma
261   begin
262      FIO.Reset (AP (File)'Unrestricted_Access);
263      File.Index := 1;
264      File.Last_Op := Op_Read;
265   end Reset;
266
267   ---------------
268   -- Set_Index --
269   ---------------
270
271   procedure Set_Index (File : File_Type; To : Positive_Count) is
272   begin
273      FIO.Check_File_Open (AP (File));
274      File.Index := Count (To);
275      File.Last_Op := Op_Other;
276   end Set_Index;
277
278   ------------------
279   -- Set_Position --
280   ------------------
281
282   procedure Set_Position (File : File_Type) is
283      use type System.CRTL.ssize_t;
284      R : int;
285   begin
286      if Standard'Address_Size = 64 then
287         R := fseek64
288           (File.Stream, ssize_t (File.Bytes) *
289              ssize_t (File.Index - 1), SEEK_SET);
290      else
291         R := fseek
292           (File.Stream, long (File.Bytes) *
293              long (File.Index - 1), SEEK_SET);
294      end if;
295
296      if R /= 0 then
297         raise Use_Error;
298      end if;
299   end Set_Position;
300
301   ----------
302   -- Size --
303   ----------
304
305   function Size (File : File_Type) return Count is
306      use type System.CRTL.ssize_t;
307   begin
308      FIO.Check_File_Open (AP (File));
309      File.Last_Op := Op_Other;
310
311      if fseek (File.Stream, 0, SEEK_END) /= 0 then
312         raise Device_Error;
313      end if;
314
315      if Standard'Address_Size = 64 then
316         return Count (ftell64 (File.Stream) / ssize_t (File.Bytes));
317      else
318         return Count (ftell (File.Stream) / long (File.Bytes));
319      end if;
320   end Size;
321
322   -----------
323   -- Write --
324   -----------
325
326   procedure Write
327     (File   : File_Type;
328      Item   : Address;
329      Size   : Interfaces.C_Streams.size_t;
330      Zeroes : System.Storage_Elements.Storage_Array)
331
332   is
333      procedure Do_Write;
334      --  Do the actual write
335
336      --------------
337      -- Do_Write --
338      --------------
339
340      procedure Do_Write is
341      begin
342         FIO.Write_Buf (AP (File), Item, Size);
343
344         --  If we did not write the whole record (happens with the variant
345         --  record case), then fill out the rest of the record with zeroes.
346         --  This is cleaner in any case, and is required for the last
347         --  record, since otherwise the length of the file is wrong.
348
349         if File.Bytes > Size then
350            FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size);
351         end if;
352      end Do_Write;
353
354   --  Start of processing for Write
355
356   begin
357      FIO.Check_Write_Status (AP (File));
358
359      --  If last operation was not a write, or if in file sharing mode,
360      --  then reset the physical pointer of the file to match the index
361      --  We lock out task access over the two operations in this case.
362
363      if File.Last_Op /= Op_Write
364        or else File.Shared_Status = FCB.Yes
365      then
366         Locked_Processing : begin
367            SSL.Lock_Task.all;
368            Set_Position (File);
369            Do_Write;
370            SSL.Unlock_Task.all;
371
372         exception
373            when others =>
374               SSL.Unlock_Task.all;
375               raise;
376         end Locked_Processing;
377
378      else
379         Do_Write;
380      end if;
381
382      File.Index := File.Index + 1;
383
384      --  Set last operation to write, unless we did not read a full record
385      --  (happens with the variant record case) in which case we set the
386      --  last operation as other, to force the file position to be reset
387      --  on the next write.
388
389      File.Last_Op := (if File.Bytes = Size then Op_Write else Op_Other);
390   end Write;
391
392   --  The following is the required overriding for Stream.Write, which is
393   --  not used, since we do not do Stream operations on Direct_IO files.
394
395   procedure Write
396     (File : in out Direct_AFCB;
397      Item : Ada.Streams.Stream_Element_Array)
398   is
399   begin
400      raise Program_Error;
401   end Write;
402
403end System.Direct_IO;
404