1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . W I D E _ T E X T _ I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 32with Ada.Streams; use Ada.Streams; 33with Interfaces.C_Streams; use Interfaces.C_Streams; 34 35with System.CRTL; 36with System.File_IO; 37with System.WCh_Cnv; use System.WCh_Cnv; 38with System.WCh_Con; use System.WCh_Con; 39 40with Ada.Unchecked_Conversion; 41with Ada.Unchecked_Deallocation; 42 43pragma Elaborate_All (System.File_IO); 44-- Needed because of calls to Chain_File in package body elaboration 45 46package body Ada.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_Char_Immed 85 (C : Character; 86 File : File_Type) return Wide_Character; 87 -- This routine is identical to Get_Wide_Char, except that the reads are 88 -- 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_Text_AFCB) return FCB.AFCB_Ptr 122 is 123 pragma Unreferenced (Control_Block); 124 begin 125 return new Wide_Text_AFCB; 126 end AFCB_Allocate; 127 128 ---------------- 129 -- AFCB_Close -- 130 ---------------- 131 132 procedure AFCB_Close (File : not null access 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_Text_AFCB) is 155 type FCB_Ptr is access all Wide_Text_AFCB; 156 FT : FCB_Ptr := FCB_Ptr (File); 157 158 procedure Free is 159 new Ada.Unchecked_Deallocation (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_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_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_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_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_Character) 447 is 448 C : Character; 449 450 begin 451 FIO.Check_Read_Status (AP (File)); 452 453 if File.Before_Wide_Character then 454 File.Before_Wide_Character := False; 455 Item := File.Saved_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_Char (C, File); 462 end if; 463 end Get; 464 465 procedure Get (Item : out 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_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_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_Character) 540 is 541 ch : int; 542 543 begin 544 FIO.Check_Read_Status (AP (File)); 545 546 if File.Before_Wide_Character then 547 File.Before_Wide_Character := False; 548 Item := File.Saved_Wide_Character; 549 550 elsif File.Before_LM then 551 File.Before_LM := False; 552 File.Before_LM_PM := False; 553 Item := 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_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_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_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_Character then 585 File.Before_Wide_Character := False; 586 Item := File.Saved_Wide_Character; 587 588 elsif File.Before_LM then 589 File.Before_LM := False; 590 File.Before_LM_PM := False; 591 Item := 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_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_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_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, but 667 -- this is not an official page mark in any case, since official 668 -- page marks can only follow a line mark. The whole page business 669 -- is pretty much nonsense anyway, so we do not want to waste 670 -- time trying to make sense out of non-standard page marks in 671 -- the file. This means that the behavior of Get_Line is different 672 -- from repeated Get of a character, but that's too bad. We 673 -- only promise that page numbers etc make sense if the file 674 -- 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_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_String is 711 Buffer : Wide_String (1 .. 500); 712 Last : Natural; 713 714 function Get_Rest (S : Wide_String) return 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_String) return 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_String (1 .. S'Length); 729 Last : Natural; 730 731 begin 732 Get_Line (File, Buffer, Last); 733 734 declare 735 R : constant 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_String is 758 begin 759 return Get_Line (Current_In); 760 end Get_Line; 761 762 ------------------- 763 -- Get_Wide_Char -- 764 ------------------- 765 766 function Get_Wide_Char 767 (C : Character; 768 File : File_Type) return 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_Wide_Char (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_Char 791 792 begin 793 FIO.Check_Read_Status (AP (File)); 794 return WC_In (C, File.WC_Method); 795 end Get_Wide_Char; 796 797 ------------------------- 798 -- Get_Wide_Char_Immed -- 799 ------------------------- 800 801 function Get_Wide_Char_Immed 802 (C : Character; 803 File : File_Type) return 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_Wide_Char (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_Char_Immed 826 827 begin 828 FIO.Check_Read_Status (AP (File)); 829 return WC_In (C, File.WC_Method); 830 end Get_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 to exceed 942 -- the value of Count'Last, i.e. no check is required for overflow raising 943 -- 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_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_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_Character then 997 End_Of_Line := False; 998 Item := File.Saved_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_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_Character'Val (ch); 1023 1024 -- For the start of an encoding, we read the character using the 1025 -- Get_Wide_Char routine. It will occupy more than one byte so we 1026 -- can't put it back with ungetc. Instead we save it in the control 1027 -- block, setting a flag that everyone interested in reading 1028 -- characters must test before reading the stream. 1029 1030 else 1031 Item := Get_Wide_Char (Character'Val (ch), File); 1032 End_Of_Line := False; 1033 File.Saved_Wide_Character := Item; 1034 File.Before_Wide_Character := True; 1035 end if; 1036 end if; 1037 end Look_Ahead; 1038 1039 procedure Look_Ahead 1040 (Item : out 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_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_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 Wide_Char_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 (Item, File.WC_Method); 1242 File.Col := File.Col + 1; 1243 end Put; 1244 1245 procedure Put (Item : 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_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_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_String) 1276 is 1277 begin 1278 Put (File, Item); 1279 New_Line (File); 1280 end Put_Line; 1281 1282 procedure Put_Line (Item : 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_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_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_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_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_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 1925begin 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 1940end Ada.Wide_Text_IO; 1941