|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . W I D E _ W I D E _ T E X T _ I O --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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.Streams; use Ada.Streams;
|
|
|
33 with Interfaces.C_Streams; use Interfaces.C_Streams;
|
|
|
34
|
|
|
35 with System.CRTL;
|
|
|
36 with System.File_IO;
|
|
|
37 with System.WCh_Cnv; use System.WCh_Cnv;
|
|
|
38 with System.WCh_Con; use System.WCh_Con;
|
|
|
39
|
|
|
40 with Ada.Unchecked_Conversion;
|
|
|
41 with Ada.Unchecked_Deallocation;
|
|
|
42
|
|
|
43 pragma Elaborate_All (System.File_IO);
|
|
|
44 -- Needed because of calls to Chain_File in package body elaboration
|
|
|
45
|
|
|
46 package body Ada.Wide_Wide_Text_IO is
|
|
|
47
|
|
|
48 package FIO renames System.File_IO;
|
|
|
49
|
|
|
50 subtype AP is FCB.AFCB_Ptr;
|
|
|
51
|
|
|
52 function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
|
|
|
53 function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode);
|
|
|
54 use type FCB.File_Mode;
|
|
|
55
|
|
|
56 use type System.CRTL.size_t;
|
|
|
57
|
|
|
58 WC_Encoding : Character;
|
|
|
59 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
|
|
|
60 -- Default wide character encoding
|
|
|
61
|
|
|
62 Err_Name : aliased String := "*stderr" & ASCII.NUL;
|
|
|
63 In_Name : aliased String := "*stdin" & ASCII.NUL;
|
|
|
64 Out_Name : aliased String := "*stdout" & ASCII.NUL;
|
|
|
65 -- Names of standard files
|
|
|
66 --
|
|
|
67 -- Use "preallocated" strings to avoid calling "new" during the elaboration
|
|
|
68 -- of the run time. This is needed in the tasking case to avoid calling
|
|
|
69 -- Task_Lock too early. A filename is expected to end with a null character
|
|
|
70 -- in the runtime, here the null characters are added just to have a
|
|
|
71 -- correct filename length.
|
|
|
72 --
|
|
|
73 -- Note: the names for these files are bogus, and probably it would be
|
|
|
74 -- better for these files to have no names, but the ACVC tests insist.
|
|
|
75 -- We use names that are bound to fail in open etc.
|
|
|
76
|
|
|
77 Null_Str : aliased constant String := "";
|
|
|
78 -- Used as form string for standard files
|
|
|
79
|
|
|
80 -----------------------
|
|
|
81 -- Local Subprograms --
|
|
|
82 -----------------------
|
|
|
83
|
|
|
84 function Get_Wide_Wide_Char_Immed
|
|
|
85 (C : Character;
|
|
|
86 File : File_Type) return Wide_Wide_Character;
|
|
|
87 -- This routine is identical to Get_Wide_Wide_Char, except that the reads
|
|
|
88 -- are done in Get_Immediate mode (i.e. without waiting for a line return).
|
|
|
89
|
|
|
90 function Getc_Immed (File : File_Type) return int;
|
|
|
91 -- This routine is identical to Getc, except that the read is done in
|
|
|
92 -- Get_Immediate mode (i.e. without waiting for a line return).
|
|
|
93
|
|
|
94 procedure Putc (ch : int; File : File_Type);
|
|
|
95 -- Outputs the given character to the file, which has already been checked
|
|
|
96 -- for being in output status. Device_Error is raised if the character
|
|
|
97 -- cannot be written.
|
|
|
98
|
|
|
99 procedure Set_WCEM (File : in out File_Type);
|
|
|
100 -- Called by Open and Create to set the wide character encoding method for
|
|
|
101 -- the file, processing a WCEM form parameter if one is present. File is
|
|
|
102 -- IN OUT because it may be closed in case of an error.
|
|
|
103
|
|
|
104 procedure Terminate_Line (File : File_Type);
|
|
|
105 -- If the file is in Write_File or Append_File mode, and the current line
|
|
|
106 -- is not terminated, then a line terminator is written using New_Line.
|
|
|
107 -- Note that there is no Terminate_Page routine, because the page mark at
|
|
|
108 -- the end of the file is implied if necessary.
|
|
|
109
|
|
|
110 procedure Ungetc (ch : int; File : File_Type);
|
|
|
111 -- Pushes back character into stream, using ungetc. The caller has checked
|
|
|
112 -- that the file is in read status. Device_Error is raised if the character
|
|
|
113 -- cannot be pushed back. An attempt to push back and end of file character
|
|
|
114 -- (EOF) is ignored.
|
|
|
115
|
|
|
116 -------------------
|
|
|
117 -- AFCB_Allocate --
|
|
|
118 -------------------
|
|
|
119
|
|
|
120 function AFCB_Allocate
|
|
|
121 (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr
|
|
|
122 is
|
|
|
123 pragma Unreferenced (Control_Block);
|
|
|
124 begin
|
|
|
125 return new Wide_Wide_Text_AFCB;
|
|
|
126 end AFCB_Allocate;
|
|
|
127
|
|
|
128 ----------------
|
|
|
129 -- AFCB_Close --
|
|
|
130 ----------------
|
|
|
131
|
|
|
132 procedure AFCB_Close (File : not null access Wide_Wide_Text_AFCB) is
|
|
|
133 begin
|
|
|
134 -- If the file being closed is one of the current files, then close
|
|
|
135 -- the corresponding current file. It is not clear that this action
|
|
|
136 -- is required (RM A.10.3(23)) but it seems reasonable, and besides
|
|
|
137 -- ACVC test CE3208A expects this behavior.
|
|
|
138
|
|
|
139 if File_Type (File) = Current_In then
|
|
|
140 Current_In := null;
|
|
|
141 elsif File_Type (File) = Current_Out then
|
|
|
142 Current_Out := null;
|
|
|
143 elsif File_Type (File) = Current_Err then
|
|
|
144 Current_Err := null;
|
|
|
145 end if;
|
|
|
146
|
|
|
147 Terminate_Line (File_Type (File));
|
|
|
148 end AFCB_Close;
|
|
|
149
|
|
|
150 ---------------
|
|
|
151 -- AFCB_Free --
|
|
|
152 ---------------
|
|
|
153
|
|
|
154 procedure AFCB_Free (File : not null access Wide_Wide_Text_AFCB) is
|
|
|
155 type FCB_Ptr is access all Wide_Wide_Text_AFCB;
|
|
|
156 FT : FCB_Ptr := FCB_Ptr (File);
|
|
|
157
|
|
|
158 procedure Free is new
|
|
|
159 Ada.Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr);
|
|
|
160
|
|
|
161 begin
|
|
|
162 Free (FT);
|
|
|
163 end AFCB_Free;
|
|
|
164
|
|
|
165 -----------
|
|
|
166 -- Close --
|
|
|
167 -----------
|
|
|
168
|
|
|
169 procedure Close (File : in out File_Type) is
|
|
|
170 begin
|
|
|
171 FIO.Close (AP (File)'Unrestricted_Access);
|
|
|
172 end Close;
|
|
|
173
|
|
|
174 ---------
|
|
|
175 -- Col --
|
|
|
176 ---------
|
|
|
177
|
|
|
178 -- Note: we assume that it is impossible in practice for the column
|
|
|
179 -- to exceed the value of Count'Last, i.e. no check is required for
|
|
|
180 -- overflow raising layout error.
|
|
|
181
|
|
|
182 function Col (File : File_Type) return Positive_Count is
|
|
|
183 begin
|
|
|
184 FIO.Check_File_Open (AP (File));
|
|
|
185 return File.Col;
|
|
|
186 end Col;
|
|
|
187
|
|
|
188 function Col return Positive_Count is
|
|
|
189 begin
|
|
|
190 return Col (Current_Out);
|
|
|
191 end Col;
|
|
|
192
|
|
|
193 ------------
|
|
|
194 -- Create --
|
|
|
195 ------------
|
|
|
196
|
|
|
197 procedure Create
|
|
|
198 (File : in out File_Type;
|
|
|
199 Mode : File_Mode := Out_File;
|
|
|
200 Name : String := "";
|
|
|
201 Form : String := "")
|
|
|
202 is
|
|
|
203 Dummy_File_Control_Block : Wide_Wide_Text_AFCB;
|
|
|
204 pragma Warnings (Off, Dummy_File_Control_Block);
|
|
|
205 -- Yes, we know this is never assigned a value, only the tag
|
|
|
206 -- is used for dispatching purposes, so that's expected.
|
|
|
207
|
|
|
208 begin
|
|
|
209 FIO.Open (File_Ptr => AP (File),
|
|
|
210 Dummy_FCB => Dummy_File_Control_Block,
|
|
|
211 Mode => To_FCB (Mode),
|
|
|
212 Name => Name,
|
|
|
213 Form => Form,
|
|
|
214 Amethod => 'W',
|
|
|
215 Creat => True,
|
|
|
216 Text => True);
|
|
|
217
|
|
|
218 File.Self := File;
|
|
|
219 Set_WCEM (File);
|
|
|
220 end Create;
|
|
|
221
|
|
|
222 -------------------
|
|
|
223 -- Current_Error --
|
|
|
224 -------------------
|
|
|
225
|
|
|
226 function Current_Error return File_Type is
|
|
|
227 begin
|
|
|
228 return Current_Err;
|
|
|
229 end Current_Error;
|
|
|
230
|
|
|
231 function Current_Error return File_Access is
|
|
|
232 begin
|
|
|
233 return Current_Err.Self'Access;
|
|
|
234 end Current_Error;
|
|
|
235
|
|
|
236 -------------------
|
|
|
237 -- Current_Input --
|
|
|
238 -------------------
|
|
|
239
|
|
|
240 function Current_Input return File_Type is
|
|
|
241 begin
|
|
|
242 return Current_In;
|
|
|
243 end Current_Input;
|
|
|
244
|
|
|
245 function Current_Input return File_Access is
|
|
|
246 begin
|
|
|
247 return Current_In.Self'Access;
|
|
|
248 end Current_Input;
|
|
|
249
|
|
|
250 --------------------
|
|
|
251 -- Current_Output --
|
|
|
252 --------------------
|
|
|
253
|
|
|
254 function Current_Output return File_Type is
|
|
|
255 begin
|
|
|
256 return Current_Out;
|
|
|
257 end Current_Output;
|
|
|
258
|
|
|
259 function Current_Output return File_Access is
|
|
|
260 begin
|
|
|
261 return Current_Out.Self'Access;
|
|
|
262 end Current_Output;
|
|
|
263
|
|
|
264 ------------
|
|
|
265 -- Delete --
|
|
|
266 ------------
|
|
|
267
|
|
|
268 procedure Delete (File : in out File_Type) is
|
|
|
269 begin
|
|
|
270 FIO.Delete (AP (File)'Unrestricted_Access);
|
|
|
271 end Delete;
|
|
|
272
|
|
|
273 -----------------
|
|
|
274 -- End_Of_File --
|
|
|
275 -----------------
|
|
|
276
|
|
|
277 function End_Of_File (File : File_Type) return Boolean is
|
|
|
278 ch : int;
|
|
|
279
|
|
|
280 begin
|
|
|
281 FIO.Check_Read_Status (AP (File));
|
|
|
282
|
|
|
283 if File.Before_Wide_Wide_Character then
|
|
|
284 return False;
|
|
|
285
|
|
|
286 elsif File.Before_LM then
|
|
|
287 if File.Before_LM_PM then
|
|
|
288 return Nextc (File) = EOF;
|
|
|
289 end if;
|
|
|
290
|
|
|
291 else
|
|
|
292 ch := Getc (File);
|
|
|
293
|
|
|
294 if ch = EOF then
|
|
|
295 return True;
|
|
|
296
|
|
|
297 elsif ch /= LM then
|
|
|
298 Ungetc (ch, File);
|
|
|
299 return False;
|
|
|
300
|
|
|
301 else -- ch = LM
|
|
|
302 File.Before_LM := True;
|
|
|
303 end if;
|
|
|
304 end if;
|
|
|
305
|
|
|
306 -- Here we are just past the line mark with Before_LM set so that we
|
|
|
307 -- do not have to try to back up past the LM, thus avoiding the need
|
|
|
308 -- to back up more than one character.
|
|
|
309
|
|
|
310 ch := Getc (File);
|
|
|
311
|
|
|
312 if ch = EOF then
|
|
|
313 return True;
|
|
|
314
|
|
|
315 elsif ch = PM and then File.Is_Regular_File then
|
|
|
316 File.Before_LM_PM := True;
|
|
|
317 return Nextc (File) = EOF;
|
|
|
318
|
|
|
319 -- Here if neither EOF nor PM followed end of line
|
|
|
320
|
|
|
321 else
|
|
|
322 Ungetc (ch, File);
|
|
|
323 return False;
|
|
|
324 end if;
|
|
|
325
|
|
|
326 end End_Of_File;
|
|
|
327
|
|
|
328 function End_Of_File return Boolean is
|
|
|
329 begin
|
|
|
330 return End_Of_File (Current_In);
|
|
|
331 end End_Of_File;
|
|
|
332
|
|
|
333 -----------------
|
|
|
334 -- End_Of_Line --
|
|
|
335 -----------------
|
|
|
336
|
|
|
337 function End_Of_Line (File : File_Type) return Boolean is
|
|
|
338 ch : int;
|
|
|
339
|
|
|
340 begin
|
|
|
341 FIO.Check_Read_Status (AP (File));
|
|
|
342
|
|
|
343 if File.Before_Wide_Wide_Character then
|
|
|
344 return False;
|
|
|
345
|
|
|
346 elsif File.Before_LM then
|
|
|
347 return True;
|
|
|
348
|
|
|
349 else
|
|
|
350 ch := Getc (File);
|
|
|
351
|
|
|
352 if ch = EOF then
|
|
|
353 return True;
|
|
|
354
|
|
|
355 else
|
|
|
356 Ungetc (ch, File);
|
|
|
357 return (ch = LM);
|
|
|
358 end if;
|
|
|
359 end if;
|
|
|
360 end End_Of_Line;
|
|
|
361
|
|
|
362 function End_Of_Line return Boolean is
|
|
|
363 begin
|
|
|
364 return End_Of_Line (Current_In);
|
|
|
365 end End_Of_Line;
|
|
|
366
|
|
|
367 -----------------
|
|
|
368 -- End_Of_Page --
|
|
|
369 -----------------
|
|
|
370
|
|
|
371 function End_Of_Page (File : File_Type) return Boolean is
|
|
|
372 ch : int;
|
|
|
373
|
|
|
374 begin
|
|
|
375 FIO.Check_Read_Status (AP (File));
|
|
|
376
|
|
|
377 if not File.Is_Regular_File then
|
|
|
378 return False;
|
|
|
379
|
|
|
380 elsif File.Before_Wide_Wide_Character then
|
|
|
381 return False;
|
|
|
382
|
|
|
383 elsif File.Before_LM then
|
|
|
384 if File.Before_LM_PM then
|
|
|
385 return True;
|
|
|
386 end if;
|
|
|
387
|
|
|
388 else
|
|
|
389 ch := Getc (File);
|
|
|
390
|
|
|
391 if ch = EOF then
|
|
|
392 return True;
|
|
|
393
|
|
|
394 elsif ch /= LM then
|
|
|
395 Ungetc (ch, File);
|
|
|
396 return False;
|
|
|
397
|
|
|
398 else -- ch = LM
|
|
|
399 File.Before_LM := True;
|
|
|
400 end if;
|
|
|
401 end if;
|
|
|
402
|
|
|
403 -- Here we are just past the line mark with Before_LM set so that we
|
|
|
404 -- do not have to try to back up past the LM, thus avoiding the need
|
|
|
405 -- to back up more than one character.
|
|
|
406
|
|
|
407 ch := Nextc (File);
|
|
|
408
|
|
|
409 return ch = PM or else ch = EOF;
|
|
|
410 end End_Of_Page;
|
|
|
411
|
|
|
412 function End_Of_Page return Boolean is
|
|
|
413 begin
|
|
|
414 return End_Of_Page (Current_In);
|
|
|
415 end End_Of_Page;
|
|
|
416
|
|
|
417 -----------
|
|
|
418 -- Flush --
|
|
|
419 -----------
|
|
|
420
|
|
|
421 procedure Flush (File : File_Type) is
|
|
|
422 begin
|
|
|
423 FIO.Flush (AP (File));
|
|
|
424 end Flush;
|
|
|
425
|
|
|
426 procedure Flush is
|
|
|
427 begin
|
|
|
428 Flush (Current_Out);
|
|
|
429 end Flush;
|
|
|
430
|
|
|
431 ----------
|
|
|
432 -- Form --
|
|
|
433 ----------
|
|
|
434
|
|
|
435 function Form (File : File_Type) return String is
|
|
|
436 begin
|
|
|
437 return FIO.Form (AP (File));
|
|
|
438 end Form;
|
|
|
439
|
|
|
440 ---------
|
|
|
441 -- Get --
|
|
|
442 ---------
|
|
|
443
|
|
|
444 procedure Get
|
|
|
445 (File : File_Type;
|
|
|
446 Item : out Wide_Wide_Character)
|
|
|
447 is
|
|
|
448 C : Character;
|
|
|
449
|
|
|
450 begin
|
|
|
451 FIO.Check_Read_Status (AP (File));
|
|
|
452
|
|
|
453 if File.Before_Wide_Wide_Character then
|
|
|
454 File.Before_Wide_Wide_Character := False;
|
|
|
455 Item := File.Saved_Wide_Wide_Character;
|
|
|
456
|
|
|
457 -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same???
|
|
|
458
|
|
|
459 else
|
|
|
460 Get_Character (File, C);
|
|
|
461 Item := Get_Wide_Wide_Char (C, File);
|
|
|
462 end if;
|
|
|
463 end Get;
|
|
|
464
|
|
|
465 procedure Get (Item : out Wide_Wide_Character) is
|
|
|
466 begin
|
|
|
467 Get (Current_In, Item);
|
|
|
468 end Get;
|
|
|
469
|
|
|
470 procedure Get
|
|
|
471 (File : File_Type;
|
|
|
472 Item : out Wide_Wide_String)
|
|
|
473 is
|
|
|
474 begin
|
|
|
475 for J in Item'Range loop
|
|
|
476 Get (File, Item (J));
|
|
|
477 end loop;
|
|
|
478 end Get;
|
|
|
479
|
|
|
480 procedure Get (Item : out Wide_Wide_String) is
|
|
|
481 begin
|
|
|
482 Get (Current_In, Item);
|
|
|
483 end Get;
|
|
|
484
|
|
|
485 -------------------
|
|
|
486 -- Get_Character --
|
|
|
487 -------------------
|
|
|
488
|
|
|
489 procedure Get_Character
|
|
|
490 (File : File_Type;
|
|
|
491 Item : out Character)
|
|
|
492 is
|
|
|
493 ch : int;
|
|
|
494
|
|
|
495 begin
|
|
|
496 if File.Before_LM then
|
|
|
497 File.Before_LM := False;
|
|
|
498 File.Before_LM_PM := False;
|
|
|
499 File.Col := 1;
|
|
|
500
|
|
|
501 if File.Before_LM_PM then
|
|
|
502 File.Line := 1;
|
|
|
503 File.Page := File.Page + 1;
|
|
|
504 File.Before_LM_PM := False;
|
|
|
505
|
|
|
506 else
|
|
|
507 File.Line := File.Line + 1;
|
|
|
508 end if;
|
|
|
509 end if;
|
|
|
510
|
|
|
511 loop
|
|
|
512 ch := Getc (File);
|
|
|
513
|
|
|
514 if ch = EOF then
|
|
|
515 raise End_Error;
|
|
|
516
|
|
|
517 elsif ch = LM then
|
|
|
518 File.Line := File.Line + 1;
|
|
|
519 File.Col := 1;
|
|
|
520
|
|
|
521 elsif ch = PM and then File.Is_Regular_File then
|
|
|
522 File.Page := File.Page + 1;
|
|
|
523 File.Line := 1;
|
|
|
524
|
|
|
525 else
|
|
|
526 Item := Character'Val (ch);
|
|
|
527 File.Col := File.Col + 1;
|
|
|
528 return;
|
|
|
529 end if;
|
|
|
530 end loop;
|
|
|
531 end Get_Character;
|
|
|
532
|
|
|
533 -------------------
|
|
|
534 -- Get_Immediate --
|
|
|
535 -------------------
|
|
|
536
|
|
|
537 procedure Get_Immediate
|
|
|
538 (File : File_Type;
|
|
|
539 Item : out Wide_Wide_Character)
|
|
|
540 is
|
|
|
541 ch : int;
|
|
|
542
|
|
|
543 begin
|
|
|
544 FIO.Check_Read_Status (AP (File));
|
|
|
545
|
|
|
546 if File.Before_Wide_Wide_Character then
|
|
|
547 File.Before_Wide_Wide_Character := False;
|
|
|
548 Item := File.Saved_Wide_Wide_Character;
|
|
|
549
|
|
|
550 elsif File.Before_LM then
|
|
|
551 File.Before_LM := False;
|
|
|
552 File.Before_LM_PM := False;
|
|
|
553 Item := Wide_Wide_Character'Val (LM);
|
|
|
554
|
|
|
555 else
|
|
|
556 ch := Getc_Immed (File);
|
|
|
557
|
|
|
558 if ch = EOF then
|
|
|
559 raise End_Error;
|
|
|
560 else
|
|
|
561 Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File);
|
|
|
562 end if;
|
|
|
563 end if;
|
|
|
564 end Get_Immediate;
|
|
|
565
|
|
|
566 procedure Get_Immediate
|
|
|
567 (Item : out Wide_Wide_Character)
|
|
|
568 is
|
|
|
569 begin
|
|
|
570 Get_Immediate (Current_In, Item);
|
|
|
571 end Get_Immediate;
|
|
|
572
|
|
|
573 procedure Get_Immediate
|
|
|
574 (File : File_Type;
|
|
|
575 Item : out Wide_Wide_Character;
|
|
|
576 Available : out Boolean)
|
|
|
577 is
|
|
|
578 ch : int;
|
|
|
579
|
|
|
580 begin
|
|
|
581 FIO.Check_Read_Status (AP (File));
|
|
|
582 Available := True;
|
|
|
583
|
|
|
584 if File.Before_Wide_Wide_Character then
|
|
|
585 File.Before_Wide_Wide_Character := False;
|
|
|
586 Item := File.Saved_Wide_Wide_Character;
|
|
|
587
|
|
|
588 elsif File.Before_LM then
|
|
|
589 File.Before_LM := False;
|
|
|
590 File.Before_LM_PM := False;
|
|
|
591 Item := Wide_Wide_Character'Val (LM);
|
|
|
592
|
|
|
593 else
|
|
|
594 -- Shouldn't we use getc_immediate_nowait here, like Text_IO???
|
|
|
595
|
|
|
596 ch := Getc_Immed (File);
|
|
|
597
|
|
|
598 if ch = EOF then
|
|
|
599 raise End_Error;
|
|
|
600 else
|
|
|
601 Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File);
|
|
|
602 end if;
|
|
|
603 end if;
|
|
|
604 end Get_Immediate;
|
|
|
605
|
|
|
606 procedure Get_Immediate
|
|
|
607 (Item : out Wide_Wide_Character;
|
|
|
608 Available : out Boolean)
|
|
|
609 is
|
|
|
610 begin
|
|
|
611 Get_Immediate (Current_In, Item, Available);
|
|
|
612 end Get_Immediate;
|
|
|
613
|
|
|
614 --------------
|
|
|
615 -- Get_Line --
|
|
|
616 --------------
|
|
|
617
|
|
|
618 procedure Get_Line
|
|
|
619 (File : File_Type;
|
|
|
620 Item : out Wide_Wide_String;
|
|
|
621 Last : out Natural)
|
|
|
622 is
|
|
|
623 begin
|
|
|
624 FIO.Check_Read_Status (AP (File));
|
|
|
625 Last := Item'First - 1;
|
|
|
626
|
|
|
627 -- Immediate exit for null string, this is a case in which we do not
|
|
|
628 -- need to test for end of file and we do not skip a line mark under
|
|
|
629 -- any circumstances.
|
|
|
630
|
|
|
631 if Last >= Item'Last then
|
|
|
632 return;
|
|
|
633 end if;
|
|
|
634
|
|
|
635 -- Here we have at least one character, if we are immediately before
|
|
|
636 -- a line mark, then we will just skip past it storing no characters.
|
|
|
637
|
|
|
638 if File.Before_LM then
|
|
|
639 File.Before_LM := False;
|
|
|
640 File.Before_LM_PM := False;
|
|
|
641
|
|
|
642 -- Otherwise we need to read some characters
|
|
|
643
|
|
|
644 else
|
|
|
645 -- If we are at the end of file now, it means we are trying to
|
|
|
646 -- skip a file terminator and we raise End_Error (RM A.10.7(20))
|
|
|
647
|
|
|
648 if Nextc (File) = EOF then
|
|
|
649 raise End_Error;
|
|
|
650 end if;
|
|
|
651
|
|
|
652 -- Loop through characters in string
|
|
|
653
|
|
|
654 loop
|
|
|
655 -- Exit the loop if read is terminated by encountering line mark
|
|
|
656 -- Note that the use of Skip_Line here ensures we properly deal
|
|
|
657 -- with setting the page and line numbers.
|
|
|
658
|
|
|
659 if End_Of_Line (File) then
|
|
|
660 Skip_Line (File);
|
|
|
661 return;
|
|
|
662 end if;
|
|
|
663
|
|
|
664 -- Otherwise store the character, note that we know that ch is
|
|
|
665 -- something other than LM or EOF. It could possibly be a page
|
|
|
666 -- mark if there is a stray page mark in the middle of a line,
|
|
|
667 -- but this is not an official page mark in any case, since
|
|
|
668 -- official page marks can only follow a line mark. The whole
|
|
|
669 -- page business is pretty much nonsense anyway, so we do not
|
|
|
670 -- want to waste time trying to make sense out of non-standard
|
|
|
671 -- page marks in the file. This means that the behavior of
|
|
|
672 -- Get_Line is different from repeated Get of a character, but
|
|
|
673 -- that's too bad. We only promise that page numbers etc make
|
|
|
674 -- sense if the file is formatted in a standard manner.
|
|
|
675
|
|
|
676 -- Note: we do not adjust the column number because it is quicker
|
|
|
677 -- to adjust it once at the end of the operation than incrementing
|
|
|
678 -- it each time around the loop.
|
|
|
679
|
|
|
680 Last := Last + 1;
|
|
|
681 Get (File, Item (Last));
|
|
|
682
|
|
|
683 -- All done if the string is full, this is the case in which
|
|
|
684 -- we do not skip the following line mark. We need to adjust
|
|
|
685 -- the column number in this case.
|
|
|
686
|
|
|
687 if Last = Item'Last then
|
|
|
688 File.Col := File.Col + Count (Item'Length);
|
|
|
689 return;
|
|
|
690 end if;
|
|
|
691
|
|
|
692 -- Exit from the loop if we are at the end of file. This happens
|
|
|
693 -- if we have a last line that is not terminated with a line mark.
|
|
|
694 -- In this case we consider that there is an implied line mark;
|
|
|
695 -- this is a non-standard file, but we will treat it nicely.
|
|
|
696
|
|
|
697 exit when Nextc (File) = EOF;
|
|
|
698 end loop;
|
|
|
699 end if;
|
|
|
700 end Get_Line;
|
|
|
701
|
|
|
702 procedure Get_Line
|
|
|
703 (Item : out Wide_Wide_String;
|
|
|
704 Last : out Natural)
|
|
|
705 is
|
|
|
706 begin
|
|
|
707 Get_Line (Current_In, Item, Last);
|
|
|
708 end Get_Line;
|
|
|
709
|
|
|
710 function Get_Line (File : File_Type) return Wide_Wide_String is
|
|
|
711 Buffer : Wide_Wide_String (1 .. 500);
|
|
|
712 Last : Natural;
|
|
|
713
|
|
|
714 function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String;
|
|
|
715 -- This is a recursive function that reads the rest of the line and
|
|
|
716 -- returns it. S is the part read so far.
|
|
|
717
|
|
|
718 --------------
|
|
|
719 -- Get_Rest --
|
|
|
720 --------------
|
|
|
721
|
|
|
722 function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String is
|
|
|
723
|
|
|
724 -- Each time we allocate a buffer the same size as what we have
|
|
|
725 -- read so far. This limits us to a logarithmic number of calls
|
|
|
726 -- to Get_Rest and also ensures only a linear use of stack space.
|
|
|
727
|
|
|
728 Buffer : Wide_Wide_String (1 .. S'Length);
|
|
|
729 Last : Natural;
|
|
|
730
|
|
|
731 begin
|
|
|
732 Get_Line (File, Buffer, Last);
|
|
|
733
|
|
|
734 declare
|
|
|
735 R : constant Wide_Wide_String := S & Buffer (1 .. Last);
|
|
|
736 begin
|
|
|
737 if Last < Buffer'Last then
|
|
|
738 return R;
|
|
|
739 else
|
|
|
740 return Get_Rest (R);
|
|
|
741 end if;
|
|
|
742 end;
|
|
|
743 end Get_Rest;
|
|
|
744
|
|
|
745 -- Start of processing for Get_Line
|
|
|
746
|
|
|
747 begin
|
|
|
748 Get_Line (File, Buffer, Last);
|
|
|
749
|
|
|
750 if Last < Buffer'Last then
|
|
|
751 return Buffer (1 .. Last);
|
|
|
752 else
|
|
|
753 return Get_Rest (Buffer (1 .. Last));
|
|
|
754 end if;
|
|
|
755 end Get_Line;
|
|
|
756
|
|
|
757 function Get_Line return Wide_Wide_String is
|
|
|
758 begin
|
|
|
759 return Get_Line (Current_In);
|
|
|
760 end Get_Line;
|
|
|
761
|
|
|
762 ------------------------
|
|
|
763 -- Get_Wide_Wide_Char --
|
|
|
764 ------------------------
|
|
|
765
|
|
|
766 function Get_Wide_Wide_Char
|
|
|
767 (C : Character;
|
|
|
768 File : File_Type) return Wide_Wide_Character
|
|
|
769 is
|
|
|
770 function In_Char return Character;
|
|
|
771 -- Function used to obtain additional characters it the wide character
|
|
|
772 -- sequence is more than one character long.
|
|
|
773
|
|
|
774 function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
|
|
|
775
|
|
|
776 -------------
|
|
|
777 -- In_Char --
|
|
|
778 -------------
|
|
|
779
|
|
|
780 function In_Char return Character is
|
|
|
781 ch : constant Integer := Getc (File);
|
|
|
782 begin
|
|
|
783 if ch = EOF then
|
|
|
784 raise End_Error;
|
|
|
785 else
|
|
|
786 return Character'Val (ch);
|
|
|
787 end if;
|
|
|
788 end In_Char;
|
|
|
789
|
|
|
790 -- Start of processing for Get_Wide_Wide_Char
|
|
|
791
|
|
|
792 begin
|
|
|
793 FIO.Check_Read_Status (AP (File));
|
|
|
794 return Wide_Wide_Character'Val (WC_In (C, File.WC_Method));
|
|
|
795 end Get_Wide_Wide_Char;
|
|
|
796
|
|
|
797 ------------------------------
|
|
|
798 -- Get_Wide_Wide_Char_Immed --
|
|
|
799 ------------------------------
|
|
|
800
|
|
|
801 function Get_Wide_Wide_Char_Immed
|
|
|
802 (C : Character;
|
|
|
803 File : File_Type) return Wide_Wide_Character
|
|
|
804 is
|
|
|
805 function In_Char return Character;
|
|
|
806 -- Function used to obtain additional characters it the wide character
|
|
|
807 -- sequence is more than one character long.
|
|
|
808
|
|
|
809 function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
|
|
|
810
|
|
|
811 -------------
|
|
|
812 -- In_Char --
|
|
|
813 -------------
|
|
|
814
|
|
|
815 function In_Char return Character is
|
|
|
816 ch : constant Integer := Getc_Immed (File);
|
|
|
817 begin
|
|
|
818 if ch = EOF then
|
|
|
819 raise End_Error;
|
|
|
820 else
|
|
|
821 return Character'Val (ch);
|
|
|
822 end if;
|
|
|
823 end In_Char;
|
|
|
824
|
|
|
825 -- Start of processing for Get_Wide_Wide_Char_Immed
|
|
|
826
|
|
|
827 begin
|
|
|
828 FIO.Check_Read_Status (AP (File));
|
|
|
829 return Wide_Wide_Character'Val (WC_In (C, File.WC_Method));
|
|
|
830 end Get_Wide_Wide_Char_Immed;
|
|
|
831
|
|
|
832 ----------
|
|
|
833 -- Getc --
|
|
|
834 ----------
|
|
|
835
|
|
|
836 function Getc (File : File_Type) return int is
|
|
|
837 ch : int;
|
|
|
838
|
|
|
839 begin
|
|
|
840 ch := fgetc (File.Stream);
|
|
|
841
|
|
|
842 if ch = EOF and then ferror (File.Stream) /= 0 then
|
|
|
843 raise Device_Error;
|
|
|
844 else
|
|
|
845 return ch;
|
|
|
846 end if;
|
|
|
847 end Getc;
|
|
|
848
|
|
|
849 ----------------
|
|
|
850 -- Getc_Immed --
|
|
|
851 ----------------
|
|
|
852
|
|
|
853 function Getc_Immed (File : File_Type) return int is
|
|
|
854 ch : int;
|
|
|
855 end_of_file : int;
|
|
|
856
|
|
|
857 procedure getc_immediate
|
|
|
858 (stream : FILEs; ch : out int; end_of_file : out int);
|
|
|
859 pragma Import (C, getc_immediate, "getc_immediate");
|
|
|
860
|
|
|
861 begin
|
|
|
862 FIO.Check_Read_Status (AP (File));
|
|
|
863
|
|
|
864 if File.Before_LM then
|
|
|
865 File.Before_LM := False;
|
|
|
866 File.Before_LM_PM := False;
|
|
|
867 ch := LM;
|
|
|
868
|
|
|
869 else
|
|
|
870 getc_immediate (File.Stream, ch, end_of_file);
|
|
|
871
|
|
|
872 if ferror (File.Stream) /= 0 then
|
|
|
873 raise Device_Error;
|
|
|
874 elsif end_of_file /= 0 then
|
|
|
875 return EOF;
|
|
|
876 end if;
|
|
|
877 end if;
|
|
|
878
|
|
|
879 return ch;
|
|
|
880 end Getc_Immed;
|
|
|
881
|
|
|
882 -------------------------------
|
|
|
883 -- Initialize_Standard_Files --
|
|
|
884 -------------------------------
|
|
|
885
|
|
|
886 procedure Initialize_Standard_Files is
|
|
|
887 begin
|
|
|
888 Standard_Err.Stream := stderr;
|
|
|
889 Standard_Err.Name := Err_Name'Access;
|
|
|
890 Standard_Err.Form := Null_Str'Unrestricted_Access;
|
|
|
891 Standard_Err.Mode := FCB.Out_File;
|
|
|
892 Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0;
|
|
|
893 Standard_Err.Is_Temporary_File := False;
|
|
|
894 Standard_Err.Is_System_File := True;
|
|
|
895 Standard_Err.Text_Encoding := Default_Text;
|
|
|
896 Standard_Err.Access_Method := 'T';
|
|
|
897 Standard_Err.Self := Standard_Err;
|
|
|
898 Standard_Err.WC_Method := Default_WCEM;
|
|
|
899
|
|
|
900 Standard_In.Stream := stdin;
|
|
|
901 Standard_In.Name := In_Name'Access;
|
|
|
902 Standard_In.Form := Null_Str'Unrestricted_Access;
|
|
|
903 Standard_In.Mode := FCB.In_File;
|
|
|
904 Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0;
|
|
|
905 Standard_In.Is_Temporary_File := False;
|
|
|
906 Standard_In.Is_System_File := True;
|
|
|
907 Standard_In.Text_Encoding := Default_Text;
|
|
|
908 Standard_In.Access_Method := 'T';
|
|
|
909 Standard_In.Self := Standard_In;
|
|
|
910 Standard_In.WC_Method := Default_WCEM;
|
|
|
911
|
|
|
912 Standard_Out.Stream := stdout;
|
|
|
913 Standard_Out.Name := Out_Name'Access;
|
|
|
914 Standard_Out.Form := Null_Str'Unrestricted_Access;
|
|
|
915 Standard_Out.Mode := FCB.Out_File;
|
|
|
916 Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0;
|
|
|
917 Standard_Out.Is_Temporary_File := False;
|
|
|
918 Standard_Out.Is_System_File := True;
|
|
|
919 Standard_Out.Text_Encoding := Default_Text;
|
|
|
920 Standard_Out.Access_Method := 'T';
|
|
|
921 Standard_Out.Self := Standard_Out;
|
|
|
922 Standard_Out.WC_Method := Default_WCEM;
|
|
|
923
|
|
|
924 FIO.Make_Unbuffered (AP (Standard_Out));
|
|
|
925 FIO.Make_Unbuffered (AP (Standard_Err));
|
|
|
926 end Initialize_Standard_Files;
|
|
|
927
|
|
|
928 -------------
|
|
|
929 -- Is_Open --
|
|
|
930 -------------
|
|
|
931
|
|
|
932 function Is_Open (File : File_Type) return Boolean is
|
|
|
933 begin
|
|
|
934 return FIO.Is_Open (AP (File));
|
|
|
935 end Is_Open;
|
|
|
936
|
|
|
937 ----------
|
|
|
938 -- Line --
|
|
|
939 ----------
|
|
|
940
|
|
|
941 -- Note: we assume that it is impossible in practice for the line
|
|
|
942 -- to exceed the value of Count'Last, i.e. no check is required for
|
|
|
943 -- overflow raising layout error.
|
|
|
944
|
|
|
945 function Line (File : File_Type) return Positive_Count is
|
|
|
946 begin
|
|
|
947 FIO.Check_File_Open (AP (File));
|
|
|
948 return File.Line;
|
|
|
949 end Line;
|
|
|
950
|
|
|
951 function Line return Positive_Count is
|
|
|
952 begin
|
|
|
953 return Line (Current_Out);
|
|
|
954 end Line;
|
|
|
955
|
|
|
956 -----------------
|
|
|
957 -- Line_Length --
|
|
|
958 -----------------
|
|
|
959
|
|
|
960 function Line_Length (File : File_Type) return Count is
|
|
|
961 begin
|
|
|
962 FIO.Check_Write_Status (AP (File));
|
|
|
963 return File.Line_Length;
|
|
|
964 end Line_Length;
|
|
|
965
|
|
|
966 function Line_Length return Count is
|
|
|
967 begin
|
|
|
968 return Line_Length (Current_Out);
|
|
|
969 end Line_Length;
|
|
|
970
|
|
|
971 ----------------
|
|
|
972 -- Look_Ahead --
|
|
|
973 ----------------
|
|
|
974
|
|
|
975 procedure Look_Ahead
|
|
|
976 (File : File_Type;
|
|
|
977 Item : out Wide_Wide_Character;
|
|
|
978 End_Of_Line : out Boolean)
|
|
|
979 is
|
|
|
980 ch : int;
|
|
|
981
|
|
|
982 -- Start of processing for Look_Ahead
|
|
|
983
|
|
|
984 begin
|
|
|
985 FIO.Check_Read_Status (AP (File));
|
|
|
986
|
|
|
987 -- If we are logically before a line mark, we can return immediately
|
|
|
988
|
|
|
989 if File.Before_LM then
|
|
|
990 End_Of_Line := True;
|
|
|
991 Item := Wide_Wide_Character'Val (0);
|
|
|
992
|
|
|
993 -- If we are before a wide character, just return it (this can happen
|
|
|
994 -- if there are two calls to Look_Ahead in a row).
|
|
|
995
|
|
|
996 elsif File.Before_Wide_Wide_Character then
|
|
|
997 End_Of_Line := False;
|
|
|
998 Item := File.Saved_Wide_Wide_Character;
|
|
|
999
|
|
|
1000 -- otherwise we must read a character from the input stream
|
|
|
1001
|
|
|
1002 else
|
|
|
1003 ch := Getc (File);
|
|
|
1004
|
|
|
1005 if ch = LM
|
|
|
1006 or else ch = EOF
|
|
|
1007 or else (ch = EOF and then File.Is_Regular_File)
|
|
|
1008 then
|
|
|
1009 End_Of_Line := True;
|
|
|
1010 Ungetc (ch, File);
|
|
|
1011 Item := Wide_Wide_Character'Val (0);
|
|
|
1012
|
|
|
1013 -- Case where character obtained does not represent the start of an
|
|
|
1014 -- encoded sequence so it stands for itself and we can unget it with
|
|
|
1015 -- no difficulty.
|
|
|
1016
|
|
|
1017 elsif not Is_Start_Of_Encoding
|
|
|
1018 (Character'Val (ch), File.WC_Method)
|
|
|
1019 then
|
|
|
1020 End_Of_Line := False;
|
|
|
1021 Ungetc (ch, File);
|
|
|
1022 Item := Wide_Wide_Character'Val (ch);
|
|
|
1023
|
|
|
1024 -- For the start of an encoding, we read the character using the
|
|
|
1025 -- Get_Wide_Wide_Char routine. It will occupy more than one byte so
|
|
|
1026 -- we can't put it back with ungetc. Instead we save it in the
|
|
|
1027 -- control block, setting a flag that everyone interested in reading
|
|
|
1028 -- characters must test before reading the stream.
|
|
|
1029
|
|
|
1030 else
|
|
|
1031 Item := Get_Wide_Wide_Char (Character'Val (ch), File);
|
|
|
1032 End_Of_Line := False;
|
|
|
1033 File.Saved_Wide_Wide_Character := Item;
|
|
|
1034 File.Before_Wide_Wide_Character := True;
|
|
|
1035 end if;
|
|
|
1036 end if;
|
|
|
1037 end Look_Ahead;
|
|
|
1038
|
|
|
1039 procedure Look_Ahead
|
|
|
1040 (Item : out Wide_Wide_Character;
|
|
|
1041 End_Of_Line : out Boolean)
|
|
|
1042 is
|
|
|
1043 begin
|
|
|
1044 Look_Ahead (Current_In, Item, End_Of_Line);
|
|
|
1045 end Look_Ahead;
|
|
|
1046
|
|
|
1047 ----------
|
|
|
1048 -- Mode --
|
|
|
1049 ----------
|
|
|
1050
|
|
|
1051 function Mode (File : File_Type) return File_Mode is
|
|
|
1052 begin
|
|
|
1053 return To_TIO (FIO.Mode (AP (File)));
|
|
|
1054 end Mode;
|
|
|
1055
|
|
|
1056 ----------
|
|
|
1057 -- Name --
|
|
|
1058 ----------
|
|
|
1059
|
|
|
1060 function Name (File : File_Type) return String is
|
|
|
1061 begin
|
|
|
1062 return FIO.Name (AP (File));
|
|
|
1063 end Name;
|
|
|
1064
|
|
|
1065 --------------
|
|
|
1066 -- New_Line --
|
|
|
1067 --------------
|
|
|
1068
|
|
|
1069 procedure New_Line
|
|
|
1070 (File : File_Type;
|
|
|
1071 Spacing : Positive_Count := 1)
|
|
|
1072 is
|
|
|
1073 begin
|
|
|
1074 -- Raise Constraint_Error if out of range value. The reason for this
|
|
|
1075 -- explicit test is that we don't want junk values around, even if
|
|
|
1076 -- checks are off in the caller.
|
|
|
1077
|
|
|
1078 if not Spacing'Valid then
|
|
|
1079 raise Constraint_Error;
|
|
|
1080 end if;
|
|
|
1081
|
|
|
1082 FIO.Check_Write_Status (AP (File));
|
|
|
1083
|
|
|
1084 for K in 1 .. Spacing loop
|
|
|
1085 Putc (LM, File);
|
|
|
1086 File.Line := File.Line + 1;
|
|
|
1087
|
|
|
1088 if File.Page_Length /= 0
|
|
|
1089 and then File.Line > File.Page_Length
|
|
|
1090 then
|
|
|
1091 Putc (PM, File);
|
|
|
1092 File.Line := 1;
|
|
|
1093 File.Page := File.Page + 1;
|
|
|
1094 end if;
|
|
|
1095 end loop;
|
|
|
1096
|
|
|
1097 File.Col := 1;
|
|
|
1098 end New_Line;
|
|
|
1099
|
|
|
1100 procedure New_Line (Spacing : Positive_Count := 1) is
|
|
|
1101 begin
|
|
|
1102 New_Line (Current_Out, Spacing);
|
|
|
1103 end New_Line;
|
|
|
1104
|
|
|
1105 --------------
|
|
|
1106 -- New_Page --
|
|
|
1107 --------------
|
|
|
1108
|
|
|
1109 procedure New_Page (File : File_Type) is
|
|
|
1110 begin
|
|
|
1111 FIO.Check_Write_Status (AP (File));
|
|
|
1112
|
|
|
1113 if File.Col /= 1 or else File.Line = 1 then
|
|
|
1114 Putc (LM, File);
|
|
|
1115 end if;
|
|
|
1116
|
|
|
1117 Putc (PM, File);
|
|
|
1118 File.Page := File.Page + 1;
|
|
|
1119 File.Line := 1;
|
|
|
1120 File.Col := 1;
|
|
|
1121 end New_Page;
|
|
|
1122
|
|
|
1123 procedure New_Page is
|
|
|
1124 begin
|
|
|
1125 New_Page (Current_Out);
|
|
|
1126 end New_Page;
|
|
|
1127
|
|
|
1128 -----------
|
|
|
1129 -- Nextc --
|
|
|
1130 -----------
|
|
|
1131
|
|
|
1132 function Nextc (File : File_Type) return int is
|
|
|
1133 ch : int;
|
|
|
1134
|
|
|
1135 begin
|
|
|
1136 ch := fgetc (File.Stream);
|
|
|
1137
|
|
|
1138 if ch = EOF then
|
|
|
1139 if ferror (File.Stream) /= 0 then
|
|
|
1140 raise Device_Error;
|
|
|
1141 end if;
|
|
|
1142
|
|
|
1143 else
|
|
|
1144 if ungetc (ch, File.Stream) = EOF then
|
|
|
1145 raise Device_Error;
|
|
|
1146 end if;
|
|
|
1147 end if;
|
|
|
1148
|
|
|
1149 return ch;
|
|
|
1150 end Nextc;
|
|
|
1151
|
|
|
1152 ----------
|
|
|
1153 -- Open --
|
|
|
1154 ----------
|
|
|
1155
|
|
|
1156 procedure Open
|
|
|
1157 (File : in out File_Type;
|
|
|
1158 Mode : File_Mode;
|
|
|
1159 Name : String;
|
|
|
1160 Form : String := "")
|
|
|
1161 is
|
|
|
1162 Dummy_File_Control_Block : Wide_Wide_Text_AFCB;
|
|
|
1163 pragma Warnings (Off, Dummy_File_Control_Block);
|
|
|
1164 -- Yes, we know this is never assigned a value, only the tag
|
|
|
1165 -- is used for dispatching purposes, so that's expected.
|
|
|
1166
|
|
|
1167 begin
|
|
|
1168 FIO.Open (File_Ptr => AP (File),
|
|
|
1169 Dummy_FCB => Dummy_File_Control_Block,
|
|
|
1170 Mode => To_FCB (Mode),
|
|
|
1171 Name => Name,
|
|
|
1172 Form => Form,
|
|
|
1173 Amethod => 'W',
|
|
|
1174 Creat => False,
|
|
|
1175 Text => True);
|
|
|
1176
|
|
|
1177 File.Self := File;
|
|
|
1178 Set_WCEM (File);
|
|
|
1179 end Open;
|
|
|
1180
|
|
|
1181 ----------
|
|
|
1182 -- Page --
|
|
|
1183 ----------
|
|
|
1184
|
|
|
1185 -- Note: we assume that it is impossible in practice for the page
|
|
|
1186 -- to exceed the value of Count'Last, i.e. no check is required for
|
|
|
1187 -- overflow raising layout error.
|
|
|
1188
|
|
|
1189 function Page (File : File_Type) return Positive_Count is
|
|
|
1190 begin
|
|
|
1191 FIO.Check_File_Open (AP (File));
|
|
|
1192 return File.Page;
|
|
|
1193 end Page;
|
|
|
1194
|
|
|
1195 function Page return Positive_Count is
|
|
|
1196 begin
|
|
|
1197 return Page (Current_Out);
|
|
|
1198 end Page;
|
|
|
1199
|
|
|
1200 -----------------
|
|
|
1201 -- Page_Length --
|
|
|
1202 -----------------
|
|
|
1203
|
|
|
1204 function Page_Length (File : File_Type) return Count is
|
|
|
1205 begin
|
|
|
1206 FIO.Check_Write_Status (AP (File));
|
|
|
1207 return File.Page_Length;
|
|
|
1208 end Page_Length;
|
|
|
1209
|
|
|
1210 function Page_Length return Count is
|
|
|
1211 begin
|
|
|
1212 return Page_Length (Current_Out);
|
|
|
1213 end Page_Length;
|
|
|
1214
|
|
|
1215 ---------
|
|
|
1216 -- Put --
|
|
|
1217 ---------
|
|
|
1218
|
|
|
1219 procedure Put
|
|
|
1220 (File : File_Type;
|
|
|
1221 Item : Wide_Wide_Character)
|
|
|
1222 is
|
|
|
1223 procedure Out_Char (C : Character);
|
|
|
1224 -- Procedure to output one character of a wide character sequence
|
|
|
1225
|
|
|
1226 procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char);
|
|
|
1227
|
|
|
1228 --------------
|
|
|
1229 -- Out_Char --
|
|
|
1230 --------------
|
|
|
1231
|
|
|
1232 procedure Out_Char (C : Character) is
|
|
|
1233 begin
|
|
|
1234 Putc (Character'Pos (C), File);
|
|
|
1235 end Out_Char;
|
|
|
1236
|
|
|
1237 -- Start of processing for Put
|
|
|
1238
|
|
|
1239 begin
|
|
|
1240 FIO.Check_Write_Status (AP (File));
|
|
|
1241 WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method);
|
|
|
1242 File.Col := File.Col + 1;
|
|
|
1243 end Put;
|
|
|
1244
|
|
|
1245 procedure Put (Item : Wide_Wide_Character) is
|
|
|
1246 begin
|
|
|
1247 Put (Current_Out, Item);
|
|
|
1248 end Put;
|
|
|
1249
|
|
|
1250 ---------
|
|
|
1251 -- Put --
|
|
|
1252 ---------
|
|
|
1253
|
|
|
1254 procedure Put
|
|
|
1255 (File : File_Type;
|
|
|
1256 Item : Wide_Wide_String)
|
|
|
1257 is
|
|
|
1258 begin
|
|
|
1259 for J in Item'Range loop
|
|
|
1260 Put (File, Item (J));
|
|
|
1261 end loop;
|
|
|
1262 end Put;
|
|
|
1263
|
|
|
1264 procedure Put (Item : Wide_Wide_String) is
|
|
|
1265 begin
|
|
|
1266 Put (Current_Out, Item);
|
|
|
1267 end Put;
|
|
|
1268
|
|
|
1269 --------------
|
|
|
1270 -- Put_Line --
|
|
|
1271 --------------
|
|
|
1272
|
|
|
1273 procedure Put_Line
|
|
|
1274 (File : File_Type;
|
|
|
1275 Item : Wide_Wide_String)
|
|
|
1276 is
|
|
|
1277 begin
|
|
|
1278 Put (File, Item);
|
|
|
1279 New_Line (File);
|
|
|
1280 end Put_Line;
|
|
|
1281
|
|
|
1282 procedure Put_Line (Item : Wide_Wide_String) is
|
|
|
1283 begin
|
|
|
1284 Put (Current_Out, Item);
|
|
|
1285 New_Line (Current_Out);
|
|
|
1286 end Put_Line;
|
|
|
1287
|
|
|
1288 ----------
|
|
|
1289 -- Putc --
|
|
|
1290 ----------
|
|
|
1291
|
|
|
1292 procedure Putc (ch : int; File : File_Type) is
|
|
|
1293 begin
|
|
|
1294 if fputc (ch, File.Stream) = EOF then
|
|
|
1295 raise Device_Error;
|
|
|
1296 end if;
|
|
|
1297 end Putc;
|
|
|
1298
|
|
|
1299 ----------
|
|
|
1300 -- Read --
|
|
|
1301 ----------
|
|
|
1302
|
|
|
1303 -- This is the primitive Stream Read routine, used when a Text_IO file
|
|
|
1304 -- is treated directly as a stream using Text_IO.Streams.Stream.
|
|
|
1305
|
|
|
1306 procedure Read
|
|
|
1307 (File : in out Wide_Wide_Text_AFCB;
|
|
|
1308 Item : out Stream_Element_Array;
|
|
|
1309 Last : out Stream_Element_Offset)
|
|
|
1310 is
|
|
|
1311 Discard_ch : int;
|
|
|
1312 pragma Unreferenced (Discard_ch);
|
|
|
1313
|
|
|
1314 begin
|
|
|
1315 -- Need to deal with Before_Wide_Wide_Character ???
|
|
|
1316
|
|
|
1317 if File.Mode /= FCB.In_File then
|
|
|
1318 raise Mode_Error;
|
|
|
1319 end if;
|
|
|
1320
|
|
|
1321 -- Deal with case where our logical and physical position do not match
|
|
|
1322 -- because of being after an LM or LM-PM sequence when in fact we are
|
|
|
1323 -- logically positioned before it.
|
|
|
1324
|
|
|
1325 if File.Before_LM then
|
|
|
1326
|
|
|
1327 -- If we are before a PM, then it is possible for a stream read
|
|
|
1328 -- to leave us after the LM and before the PM, which is a bit
|
|
|
1329 -- odd. The easiest way to deal with this is to unget the PM,
|
|
|
1330 -- so we are indeed positioned between the characters. This way
|
|
|
1331 -- further stream read operations will work correctly, and the
|
|
|
1332 -- effect on text processing is a little weird, but what can
|
|
|
1333 -- be expected if stream and text input are mixed this way?
|
|
|
1334
|
|
|
1335 if File.Before_LM_PM then
|
|
|
1336 Discard_ch := ungetc (PM, File.Stream);
|
|
|
1337 File.Before_LM_PM := False;
|
|
|
1338 end if;
|
|
|
1339
|
|
|
1340 File.Before_LM := False;
|
|
|
1341
|
|
|
1342 Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
|
|
|
1343
|
|
|
1344 if Item'Length = 1 then
|
|
|
1345 Last := Item'Last;
|
|
|
1346
|
|
|
1347 else
|
|
|
1348 Last :=
|
|
|
1349 Item'First +
|
|
|
1350 Stream_Element_Offset
|
|
|
1351 (fread (buffer => Item'Address,
|
|
|
1352 index => size_t (Item'First + 1),
|
|
|
1353 size => 1,
|
|
|
1354 count => Item'Length - 1,
|
|
|
1355 stream => File.Stream));
|
|
|
1356 end if;
|
|
|
1357
|
|
|
1358 return;
|
|
|
1359 end if;
|
|
|
1360
|
|
|
1361 -- Now we do the read. Since this is a text file, it is normally in
|
|
|
1362 -- text mode, but stream data must be read in binary mode, so we
|
|
|
1363 -- temporarily set binary mode for the read, resetting it after.
|
|
|
1364 -- These calls have no effect in a system (like Unix) where there is
|
|
|
1365 -- no distinction between text and binary files.
|
|
|
1366
|
|
|
1367 set_binary_mode (fileno (File.Stream));
|
|
|
1368
|
|
|
1369 Last :=
|
|
|
1370 Item'First +
|
|
|
1371 Stream_Element_Offset
|
|
|
1372 (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
|
|
|
1373
|
|
|
1374 if Last < Item'Last then
|
|
|
1375 if ferror (File.Stream) /= 0 then
|
|
|
1376 raise Device_Error;
|
|
|
1377 end if;
|
|
|
1378 end if;
|
|
|
1379
|
|
|
1380 set_text_mode (fileno (File.Stream));
|
|
|
1381 end Read;
|
|
|
1382
|
|
|
1383 -----------
|
|
|
1384 -- Reset --
|
|
|
1385 -----------
|
|
|
1386
|
|
|
1387 procedure Reset
|
|
|
1388 (File : in out File_Type;
|
|
|
1389 Mode : File_Mode)
|
|
|
1390 is
|
|
|
1391 begin
|
|
|
1392 -- Don't allow change of mode for current file (RM A.10.2(5))
|
|
|
1393
|
|
|
1394 if (File = Current_In or else
|
|
|
1395 File = Current_Out or else
|
|
|
1396 File = Current_Error)
|
|
|
1397 and then To_FCB (Mode) /= File.Mode
|
|
|
1398 then
|
|
|
1399 raise Mode_Error;
|
|
|
1400 end if;
|
|
|
1401
|
|
|
1402 Terminate_Line (File);
|
|
|
1403 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode));
|
|
|
1404 File.Page := 1;
|
|
|
1405 File.Line := 1;
|
|
|
1406 File.Col := 1;
|
|
|
1407 File.Line_Length := 0;
|
|
|
1408 File.Page_Length := 0;
|
|
|
1409 File.Before_LM := False;
|
|
|
1410 File.Before_LM_PM := False;
|
|
|
1411 end Reset;
|
|
|
1412
|
|
|
1413 procedure Reset (File : in out File_Type) is
|
|
|
1414 begin
|
|
|
1415 Terminate_Line (File);
|
|
|
1416 FIO.Reset (AP (File)'Unrestricted_Access);
|
|
|
1417 File.Page := 1;
|
|
|
1418 File.Line := 1;
|
|
|
1419 File.Col := 1;
|
|
|
1420 File.Line_Length := 0;
|
|
|
1421 File.Page_Length := 0;
|
|
|
1422 File.Before_LM := False;
|
|
|
1423 File.Before_LM_PM := False;
|
|
|
1424 end Reset;
|
|
|
1425
|
|
|
1426 -------------
|
|
|
1427 -- Set_Col --
|
|
|
1428 -------------
|
|
|
1429
|
|
|
1430 procedure Set_Col
|
|
|
1431 (File : File_Type;
|
|
|
1432 To : Positive_Count)
|
|
|
1433 is
|
|
|
1434 ch : int;
|
|
|
1435
|
|
|
1436 begin
|
|
|
1437 -- Raise Constraint_Error if out of range value. The reason for this
|
|
|
1438 -- explicit test is that we don't want junk values around, even if
|
|
|
1439 -- checks are off in the caller.
|
|
|
1440
|
|
|
1441 if not To'Valid then
|
|
|
1442 raise Constraint_Error;
|
|
|
1443 end if;
|
|
|
1444
|
|
|
1445 FIO.Check_File_Open (AP (File));
|
|
|
1446
|
|
|
1447 if To = File.Col then
|
|
|
1448 return;
|
|
|
1449 end if;
|
|
|
1450
|
|
|
1451 if Mode (File) >= Out_File then
|
|
|
1452 if File.Line_Length /= 0 and then To > File.Line_Length then
|
|
|
1453 raise Layout_Error;
|
|
|
1454 end if;
|
|
|
1455
|
|
|
1456 if To < File.Col then
|
|
|
1457 New_Line (File);
|
|
|
1458 end if;
|
|
|
1459
|
|
|
1460 while File.Col < To loop
|
|
|
1461 Put (File, ' ');
|
|
|
1462 end loop;
|
|
|
1463
|
|
|
1464 else
|
|
|
1465 loop
|
|
|
1466 ch := Getc (File);
|
|
|
1467
|
|
|
1468 if ch = EOF then
|
|
|
1469 raise End_Error;
|
|
|
1470
|
|
|
1471 elsif ch = LM then
|
|
|
1472 File.Line := File.Line + 1;
|
|
|
1473 File.Col := 1;
|
|
|
1474
|
|
|
1475 elsif ch = PM and then File.Is_Regular_File then
|
|
|
1476 File.Page := File.Page + 1;
|
|
|
1477 File.Line := 1;
|
|
|
1478 File.Col := 1;
|
|
|
1479
|
|
|
1480 elsif To = File.Col then
|
|
|
1481 Ungetc (ch, File);
|
|
|
1482 return;
|
|
|
1483
|
|
|
1484 else
|
|
|
1485 File.Col := File.Col + 1;
|
|
|
1486 end if;
|
|
|
1487 end loop;
|
|
|
1488 end if;
|
|
|
1489 end Set_Col;
|
|
|
1490
|
|
|
1491 procedure Set_Col (To : Positive_Count) is
|
|
|
1492 begin
|
|
|
1493 Set_Col (Current_Out, To);
|
|
|
1494 end Set_Col;
|
|
|
1495
|
|
|
1496 ---------------
|
|
|
1497 -- Set_Error --
|
|
|
1498 ---------------
|
|
|
1499
|
|
|
1500 procedure Set_Error (File : File_Type) is
|
|
|
1501 begin
|
|
|
1502 FIO.Check_Write_Status (AP (File));
|
|
|
1503 Current_Err := File;
|
|
|
1504 end Set_Error;
|
|
|
1505
|
|
|
1506 ---------------
|
|
|
1507 -- Set_Input --
|
|
|
1508 ---------------
|
|
|
1509
|
|
|
1510 procedure Set_Input (File : File_Type) is
|
|
|
1511 begin
|
|
|
1512 FIO.Check_Read_Status (AP (File));
|
|
|
1513 Current_In := File;
|
|
|
1514 end Set_Input;
|
|
|
1515
|
|
|
1516 --------------
|
|
|
1517 -- Set_Line --
|
|
|
1518 --------------
|
|
|
1519
|
|
|
1520 procedure Set_Line
|
|
|
1521 (File : File_Type;
|
|
|
1522 To : Positive_Count)
|
|
|
1523 is
|
|
|
1524 begin
|
|
|
1525 -- Raise Constraint_Error if out of range value. The reason for this
|
|
|
1526 -- explicit test is that we don't want junk values around, even if
|
|
|
1527 -- checks are off in the caller.
|
|
|
1528
|
|
|
1529 if not To'Valid then
|
|
|
1530 raise Constraint_Error;
|
|
|
1531 end if;
|
|
|
1532
|
|
|
1533 FIO.Check_File_Open (AP (File));
|
|
|
1534
|
|
|
1535 if To = File.Line then
|
|
|
1536 return;
|
|
|
1537 end if;
|
|
|
1538
|
|
|
1539 if Mode (File) >= Out_File then
|
|
|
1540 if File.Page_Length /= 0 and then To > File.Page_Length then
|
|
|
1541 raise Layout_Error;
|
|
|
1542 end if;
|
|
|
1543
|
|
|
1544 if To < File.Line then
|
|
|
1545 New_Page (File);
|
|
|
1546 end if;
|
|
|
1547
|
|
|
1548 while File.Line < To loop
|
|
|
1549 New_Line (File);
|
|
|
1550 end loop;
|
|
|
1551
|
|
|
1552 else
|
|
|
1553 while To /= File.Line loop
|
|
|
1554 Skip_Line (File);
|
|
|
1555 end loop;
|
|
|
1556 end if;
|
|
|
1557 end Set_Line;
|
|
|
1558
|
|
|
1559 procedure Set_Line (To : Positive_Count) is
|
|
|
1560 begin
|
|
|
1561 Set_Line (Current_Out, To);
|
|
|
1562 end Set_Line;
|
|
|
1563
|
|
|
1564 ---------------------
|
|
|
1565 -- Set_Line_Length --
|
|
|
1566 ---------------------
|
|
|
1567
|
|
|
1568 procedure Set_Line_Length (File : File_Type; To : Count) is
|
|
|
1569 begin
|
|
|
1570 -- Raise Constraint_Error if out of range value. The reason for this
|
|
|
1571 -- explicit test is that we don't want junk values around, even if
|
|
|
1572 -- checks are off in the caller.
|
|
|
1573
|
|
|
1574 if not To'Valid then
|
|
|
1575 raise Constraint_Error;
|
|
|
1576 end if;
|
|
|
1577
|
|
|
1578 FIO.Check_Write_Status (AP (File));
|
|
|
1579 File.Line_Length := To;
|
|
|
1580 end Set_Line_Length;
|
|
|
1581
|
|
|
1582 procedure Set_Line_Length (To : Count) is
|
|
|
1583 begin
|
|
|
1584 Set_Line_Length (Current_Out, To);
|
|
|
1585 end Set_Line_Length;
|
|
|
1586
|
|
|
1587 ----------------
|
|
|
1588 -- Set_Output --
|
|
|
1589 ----------------
|
|
|
1590
|
|
|
1591 procedure Set_Output (File : File_Type) is
|
|
|
1592 begin
|
|
|
1593 FIO.Check_Write_Status (AP (File));
|
|
|
1594 Current_Out := File;
|
|
|
1595 end Set_Output;
|
|
|
1596
|
|
|
1597 ---------------------
|
|
|
1598 -- Set_Page_Length --
|
|
|
1599 ---------------------
|
|
|
1600
|
|
|
1601 procedure Set_Page_Length (File : File_Type; To : Count) is
|
|
|
1602 begin
|
|
|
1603 -- Raise Constraint_Error if out of range value. The reason for this
|
|
|
1604 -- explicit test is that we don't want junk values around, even if
|
|
|
1605 -- checks are off in the caller.
|
|
|
1606
|
|
|
1607 if not To'Valid then
|
|
|
1608 raise Constraint_Error;
|
|
|
1609 end if;
|
|
|
1610
|
|
|
1611 FIO.Check_Write_Status (AP (File));
|
|
|
1612 File.Page_Length := To;
|
|
|
1613 end Set_Page_Length;
|
|
|
1614
|
|
|
1615 procedure Set_Page_Length (To : Count) is
|
|
|
1616 begin
|
|
|
1617 Set_Page_Length (Current_Out, To);
|
|
|
1618 end Set_Page_Length;
|
|
|
1619
|
|
|
1620 --------------
|
|
|
1621 -- Set_WCEM --
|
|
|
1622 --------------
|
|
|
1623
|
|
|
1624 procedure Set_WCEM (File : in out File_Type) is
|
|
|
1625 Start : Natural;
|
|
|
1626 Stop : Natural;
|
|
|
1627
|
|
|
1628 begin
|
|
|
1629 FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
|
|
|
1630
|
|
|
1631 if Start = 0 then
|
|
|
1632 File.WC_Method := Default_WCEM;
|
|
|
1633
|
|
|
1634 else
|
|
|
1635 if Stop = Start then
|
|
|
1636 for J in WC_Encoding_Letters'Range loop
|
|
|
1637 if File.Form (Start) = WC_Encoding_Letters (J) then
|
|
|
1638 File.WC_Method := J;
|
|
|
1639 return;
|
|
|
1640 end if;
|
|
|
1641 end loop;
|
|
|
1642 end if;
|
|
|
1643
|
|
|
1644 Close (File);
|
|
|
1645 raise Use_Error with "invalid WCEM form parameter";
|
|
|
1646 end if;
|
|
|
1647 end Set_WCEM;
|
|
|
1648
|
|
|
1649 ---------------
|
|
|
1650 -- Skip_Line --
|
|
|
1651 ---------------
|
|
|
1652
|
|
|
1653 procedure Skip_Line
|
|
|
1654 (File : File_Type;
|
|
|
1655 Spacing : Positive_Count := 1)
|
|
|
1656 is
|
|
|
1657 ch : int;
|
|
|
1658
|
|
|
1659 begin
|
|
|
1660 -- Raise Constraint_Error if out of range value. The reason for this
|
|
|
1661 -- explicit test is that we don't want junk values around, even if
|
|
|
1662 -- checks are off in the caller.
|
|
|
1663
|
|
|
1664 if not Spacing'Valid then
|
|
|
1665 raise Constraint_Error;
|
|
|
1666 end if;
|
|
|
1667
|
|
|
1668 FIO.Check_Read_Status (AP (File));
|
|
|
1669
|
|
|
1670 for L in 1 .. Spacing loop
|
|
|
1671 if File.Before_LM then
|
|
|
1672 File.Before_LM := False;
|
|
|
1673 File.Before_LM_PM := False;
|
|
|
1674
|
|
|
1675 else
|
|
|
1676 ch := Getc (File);
|
|
|
1677
|
|
|
1678 -- If at end of file now, then immediately raise End_Error. Note
|
|
|
1679 -- that we can never be positioned between a line mark and a page
|
|
|
1680 -- mark, so if we are at the end of file, we cannot logically be
|
|
|
1681 -- before the implicit page mark that is at the end of the file.
|
|
|
1682
|
|
|
1683 -- For the same reason, we do not need an explicit check for a
|
|
|
1684 -- page mark. If there is a FF in the middle of a line, the file
|
|
|
1685 -- is not in canonical format and we do not care about the page
|
|
|
1686 -- numbers for files other than ones in canonical format.
|
|
|
1687
|
|
|
1688 if ch = EOF then
|
|
|
1689 raise End_Error;
|
|
|
1690 end if;
|
|
|
1691
|
|
|
1692 -- If not at end of file, then loop till we get to an LM or EOF.
|
|
|
1693 -- The latter case happens only in non-canonical files where the
|
|
|
1694 -- last line is not terminated by LM, but we don't want to blow
|
|
|
1695 -- up for such files, so we assume an implicit LM in this case.
|
|
|
1696
|
|
|
1697 loop
|
|
|
1698 exit when ch = LM or else ch = EOF;
|
|
|
1699 ch := Getc (File);
|
|
|
1700 end loop;
|
|
|
1701 end if;
|
|
|
1702
|
|
|
1703 -- We have got past a line mark, now, for a regular file only,
|
|
|
1704 -- see if a page mark immediately follows this line mark and
|
|
|
1705 -- if so, skip past the page mark as well. We do not do this
|
|
|
1706 -- for non-regular files, since it would cause an undesirable
|
|
|
1707 -- wait for an additional character.
|
|
|
1708
|
|
|
1709 File.Col := 1;
|
|
|
1710 File.Line := File.Line + 1;
|
|
|
1711
|
|
|
1712 if File.Before_LM_PM then
|
|
|
1713 File.Page := File.Page + 1;
|
|
|
1714 File.Line := 1;
|
|
|
1715 File.Before_LM_PM := False;
|
|
|
1716
|
|
|
1717 elsif File.Is_Regular_File then
|
|
|
1718 ch := Getc (File);
|
|
|
1719
|
|
|
1720 -- Page mark can be explicit, or implied at the end of the file
|
|
|
1721
|
|
|
1722 if (ch = PM or else ch = EOF)
|
|
|
1723 and then File.Is_Regular_File
|
|
|
1724 then
|
|
|
1725 File.Page := File.Page + 1;
|
|
|
1726 File.Line := 1;
|
|
|
1727 else
|
|
|
1728 Ungetc (ch, File);
|
|
|
1729 end if;
|
|
|
1730 end if;
|
|
|
1731 end loop;
|
|
|
1732
|
|
|
1733 File.Before_Wide_Wide_Character := False;
|
|
|
1734 end Skip_Line;
|
|
|
1735
|
|
|
1736 procedure Skip_Line (Spacing : Positive_Count := 1) is
|
|
|
1737 begin
|
|
|
1738 Skip_Line (Current_In, Spacing);
|
|
|
1739 end Skip_Line;
|
|
|
1740
|
|
|
1741 ---------------
|
|
|
1742 -- Skip_Page --
|
|
|
1743 ---------------
|
|
|
1744
|
|
|
1745 procedure Skip_Page (File : File_Type) is
|
|
|
1746 ch : int;
|
|
|
1747
|
|
|
1748 begin
|
|
|
1749 FIO.Check_Read_Status (AP (File));
|
|
|
1750
|
|
|
1751 -- If at page mark already, just skip it
|
|
|
1752
|
|
|
1753 if File.Before_LM_PM then
|
|
|
1754 File.Before_LM := False;
|
|
|
1755 File.Before_LM_PM := False;
|
|
|
1756 File.Page := File.Page + 1;
|
|
|
1757 File.Line := 1;
|
|
|
1758 File.Col := 1;
|
|
|
1759 return;
|
|
|
1760 end if;
|
|
|
1761
|
|
|
1762 -- This is a bit tricky, if we are logically before an LM then
|
|
|
1763 -- it is not an error if we are at an end of file now, since we
|
|
|
1764 -- are not really at it.
|
|
|
1765
|
|
|
1766 if File.Before_LM then
|
|
|
1767 File.Before_LM := False;
|
|
|
1768 File.Before_LM_PM := False;
|
|
|
1769 ch := Getc (File);
|
|
|
1770
|
|
|
1771 -- Otherwise we do raise End_Error if we are at the end of file now
|
|
|
1772
|
|
|
1773 else
|
|
|
1774 ch := Getc (File);
|
|
|
1775
|
|
|
1776 if ch = EOF then
|
|
|
1777 raise End_Error;
|
|
|
1778 end if;
|
|
|
1779 end if;
|
|
|
1780
|
|
|
1781 -- Now we can just rumble along to the next page mark, or to the
|
|
|
1782 -- end of file, if that comes first. The latter case happens when
|
|
|
1783 -- the page mark is implied at the end of file.
|
|
|
1784
|
|
|
1785 loop
|
|
|
1786 exit when ch = EOF
|
|
|
1787 or else (ch = PM and then File.Is_Regular_File);
|
|
|
1788 ch := Getc (File);
|
|
|
1789 end loop;
|
|
|
1790
|
|
|
1791 File.Page := File.Page + 1;
|
|
|
1792 File.Line := 1;
|
|
|
1793 File.Col := 1;
|
|
|
1794 File.Before_Wide_Wide_Character := False;
|
|
|
1795 end Skip_Page;
|
|
|
1796
|
|
|
1797 procedure Skip_Page is
|
|
|
1798 begin
|
|
|
1799 Skip_Page (Current_In);
|
|
|
1800 end Skip_Page;
|
|
|
1801
|
|
|
1802 --------------------
|
|
|
1803 -- Standard_Error --
|
|
|
1804 --------------------
|
|
|
1805
|
|
|
1806 function Standard_Error return File_Type is
|
|
|
1807 begin
|
|
|
1808 return Standard_Err;
|
|
|
1809 end Standard_Error;
|
|
|
1810
|
|
|
1811 function Standard_Error return File_Access is
|
|
|
1812 begin
|
|
|
1813 return Standard_Err'Access;
|
|
|
1814 end Standard_Error;
|
|
|
1815
|
|
|
1816 --------------------
|
|
|
1817 -- Standard_Input --
|
|
|
1818 --------------------
|
|
|
1819
|
|
|
1820 function Standard_Input return File_Type is
|
|
|
1821 begin
|
|
|
1822 return Standard_In;
|
|
|
1823 end Standard_Input;
|
|
|
1824
|
|
|
1825 function Standard_Input return File_Access is
|
|
|
1826 begin
|
|
|
1827 return Standard_In'Access;
|
|
|
1828 end Standard_Input;
|
|
|
1829
|
|
|
1830 ---------------------
|
|
|
1831 -- Standard_Output --
|
|
|
1832 ---------------------
|
|
|
1833
|
|
|
1834 function Standard_Output return File_Type is
|
|
|
1835 begin
|
|
|
1836 return Standard_Out;
|
|
|
1837 end Standard_Output;
|
|
|
1838
|
|
|
1839 function Standard_Output return File_Access is
|
|
|
1840 begin
|
|
|
1841 return Standard_Out'Access;
|
|
|
1842 end Standard_Output;
|
|
|
1843
|
|
|
1844 --------------------
|
|
|
1845 -- Terminate_Line --
|
|
|
1846 --------------------
|
|
|
1847
|
|
|
1848 procedure Terminate_Line (File : File_Type) is
|
|
|
1849 begin
|
|
|
1850 FIO.Check_File_Open (AP (File));
|
|
|
1851
|
|
|
1852 -- For file other than In_File, test for needing to terminate last line
|
|
|
1853
|
|
|
1854 if Mode (File) /= In_File then
|
|
|
1855
|
|
|
1856 -- If not at start of line definition need new line
|
|
|
1857
|
|
|
1858 if File.Col /= 1 then
|
|
|
1859 New_Line (File);
|
|
|
1860
|
|
|
1861 -- For files other than standard error and standard output, we
|
|
|
1862 -- make sure that an empty file has a single line feed, so that
|
|
|
1863 -- it is properly formatted. We avoid this for the standard files
|
|
|
1864 -- because it is too much of a nuisance to have these odd line
|
|
|
1865 -- feeds when nothing has been written to the file.
|
|
|
1866
|
|
|
1867 elsif (File /= Standard_Err and then File /= Standard_Out)
|
|
|
1868 and then (File.Line = 1 and then File.Page = 1)
|
|
|
1869 then
|
|
|
1870 New_Line (File);
|
|
|
1871 end if;
|
|
|
1872 end if;
|
|
|
1873 end Terminate_Line;
|
|
|
1874
|
|
|
1875 ------------
|
|
|
1876 -- Ungetc --
|
|
|
1877 ------------
|
|
|
1878
|
|
|
1879 procedure Ungetc (ch : int; File : File_Type) is
|
|
|
1880 begin
|
|
|
1881 if ch /= EOF then
|
|
|
1882 if ungetc (ch, File.Stream) = EOF then
|
|
|
1883 raise Device_Error;
|
|
|
1884 end if;
|
|
|
1885 end if;
|
|
|
1886 end Ungetc;
|
|
|
1887
|
|
|
1888 -----------
|
|
|
1889 -- Write --
|
|
|
1890 -----------
|
|
|
1891
|
|
|
1892 -- This is the primitive Stream Write routine, used when a Text_IO file
|
|
|
1893 -- is treated directly as a stream using Text_IO.Streams.Stream.
|
|
|
1894
|
|
|
1895 procedure Write
|
|
|
1896 (File : in out Wide_Wide_Text_AFCB;
|
|
|
1897 Item : Stream_Element_Array)
|
|
|
1898 is
|
|
|
1899 pragma Warnings (Off, File);
|
|
|
1900 -- Because in this implementation we don't need IN OUT, we only read
|
|
|
1901
|
|
|
1902 Siz : constant size_t := Item'Length;
|
|
|
1903
|
|
|
1904 begin
|
|
|
1905 if File.Mode = FCB.In_File then
|
|
|
1906 raise Mode_Error;
|
|
|
1907 end if;
|
|
|
1908
|
|
|
1909 -- Now we do the write. Since this is a text file, it is normally in
|
|
|
1910 -- text mode, but stream data must be written in binary mode, so we
|
|
|
1911 -- temporarily set binary mode for the write, resetting it after.
|
|
|
1912 -- These calls have no effect in a system (like Unix) where there is
|
|
|
1913 -- no distinction between text and binary files.
|
|
|
1914
|
|
|
1915 set_binary_mode (fileno (File.Stream));
|
|
|
1916
|
|
|
1917 if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
|
|
|
1918 raise Device_Error;
|
|
|
1919 end if;
|
|
|
1920
|
|
|
1921 set_text_mode (fileno (File.Stream));
|
|
|
1922 end Write;
|
|
|
1923
|
|
|
1924 begin
|
|
|
1925 -- Initialize Standard Files
|
|
|
1926
|
|
|
1927 for J in WC_Encoding_Method loop
|
|
|
1928 if WC_Encoding = WC_Encoding_Letters (J) then
|
|
|
1929 Default_WCEM := J;
|
|
|
1930 end if;
|
|
|
1931 end loop;
|
|
|
1932
|
|
|
1933 Initialize_Standard_Files;
|
|
|
1934
|
|
|
1935 FIO.Chain_File (AP (Standard_In));
|
|
|
1936 FIO.Chain_File (AP (Standard_Out));
|
|
|
1937 FIO.Chain_File (AP (Standard_Err));
|
|
|
1938
|
|
|
1939 end Ada.Wide_Wide_Text_IO;
|
