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-2019, 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.int64;
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      R : int;
284   begin
285      R :=
286        fseek64
287          (File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET);
288
289      if R /= 0 then
290         raise Use_Error;
291      end if;
292   end Set_Position;
293
294   ----------
295   -- Size --
296   ----------
297
298   function Size (File : File_Type) return Count is
299      Pos : int64;
300
301   begin
302      FIO.Check_File_Open (AP (File));
303      File.Last_Op := Op_Other;
304
305      if fseek64 (File.Stream, 0, SEEK_END) /= 0 then
306         raise Device_Error;
307      end if;
308
309      Pos := ftell64 (File.Stream);
310
311      if Pos = -1 then
312         raise Use_Error;
313      end if;
314
315      return Count (Pos / int64 (File.Bytes));
316   end Size;
317
318   -----------
319   -- Write --
320   -----------
321
322   procedure Write
323     (File   : File_Type;
324      Item   : Address;
325      Size   : Interfaces.C_Streams.size_t;
326      Zeroes : System.Storage_Elements.Storage_Array)
327
328   is
329      procedure Do_Write;
330      --  Do the actual write
331
332      --------------
333      -- Do_Write --
334      --------------
335
336      procedure Do_Write is
337      begin
338         FIO.Write_Buf (AP (File), Item, Size);
339
340         --  If we did not write the whole record (happens with the variant
341         --  record case), then fill out the rest of the record with zeroes.
342         --  This is cleaner in any case, and is required for the last
343         --  record, since otherwise the length of the file is wrong.
344
345         if File.Bytes > Size then
346            FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size);
347         end if;
348      end Do_Write;
349
350   --  Start of processing for Write
351
352   begin
353      FIO.Check_Write_Status (AP (File));
354
355      --  If last operation was not a write, or if in file sharing mode,
356      --  then reset the physical pointer of the file to match the index
357      --  We lock out task access over the two operations in this case.
358
359      if File.Last_Op /= Op_Write
360        or else File.Shared_Status = FCB.Yes
361      then
362         Locked_Processing : begin
363            SSL.Lock_Task.all;
364            Set_Position (File);
365            Do_Write;
366            SSL.Unlock_Task.all;
367
368         exception
369            when others =>
370               SSL.Unlock_Task.all;
371               raise;
372         end Locked_Processing;
373
374      else
375         Do_Write;
376      end if;
377
378      File.Index := File.Index + 1;
379
380      --  Set last operation to write, unless we did not read a full record
381      --  (happens with the variant record case) in which case we set the
382      --  last operation as other, to force the file position to be reset
383      --  on the next write.
384
385      File.Last_Op := (if File.Bytes = Size then Op_Write else Op_Other);
386   end Write;
387
388   --  The following is the required overriding for Stream.Write, which is
389   --  not used, since we do not do Stream operations on Direct_IO files.
390
391   procedure Write
392     (File : in out Direct_AFCB;
393      Item : Ada.Streams.Stream_Element_Array)
394   is
395   begin
396      raise Program_Error;
397   end Write;
398
399end System.Direct_IO;
400