OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-ztexio.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with Ada.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.Is_Text_File      := True;
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.Is_Text_File       := True;
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.Is_Text_File      := True;
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
      File.WC_Method := WCEM_Brackets;
1630
      FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
1631
 
1632
      if Start = 0 then
1633
         File.WC_Method := WCEM_Brackets;
1634
 
1635
      else
1636
         if Stop = Start then
1637
            for J in WC_Encoding_Letters'Range loop
1638
               if File.Form (Start) = WC_Encoding_Letters (J) then
1639
                  File.WC_Method := J;
1640
                  return;
1641
               end if;
1642
            end loop;
1643
         end if;
1644
 
1645
         Close (File);
1646
         raise Use_Error with "invalid WCEM form parameter";
1647
      end if;
1648
   end Set_WCEM;
1649
 
1650
   ---------------
1651
   -- Skip_Line --
1652
   ---------------
1653
 
1654
   procedure Skip_Line
1655
     (File    : File_Type;
1656
      Spacing : Positive_Count := 1)
1657
   is
1658
      ch : int;
1659
 
1660
   begin
1661
      --  Raise Constraint_Error if out of range value. The reason for this
1662
      --  explicit test is that we don't want junk values around, even if
1663
      --  checks are off in the caller.
1664
 
1665
      if not Spacing'Valid then
1666
         raise Constraint_Error;
1667
      end if;
1668
 
1669
      FIO.Check_Read_Status (AP (File));
1670
 
1671
      for L in 1 .. Spacing loop
1672
         if File.Before_LM then
1673
            File.Before_LM := False;
1674
            File.Before_LM_PM := False;
1675
 
1676
         else
1677
            ch := Getc (File);
1678
 
1679
            --  If at end of file now, then immediately raise End_Error. Note
1680
            --  that we can never be positioned between a line mark and a page
1681
            --  mark, so if we are at the end of file, we cannot logically be
1682
            --  before the implicit page mark that is at the end of the file.
1683
 
1684
            --  For the same reason, we do not need an explicit check for a
1685
            --  page mark. If there is a FF in the middle of a line, the file
1686
            --  is not in canonical format and we do not care about the page
1687
            --  numbers for files other than ones in canonical format.
1688
 
1689
            if ch = EOF then
1690
               raise End_Error;
1691
            end if;
1692
 
1693
            --  If not at end of file, then loop till we get to an LM or EOF.
1694
            --  The latter case happens only in non-canonical files where the
1695
            --  last line is not terminated by LM, but we don't want to blow
1696
            --  up for such files, so we assume an implicit LM in this case.
1697
 
1698
            loop
1699
               exit when ch = LM or else ch = EOF;
1700
               ch := Getc (File);
1701
            end loop;
1702
         end if;
1703
 
1704
         --  We have got past a line mark, now, for a regular file only,
1705
         --  see if a page mark immediately follows this line mark and
1706
         --  if so, skip past the page mark as well. We do not do this
1707
         --  for non-regular files, since it would cause an undesirable
1708
         --  wait for an additional character.
1709
 
1710
         File.Col := 1;
1711
         File.Line := File.Line + 1;
1712
 
1713
         if File.Before_LM_PM then
1714
            File.Page := File.Page + 1;
1715
            File.Line := 1;
1716
            File.Before_LM_PM := False;
1717
 
1718
         elsif File.Is_Regular_File then
1719
            ch := Getc (File);
1720
 
1721
            --  Page mark can be explicit, or implied at the end of the file
1722
 
1723
            if (ch = PM or else ch = EOF)
1724
              and then File.Is_Regular_File
1725
            then
1726
               File.Page := File.Page + 1;
1727
               File.Line := 1;
1728
            else
1729
               Ungetc (ch, File);
1730
            end if;
1731
         end if;
1732
      end loop;
1733
 
1734
      File.Before_Wide_Wide_Character := False;
1735
   end Skip_Line;
1736
 
1737
   procedure Skip_Line (Spacing : Positive_Count := 1) is
1738
   begin
1739
      Skip_Line (Current_In, Spacing);
1740
   end Skip_Line;
1741
 
1742
   ---------------
1743
   -- Skip_Page --
1744
   ---------------
1745
 
1746
   procedure Skip_Page (File : File_Type) is
1747
      ch : int;
1748
 
1749
   begin
1750
      FIO.Check_Read_Status (AP (File));
1751
 
1752
      --  If at page mark already, just skip it
1753
 
1754
      if File.Before_LM_PM then
1755
         File.Before_LM := False;
1756
         File.Before_LM_PM := False;
1757
         File.Page := File.Page + 1;
1758
         File.Line := 1;
1759
         File.Col  := 1;
1760
         return;
1761
      end if;
1762
 
1763
      --  This is a bit tricky, if we are logically before an LM then
1764
      --  it is not an error if we are at an end of file now, since we
1765
      --  are not really at it.
1766
 
1767
      if File.Before_LM then
1768
         File.Before_LM := False;
1769
         File.Before_LM_PM := False;
1770
         ch := Getc (File);
1771
 
1772
      --  Otherwise we do raise End_Error if we are at the end of file now
1773
 
1774
      else
1775
         ch := Getc (File);
1776
 
1777
         if ch = EOF then
1778
            raise End_Error;
