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