Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/s-direio.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
33 with Ada.Unchecked_Deallocation;
34 with Interfaces.C_Streams; use Interfaces.C_Streams;
35 with System; use System;
36 with System.CRTL;
37 with System.File_IO;
38 with System.Soft_Links;
39
40 package 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
399 end System.Direct_IO;