1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUNTIME 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-2003 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 2,  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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34with Ada.IO_Exceptions;         use Ada.IO_Exceptions;
35with Interfaces.C_Streams;      use Interfaces.C_Streams;
36with System;                    use System;
37with System.CRTL;
38with System.File_IO;
39with System.Soft_Links;
40with Unchecked_Deallocation;
41
42package body System.Direct_IO is
43
44   package FIO renames System.File_IO;
45   package SSL renames System.Soft_Links;
46
47   subtype AP is FCB.AFCB_Ptr;
48   use type FCB.Shared_Status_Type;
49
50   use type System.CRTL.long;
51   use type System.CRTL.size_t;
52
53   -----------------------
54   -- Local Subprograms --
55   -----------------------
56
57   procedure Set_Position (File : in File_Type);
58   --  Sets file position pointer according to value of current index
59
60   -------------------
61   -- AFCB_Allocate --
62   -------------------
63
64   function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is
65      pragma Unreferenced (Control_Block);
66
67   begin
68      return new Direct_AFCB;
69   end AFCB_Allocate;
70
71   ----------------
72   -- AFCB_Close --
73   ----------------
74
75   --  No special processing required for Direct_IO close
76
77   procedure AFCB_Close (File : access Direct_AFCB) is
78      pragma Unreferenced (File);
79
80   begin
81      null;
82   end AFCB_Close;
83
84   ---------------
85   -- AFCB_Free --
86   ---------------
87
88   procedure AFCB_Free (File : access Direct_AFCB) is
89
90      type FCB_Ptr is access all Direct_AFCB;
91
92      FT : FCB_Ptr := FCB_Ptr (File);
93
94      procedure Free is new
95        Unchecked_Deallocation (Direct_AFCB, FCB_Ptr);
96
97   begin
98      Free (FT);
99   end AFCB_Free;
100
101   ------------
102   -- Create --
103   ------------
104
105   procedure Create
106     (File : in out File_Type;
107      Mode : in FCB.File_Mode := FCB.Inout_File;
108      Name : in String := "";
109      Form : in String := "")
110   is
111      Dummy_File_Control_Block : Direct_AFCB;
112      pragma Warnings (Off, Dummy_File_Control_Block);
113      --  Yes, we know this is never assigned a value, only the tag
114      --  is used for dispatching purposes, so that's expected.
115
116   begin
117      FIO.Open (File_Ptr  => AP (File),
118                Dummy_FCB => Dummy_File_Control_Block,
119                Mode      => Mode,
120                Name      => Name,
121                Form      => Form,
122                Amethod   => 'D',
123                Creat     => True,
124                Text      => False);
125   end Create;
126
127   -----------------
128   -- End_Of_File --
129   -----------------
130
131   function End_Of_File (File : in File_Type) return Boolean is
132   begin
133      FIO.Check_Read_Status (AP (File));
134      return Count (File.Index) > Size (File);
135   end End_Of_File;
136
137   -----------
138   -- Index --
139   -----------
140
141   function Index (File : in File_Type) return Positive_Count is
142   begin
143      FIO.Check_File_Open (AP (File));
144      return Count (File.Index);
145   end Index;
146
147   ----------
148   -- Open --
149   ----------
150
151   procedure Open
152     (File : in out File_Type;
153      Mode : in FCB.File_Mode;
154      Name : in String;
155      Form : in String := "")
156   is
157      Dummy_File_Control_Block : Direct_AFCB;
158      pragma Warnings (Off, Dummy_File_Control_Block);
159      --  Yes, we know this is never assigned a value, only the tag
160      --  is used for dispatching purposes, so that's expected.
161
162   begin
163      FIO.Open (File_Ptr  => AP (File),
164                Dummy_FCB => Dummy_File_Control_Block,
165                Mode      => Mode,
166                Name      => Name,
167                Form      => Form,
168                Amethod   => 'D',
169                Creat     => False,
170                Text      => False);
171   end Open;
172
173   ----------
174   -- Read --
175   ----------
176
177   procedure Read
178     (File : in File_Type;
179      Item : Address;
180      Size : in Interfaces.C_Streams.size_t;
181      From : in Positive_Count)
182   is
183   begin
184      Set_Index (File, From);
185      Read (File, Item, Size);
186   end Read;
187
188   procedure Read
189     (File : in File_Type;
190      Item : Address;
191      Size : in Interfaces.C_Streams.size_t)
192   is
193   begin
194      FIO.Check_Read_Status (AP (File));
195
196      --  If last operation was not a read, or if in file sharing mode,
197      --  then reset the physical pointer of the file to match the index
198      --  We lock out task access over the two operations in this case.
199
200      if File.Last_Op /= Op_Read
201        or else File.Shared_Status = FCB.Yes
202      then
203         if End_Of_File (File) then
204            raise End_Error;
205         end if;
206
207         Locked_Processing : begin
208            SSL.Lock_Task.all;
209            Set_Position (File);
210            FIO.Read_Buf (AP (File), Item, Size);
211            SSL.Unlock_Task.all;
212
213         exception
214            when others =>
215               SSL.Unlock_Task.all;
216               raise;
217         end Locked_Processing;
218
219      else
220         FIO.Read_Buf (AP (File), Item, Size);
221      end if;
222
223      File.Index := File.Index + 1;
224
225      --  Set last operation to read, unless we did not read a full record
226      --  (happens with the variant record case) in which case we set the
227      --  last operation as other, to force the file position to be reset
228      --  on the next read.
229
230      if File.Bytes = Size then
231         File.Last_Op := Op_Read;
232      else
233         File.Last_Op := Op_Other;
234      end if;
235   end Read;
236
237   --  The following is the required overriding for Stream.Read, which is
238   --  not used, since we do not do Stream operations on Direct_IO files.
239
240   procedure Read
241     (File : in out Direct_AFCB;
242      Item : out Ada.Streams.Stream_Element_Array;
243      Last : out Ada.Streams.Stream_Element_Offset)
244   is
245   begin
246      raise Program_Error;
247   end Read;
248
249   -----------
250   -- Reset --
251   -----------
252
253   procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode) is
254   begin
255      FIO.Reset (AP (File), Mode);
256      File.Index := 1;
257      File.Last_Op := Op_Read;
258   end Reset;
259
260   procedure Reset (File : in out File_Type) is
261   begin
262      FIO.Reset (AP (File));
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 : in File_Type; To : in 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 : in File_Type) is
283   begin
284      if fseek
285           (File.Stream, long (File.Bytes) *
286              long (File.Index - 1), SEEK_SET) /= 0
287      then
288         raise Use_Error;
289      end if;
290   end Set_Position;
291
292   ----------
293   -- Size --
294   ----------
295
296   function Size (File : in File_Type) return Count is
297   begin
298      FIO.Check_File_Open (AP (File));
299      File.Last_Op := Op_Other;
300
301      if fseek (File.Stream, 0, SEEK_END) /= 0 then
302         raise Device_Error;
303      end if;
304
305      return Count (ftell (File.Stream) / long (File.Bytes));
306   end Size;
307
308   -----------
309   -- Write --
310   -----------
311
312   procedure Write
313     (File   : File_Type;
314      Item   : Address;
315      Size   : in Interfaces.C_Streams.size_t;
316      Zeroes : System.Storage_Elements.Storage_Array)
317
318   is
319      procedure Do_Write;
320      --  Do the actual write
321
322      procedure Do_Write is
323      begin
324         FIO.Write_Buf (AP (File), Item, Size);
325
326         --  If we did not write the whole record (happens with the variant
327         --  record case), then fill out the rest of the record with zeroes.
328         --  This is cleaner in any case, and is required for the last
329         --  record, since otherwise the length of the file is wrong.
330
331         if File.Bytes > Size then
332            FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size);
333         end if;
334      end Do_Write;
335
336   --  Start of processing for Write
337
338   begin
339      FIO.Check_Write_Status (AP (File));
340
341      --  If last operation was not a write, or if in file sharing mode,
342      --  then reset the physical pointer of the file to match the index
343      --  We lock out task access over the two operations in this case.
344
345      if File.Last_Op /= Op_Write
346        or else File.Shared_Status = FCB.Yes
347      then
348         Locked_Processing : begin
349            SSL.Lock_Task.all;
350            Set_Position (File);
351            Do_Write;
352            SSL.Unlock_Task.all;
353
354         exception
355            when others =>
356               SSL.Unlock_Task.all;
357               raise;
358         end Locked_Processing;
359
360      else
361         Do_Write;
362      end if;
363
364      File.Index := File.Index + 1;
365
366      --  Set last operation to write, unless we did not read a full record
367      --  (happens with the variant record case) in which case we set the
368      --  last operation as other, to force the file position to be reset
369      --  on the next write.
370
371      if File.Bytes = Size then
372         File.Last_Op := Op_Write;
373      else
374         File.Last_Op := Op_Other;
375      end if;
376   end Write;
377
378   --  The following is the required overriding for Stream.Write, which is
379   --  not used, since we do not do Stream operations on Direct_IO files.
380
381   procedure Write
382     (File : in out Direct_AFCB;
383      Item : in Ada.Streams.Stream_Element_Array)
384   is
385   begin
386      raise Program_Error;
387   end Write;
388
389end System.Direct_IO;
390