1779
         end if;
1780
      end if;
1781
 
1782
      --  Now we can just rumble along to the next page mark, or to the
1783
      --  end of file, if that comes first. The latter case happens when
1784
      --  the page mark is implied at the end of file.
1785
 
1786
      loop
1787
         exit when ch = EOF
1788
           or else (ch = PM and then File.Is_Regular_File);
1789
         ch := Getc (File);
1790
      end loop;
1791
 
1792
      File.Page := File.Page + 1;
1793
      File.Line := 1;
1794
      File.Col  := 1;
1795
      File.Before_Wide_Wide_Character := False;
1796
   end Skip_Page;
1797
 
1798
   procedure Skip_Page is
1799
   begin
1800
      Skip_Page (Current_In);
1801
   end Skip_Page;
1802
 
1803
   --------------------
1804
   -- Standard_Error --
1805
   --------------------
1806
 
1807
   function Standard_Error return File_Type is
1808
   begin
1809
      return Standard_Err;
1810
   end Standard_Error;
1811
 
1812
   function Standard_Error return File_Access is
1813
   begin
1814
      return Standard_Err'Access;
1815
   end Standard_Error;
1816
 
1817
   --------------------
1818
   -- Standard_Input --
1819
   --------------------
1820
 
1821
   function Standard_Input return File_Type is
1822
   begin
1823
      return Standard_In;
1824
   end Standard_Input;
1825
 
1826
   function Standard_Input return File_Access is
1827
   begin
1828
      return Standard_In'Access;
1829
   end Standard_Input;
1830
 
1831
   ---------------------
1832
   -- Standard_Output --
1833
   ---------------------
1834
 
1835
   function Standard_Output return File_Type is
1836
   begin
1837
      return Standard_Out;
1838
   end Standard_Output;
1839
 
1840
   function Standard_Output return File_Access is
1841
   begin
1842
      return Standard_Out'Access;
1843
   end Standard_Output;
1844
 
1845
   --------------------
1846
   -- Terminate_Line --
1847
   --------------------
1848
 
1849
   procedure Terminate_Line (File : File_Type) is
1850
   begin
1851
      FIO.Check_File_Open (AP (File));
1852
 
1853
      --  For file other than In_File, test for needing to terminate last line
1854
 
1855
      if Mode (File) /= In_File then
1856
 
1857
         --  If not at start of line definition need new line
1858
 
1859
         if File.Col /= 1 then
1860
            New_Line (File);
1861
 
1862
         --  For files other than standard error and standard output, we
1863
         --  make sure that an empty file has a single line feed, so that
1864
         --  it is properly formatted. We avoid this for the standard files
1865
         --  because it is too much of a nuisance to have these odd line
1866
         --  feeds when nothing has been written to the file.
1867
 
1868
         elsif (File /= Standard_Err and then File /= Standard_Out)
1869
           and then (File.Line = 1 and then File.Page = 1)
1870
         then
1871
            New_Line (File);
1872
         end if;
1873
      end if;
1874
   end Terminate_Line;
1875
 
1876
   ------------
1877
   -- Ungetc --
1878
   ------------
1879
 
1880
   procedure Ungetc (ch : int; File : File_Type) is
1881
   begin
1882
      if ch /= EOF then
1883
         if ungetc (ch, File.Stream) = EOF then
1884
            raise Device_Error;
1885
         end if;
1886
      end if;
1887
   end Ungetc;
1888
 
1889
   -----------
1890
   -- Write --
1891
   -----------
1892
 
1893
   --  This is the primitive Stream Write routine, used when a Text_IO file
1894
   --  is treated directly as a stream using Text_IO.Streams.Stream.
1895
 
1896
   procedure Write
1897
     (File : in out Wide_Wide_Text_AFCB;
1898
      Item : Stream_Element_Array)
1899
   is
1900
      pragma Warnings (Off, File);
1901
      --  Because in this implementation we don't need IN OUT, we only read
1902
 
1903
      Siz : constant size_t := Item'Length;
1904
 
1905
   begin
1906
      if File.Mode = FCB.In_File then
1907
         raise Mode_Error;
1908
      end if;
1909
 
1910
      --  Now we do the write. Since this is a text file, it is normally in
1911
      --  text mode, but stream data must be written in binary mode, so we
1912
      --  temporarily set binary mode for the write, resetting it after.
1913
      --  These calls have no effect in a system (like Unix) where there is
1914
      --  no distinction between text and binary files.
1915
 
1916
      set_binary_mode (fileno (File.Stream));
1917
 
1918
      if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
1919
         raise Device_Error;
1920
      end if;
1921
 
1922
      set_text_mode (fileno (File.Stream));
1923
   end Write;
1924
 
1925
begin
1926
   --  Initialize Standard Files
1927
 
1928
   for J in WC_Encoding_Method loop
1929
      if WC_Encoding = WC_Encoding_Letters (J) then
1930
         Default_WCEM := J;
1931
      end if;
1932
   end loop;
1933
 
1934
   Initialize_Standard_Files;
1935
 
1936
   FIO.Chain_File (AP (Standard_In));
1937
   FIO.Chain_File (AP (Standard_Out));
1938
   FIO.Chain_File (AP (Standard_Err));
1939
 
1940
end Ada.Wide_Wide_Text_IO;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.