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-2018, 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.Text_Encoding := Default_Text; 896 Standard_Err.Access_Method := 'T'; 897 Standard_Err.Self := Standard_Err; 898 Standard_Err.WC_Method := Default_WCEM; 899 900 Standard_In.Stream := stdin; 901 Standard_In.Name := In_Name'Access; 902 Standard_In.Form := Null_Str'Unrestricted_Access; 903 Standard_In.Mode := FCB.In_File; 904 Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; 905 Standard_In.Is_Temporary_File := False; 906 Standard_In.Is_System_File := True; 907 Standard_In.Text_Encoding := Default_Text; 908 Standard_In.Access_Method := 'T'; 909 Standard_In.Self := Standard_In; 910 Standard_In.WC_Method := Default_WCEM; 911 912 Standard_Out.Stream := stdout; 913 Standard_Out.Name := Out_Name'Access; 914 Standard_Out.Form := Null_Str'Unrestricted_Access; 915 Standard_Out.Mode := FCB.Out_File; 916 Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; 917 Standard_Out.Is_Temporary_File := False; 918 Standard_Out.Is_System_File := True; 919 Standard_Out.Text_Encoding := Default_Text; 920 Standard_Out.Access_Method := 'T'; 921 Standard_Out.Self := Standard_Out; 922 Standard_Out.WC_Method := Default_WCEM; 923 924 FIO.Make_Unbuffered (AP (Standard_Out)); 925 FIO.Make_Unbuffered (AP (Standard_Err)); 926 end Initialize_Standard_Files; 927 928 ------------- 929 -- Is_Open -- 930 ------------- 931 932 function Is_Open (File : File_Type) return Boolean is 933 begin 934 return FIO.Is_Open (AP (File)); 935 end Is_Open; 936 937 ---------- 938 -- Line -- 939 ---------- 940 941 -- Note: we assume that it is impossible in practice for the line 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 1086 -- We use Put here (rather than Putc) so that we get the proper 1087 -- behavior on windows for output of Wide_String to the console. 1088 1089 Put (File, Wide_Character'Val (LM)); 1090 1091 File.Line := File.Line + 1; 1092 1093 if File.Page_Length /= 0 and then File.Line > File.Page_Length then 1094 1095 -- Same situation as above, use Put instead of Putc 1096 1097 Put (File, Wide_Character'Val (PM)); 1098 1099 File.Line := 1; 1100 File.Page := File.Page + 1; 1101 end if; 1102 end loop; 1103 1104 File.Col := 1; 1105 end New_Line; 1106 1107 procedure New_Line (Spacing : Positive_Count := 1) is 1108 begin 1109 New_Line (Current_Out, Spacing); 1110 end New_Line; 1111 1112 -------------- 1113 -- New_Page -- 1114 -------------- 1115 1116 procedure New_Page (File : File_Type) is 1117 begin 1118 FIO.Check_Write_Status (AP (File)); 1119 1120 if File.Col /= 1 or else File.Line = 1 then 1121 Putc (LM, File); 1122 end if; 1123 1124 Putc (PM, File); 1125 File.Page := File.Page + 1; 1126 File.Line := 1; 1127 File.Col := 1; 1128 end New_Page; 1129 1130 procedure New_Page is 1131 begin 1132 New_Page (Current_Out); 1133 end New_Page; 1134 1135 ----------- 1136 -- Nextc -- 1137 ----------- 1138 1139 function Nextc (File : File_Type) return int is 1140 ch : int; 1141 1142 begin 1143 ch := fgetc (File.Stream); 1144 1145 if ch = EOF then 1146 if ferror (File.Stream) /= 0 then 1147 raise Device_Error; 1148 end if; 1149 1150 else 1151 if ungetc (ch, File.Stream) = EOF then 1152 raise Device_Error; 1153 end if; 1154 end if; 1155 1156 return ch; 1157 end Nextc; 1158 1159 ---------- 1160 -- Open -- 1161 ---------- 1162 1163 procedure Open 1164 (File : in out File_Type; 1165 Mode : File_Mode; 1166 Name : String; 1167 Form : String := "") 1168 is 1169 Dummy_File_Control_Block : Wide_Text_AFCB; 1170 pragma Warnings (Off, Dummy_File_Control_Block); 1171 -- Yes, we know this is never assigned a value, only the tag 1172 -- is used for dispatching purposes, so that's expected. 1173 1174 begin 1175 FIO.Open (File_Ptr => AP (File), 1176 Dummy_FCB => Dummy_File_Control_Block, 1177 Mode => To_FCB (Mode), 1178 Name => Name, 1179 Form => Form, 1180 Amethod => 'W', 1181 Creat => False, 1182 Text => True); 1183 1184 File.Self := File; 1185 Set_WCEM (File); 1186 end Open; 1187 1188 ---------- 1189 -- Page -- 1190 ---------- 1191 1192 -- Note: we assume that it is impossible in practice for the page 1193 -- to exceed the value of Count'Last, i.e. no check is required for 1194 -- overflow raising layout error. 1195 1196 function Page (File : File_Type) return Positive_Count is 1197 begin 1198 FIO.Check_File_Open (AP (File)); 1199 return File.Page; 1200 end Page; 1201 1202 function Page return Positive_Count is 1203 begin 1204 return Page (Current_Out); 1205 end Page; 1206 1207 ----------------- 1208 -- Page_Length -- 1209 ----------------- 1210 1211 function Page_Length (File : File_Type) return Count is 1212 begin 1213 FIO.Check_Write_Status (AP (File)); 1214 return File.Page_Length; 1215 end Page_Length; 1216 1217 function Page_Length return Count is 1218 begin 1219 return Page_Length (Current_Out); 1220 end Page_Length; 1221 1222 --------- 1223 -- Put -- 1224 --------- 1225 1226 procedure Put 1227 (File : File_Type; 1228 Item : Wide_Character) 1229 is 1230 wide_text_translation_required : Integer; 1231 pragma Import 1232 (C, wide_text_translation_required, 1233 "__gnat_wide_text_translation_required"); 1234 -- Text translation is required on Windows only. This means that the 1235 -- console is doing translation and we do not want to do any encoding 1236 -- here. If this variable is not 0 we output the character via fputwc. 1237 1238 procedure Out_Char (C : Character); 1239 -- Procedure to output one character of a wide character sequence 1240 1241 procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); 1242 1243 -------------- 1244 -- Out_Char -- 1245 -------------- 1246 1247 procedure Out_Char (C : Character) is 1248 begin 1249 Putc (Character'Pos (C), File); 1250 end Out_Char; 1251 1252 Discard : int; 1253 1254 -- Start of processing for Put 1255 1256 begin 1257 FIO.Check_Write_Status (AP (File)); 1258 1259 if wide_text_translation_required /= 0 1260 or else File.Text_Encoding in Non_Default_Text_Content_Encoding 1261 then 1262 set_mode (fileno (File.Stream), File.Text_Encoding); 1263 Discard := fputwc (Wide_Character'Pos (Item), File.Stream); 1264 else 1265 WC_Out (Item, File.WC_Method); 1266 end if; 1267 1268 File.Col := File.Col + 1; 1269 end Put; 1270 1271 procedure Put (Item : Wide_Character) is 1272 begin 1273 Put (Current_Out, Item); 1274 end Put; 1275 1276 --------- 1277 -- Put -- 1278 --------- 1279 1280 procedure Put 1281 (File : File_Type; 1282 Item : Wide_String) 1283 is 1284 begin 1285 for J in Item'Range loop 1286 Put (File, Item (J)); 1287 end loop; 1288 end Put; 1289 1290 procedure Put (Item : Wide_String) is 1291 begin 1292 Put (Current_Out, Item); 1293 end Put; 1294 1295 -------------- 1296 -- Put_Line -- 1297 -------------- 1298 1299 procedure Put_Line 1300 (File : File_Type; 1301 Item : Wide_String) 1302 is 1303 begin 1304 Put (File, Item); 1305 New_Line (File); 1306 end Put_Line; 1307 1308 procedure Put_Line (Item : Wide_String) is 1309 begin 1310 Put (Current_Out, Item); 1311 New_Line (Current_Out); 1312 end Put_Line; 1313 1314 ---------- 1315 -- Putc -- 1316 ---------- 1317 1318 procedure Putc (ch : int; File : File_Type) is 1319 begin 1320 if fputc (ch, File.Stream) = EOF then 1321 raise Device_Error; 1322 end if; 1323 end Putc; 1324 1325 ---------- 1326 -- Read -- 1327 ---------- 1328 1329 -- This is the primitive Stream Read routine, used when a Text_IO file 1330 -- is treated directly as a stream using Text_IO.Streams.Stream. 1331 1332 procedure Read 1333 (File : in out Wide_Text_AFCB; 1334 Item : out Stream_Element_Array; 1335 Last : out Stream_Element_Offset) 1336 is 1337 Discard_ch : int; 1338 pragma Unreferenced (Discard_ch); 1339 1340 begin 1341 -- Need to deal with Before_Wide_Character ??? 1342 1343 if File.Mode /= FCB.In_File then 1344 raise Mode_Error; 1345 end if; 1346 1347 -- Deal with case where our logical and physical position do not match 1348 -- because of being after an LM or LM-PM sequence when in fact we are 1349 -- logically positioned before it. 1350 1351 if File.Before_LM then 1352 1353 -- If we are before a PM, then it is possible for a stream read 1354 -- to leave us after the LM and before the PM, which is a bit 1355 -- odd. The easiest way to deal with this is to unget the PM, 1356 -- so we are indeed positioned between the characters. This way 1357 -- further stream read operations will work correctly, and the 1358 -- effect on text processing is a little weird, but what can 1359 -- be expected if stream and text input are mixed this way? 1360 1361 if File.Before_LM_PM then 1362 Discard_ch := ungetc (PM, File.Stream); 1363 File.Before_LM_PM := False; 1364 end if; 1365 1366 File.Before_LM := False; 1367 1368 Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); 1369 1370 if Item'Length = 1 then 1371 Last := Item'Last; 1372 1373 else 1374 Last := 1375 Item'First + 1376 Stream_Element_Offset 1377 (fread (buffer => Item'Address, 1378 index => size_t (Item'First + 1), 1379 size => 1, 1380 count => Item'Length - 1, 1381 stream => File.Stream)); 1382 end if; 1383 1384 return; 1385 end if; 1386 1387 -- Now we do the read. Since this is a text file, it is normally in 1388 -- text mode, but stream data must be read in binary mode, so we 1389 -- temporarily set binary mode for the read, resetting it after. 1390 -- These calls have no effect in a system (like Unix) where there is 1391 -- no distinction between text and binary files. 1392 1393 set_binary_mode (fileno (File.Stream)); 1394 1395 Last := 1396 Item'First + 1397 Stream_Element_Offset 1398 (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; 1399 1400 if Last < Item'Last then 1401 if ferror (File.Stream) /= 0 then 1402 raise Device_Error; 1403 end if; 1404 end if; 1405 1406 set_text_mode (fileno (File.Stream)); 1407 end Read; 1408 1409 ----------- 1410 -- Reset -- 1411 ----------- 1412 1413 procedure Reset 1414 (File : in out File_Type; 1415 Mode : File_Mode) 1416 is 1417 begin 1418 -- Don't allow change of mode for current file (RM A.10.2(5)) 1419 1420 if (File = Current_In or else 1421 File = Current_Out or else 1422 File = Current_Error) 1423 and then To_FCB (Mode) /= File.Mode 1424 then 1425 raise Mode_Error; 1426 end if; 1427 1428 Terminate_Line (File); 1429 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); 1430 File.Page := 1; 1431 File.Line := 1; 1432 File.Col := 1; 1433 File.Line_Length := 0; 1434 File.Page_Length := 0; 1435 File.Before_LM := False; 1436 File.Before_LM_PM := False; 1437 end Reset; 1438 1439 procedure Reset (File : in out File_Type) is 1440 begin 1441 Terminate_Line (File); 1442 FIO.Reset (AP (File)'Unrestricted_Access); 1443 File.Page := 1; 1444 File.Line := 1; 1445 File.Col := 1; 1446 File.Line_Length := 0; 1447 File.Page_Length := 0; 1448 File.Before_LM := False; 1449 File.Before_LM_PM := False; 1450 end Reset; 1451 1452 ------------- 1453 -- Set_Col -- 1454 ------------- 1455 1456 procedure Set_Col 1457 (File : File_Type; 1458 To : Positive_Count) 1459 is 1460 ch : int; 1461 1462 begin 1463 -- Raise Constraint_Error if out of range value. The reason for this 1464 -- explicit test is that we don't want junk values around, even if 1465 -- checks are off in the caller. 1466 1467 if not To'Valid then 1468 raise Constraint_Error; 1469 end if; 1470 1471 FIO.Check_File_Open (AP (File)); 1472 1473 if To = File.Col then 1474 return; 1475 end if; 1476 1477 if Mode (File) >= Out_File then 1478 if File.Line_Length /= 0 and then To > File.Line_Length then 1479 raise Layout_Error; 1480 end if; 1481 1482 if To < File.Col then 1483 New_Line (File); 1484 end if; 1485 1486 while File.Col < To loop 1487 Put (File, ' '); 1488 end loop; 1489 1490 else 1491 loop 1492 ch := Getc (File); 1493 1494 if ch = EOF then 1495 raise End_Error; 1496 1497 elsif ch = LM then 1498 File.Line := File.Line + 1; 1499 File.Col := 1; 1500 1501 elsif ch = PM and then File.Is_Regular_File then 1502 File.Page := File.Page + 1; 1503 File.Line := 1; 1504 File.Col := 1; 1505 1506 elsif To = File.Col then 1507 Ungetc (ch, File); 1508 return; 1509 1510 else 1511 File.Col := File.Col + 1; 1512 end if; 1513 end loop; 1514 end if; 1515 end Set_Col; 1516 1517 procedure Set_Col (To : Positive_Count) is 1518 begin 1519 Set_Col (Current_Out, To); 1520 end Set_Col; 1521 1522 --------------- 1523 -- Set_Error -- 1524 --------------- 1525 1526 procedure Set_Error (File : File_Type) is 1527 begin 1528 FIO.Check_Write_Status (AP (File)); 1529 Current_Err := File; 1530 end Set_Error; 1531 1532 --------------- 1533 -- Set_Input -- 1534 --------------- 1535 1536 procedure Set_Input (File : File_Type) is 1537 begin 1538 FIO.Check_Read_Status (AP (File)); 1539 Current_In := File; 1540 end Set_Input; 1541 1542 -------------- 1543 -- Set_Line -- 1544 -------------- 1545 1546 procedure Set_Line 1547 (File : File_Type; 1548 To : Positive_Count) 1549 is 1550 begin 1551 -- Raise Constraint_Error if out of range value. The reason for this 1552 -- explicit test is that we don't want junk values around, even if 1553 -- checks are off in the caller. 1554 1555 if not To'Valid then 1556 raise Constraint_Error; 1557 end if; 1558 1559 FIO.Check_File_Open (AP (File)); 1560 1561 if To = File.Line then 1562 return; 1563 end if; 1564 1565 if Mode (File) >= Out_File then 1566 if File.Page_Length /= 0 and then To > File.Page_Length then 1567 raise Layout_Error; 1568 end if; 1569 1570 if To < File.Line then 1571 New_Page (File); 1572 end if; 1573 1574 while File.Line < To loop 1575 New_Line (File); 1576 end loop; 1577 1578 else 1579 while To /= File.Line loop 1580 Skip_Line (File); 1581 end loop; 1582 end if; 1583 end Set_Line; 1584 1585 procedure Set_Line (To : Positive_Count) is 1586 begin 1587 Set_Line (Current_Out, To); 1588 end Set_Line; 1589 1590 --------------------- 1591 -- Set_Line_Length -- 1592 --------------------- 1593 1594 procedure Set_Line_Length (File : File_Type; To : Count) is 1595 begin 1596 -- Raise Constraint_Error if out of range value. The reason for this 1597 -- explicit test is that we don't want junk values around, even if 1598 -- checks are off in the caller. 1599 1600 if not To'Valid then 1601 raise Constraint_Error; 1602 end if; 1603 1604 FIO.Check_Write_Status (AP (File)); 1605 File.Line_Length := To; 1606 end Set_Line_Length; 1607 1608 procedure Set_Line_Length (To : Count) is 1609 begin 1610 Set_Line_Length (Current_Out, To); 1611 end Set_Line_Length; 1612 1613 ---------------- 1614 -- Set_Output -- 1615 ---------------- 1616 1617 procedure Set_Output (File : File_Type) is 1618 begin 1619 FIO.Check_Write_Status (AP (File)); 1620 Current_Out := File; 1621 end Set_Output; 1622 1623 --------------------- 1624 -- Set_Page_Length -- 1625 --------------------- 1626 1627 procedure Set_Page_Length (File : File_Type; To : Count) is 1628 begin 1629 -- Raise Constraint_Error if out of range value. The reason for this 1630 -- explicit test is that we don't want junk values around, even if 1631 -- checks are off in the caller. 1632 1633 if not To'Valid then 1634 raise Constraint_Error; 1635 end if; 1636 1637 FIO.Check_Write_Status (AP (File)); 1638 File.Page_Length := To; 1639 end Set_Page_Length; 1640 1641 procedure Set_Page_Length (To : Count) is 1642 begin 1643 Set_Page_Length (Current_Out, To); 1644 end Set_Page_Length; 1645 1646 -------------- 1647 -- Set_WCEM -- 1648 -------------- 1649 1650 procedure Set_WCEM (File : in out File_Type) is 1651 Start : Natural; 1652 Stop : Natural; 1653 1654 begin 1655 FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); 1656 1657 if Start = 0 then 1658 File.WC_Method := Default_WCEM; 1659 1660 else 1661 if Stop = Start then 1662 for J in WC_Encoding_Letters'Range loop 1663 if File.Form (Start) = WC_Encoding_Letters (J) then 1664 File.WC_Method := J; 1665 return; 1666 end if; 1667 end loop; 1668 end if; 1669 1670 Close (File); 1671 raise Use_Error with "invalid WCEM form parameter"; 1672 end if; 1673 end Set_WCEM; 1674 1675 --------------- 1676 -- Skip_Line -- 1677 --------------- 1678 1679 procedure Skip_Line 1680 (File : File_Type; 1681 Spacing : Positive_Count := 1) 1682 is 1683 ch : int; 1684 1685 begin 1686 -- Raise Constraint_Error if out of range value. The reason for this 1687 -- explicit test is that we don't want junk values around, even if 1688 -- checks are off in the caller. 1689 1690 if not Spacing'Valid then 1691 raise Constraint_Error; 1692 end if; 1693 1694 FIO.Check_Read_Status (AP (File)); 1695 1696 for L in 1 .. Spacing loop 1697 if File.Before_LM then 1698 File.Before_LM := False; 1699 File.Before_LM_PM := False; 1700 1701 else 1702 ch := Getc (File); 1703 1704 -- If at end of file now, then immediately raise End_Error. Note 1705 -- that we can never be positioned between a line mark and a page 1706 -- mark, so if we are at the end of file, we cannot logically be 1707 -- before the implicit page mark that is at the end of the file. 1708 1709 -- For the same reason, we do not need an explicit check for a 1710 -- page mark. If there is a FF in the middle of a line, the file 1711 -- is not in canonical format and we do not care about the page 1712 -- numbers for files other than ones in canonical format. 1713 1714 if ch = EOF then 1715 raise End_Error; 1716 end if; 1717 1718 -- If not at end of file, then loop till we get to an LM or EOF. 1719 -- The latter case happens only in non-canonical files where the 1720 -- last line is not terminated by LM, but we don't want to blow 1721 -- up for such files, so we assume an implicit LM in this case. 1722 1723 loop 1724 exit when ch = LM or else ch = EOF; 1725 ch := Getc (File); 1726 end loop; 1727 end if; 1728 1729 -- We have got past a line mark, now, for a regular file only, 1730 -- see if a page mark immediately follows this line mark and 1731 -- if so, skip past the page mark as well. We do not do this 1732 -- for non-regular files, since it would cause an undesirable 1733 -- wait for an additional character. 1734 1735 File.Col := 1; 1736 File.Line := File.Line + 1; 1737 1738 if File.Before_LM_PM then 1739 File.Page := File.Page + 1; 1740 File.Line := 1; 1741 File.Before_LM_PM := False; 1742 1743 elsif File.Is_Regular_File then 1744 ch := Getc (File); 1745 1746 -- Page mark can be explicit, or implied at the end of the file 1747 1748 if (ch = PM or else ch = EOF) 1749 and then File.Is_Regular_File 1750 then 1751 File.Page := File.Page + 1; 1752 File.Line := 1; 1753 else 1754 Ungetc (ch, File); 1755 end if; 1756 end if; 1757 end loop; 1758 1759 File.Before_Wide_Character := False; 1760 end Skip_Line; 1761 1762 procedure Skip_Line (Spacing : Positive_Count := 1) is 1763 begin 1764 Skip_Line (Current_In, Spacing); 1765 end Skip_Line; 1766 1767 --------------- 1768 -- Skip_Page -- 1769 --------------- 1770 1771 procedure Skip_Page (File : File_Type) is 1772 ch : int; 1773 1774 begin 1775 FIO.Check_Read_Status (AP (File)); 1776 1777 -- If at page mark already, just skip it 1778 1779 if File.Before_LM_PM then 1780 File.Before_LM := False; 1781 File.Before_LM_PM := False; 1782 File.Page := File.Page + 1; 1783 File.Line := 1; 1784 File.Col := 1; 1785 return; 1786 end if; 1787 1788 -- This is a bit tricky, if we are logically before an LM then 1789 -- it is not an error if we are at an end of file now, since we 1790 -- are not really at it. 1791 1792 if File.Before_LM then 1793 File.Before_LM := False; 1794 File.Before_LM_PM := False; 1795 ch := Getc (File); 1796 1797 -- Otherwise we do raise End_Error if we are at the end of file now 1798 1799 else 1800 ch := Getc (File); 1801 1802 if ch = EOF then 1803 raise End_Error; 1804 end if; 1805 end if; 1806 1807 -- Now we can just rumble along to the next page mark, or to the 1808 -- end of file, if that comes first. The latter case happens when 1809 -- the page mark is implied at the end of file. 1810 1811 loop 1812 exit when ch = EOF 1813 or else (ch = PM and then File.Is_Regular_File); 1814 ch := Getc (File); 1815 end loop; 1816 1817 File.Page := File.Page + 1; 1818 File.Line := 1; 1819 File.Col := 1; 1820 File.Before_Wide_Character := False; 1821 end Skip_Page; 1822 1823 procedure Skip_Page is 1824 begin 1825 Skip_Page (Current_In); 1826 end Skip_Page; 1827 1828 -------------------- 1829 -- Standard_Error -- 1830 -------------------- 1831 1832 function Standard_Error return File_Type is 1833 begin 1834 return Standard_Err; 1835 end Standard_Error; 1836 1837 function Standard_Error return File_Access is 1838 begin 1839 return Standard_Err'Access; 1840 end Standard_Error; 1841 1842 -------------------- 1843 -- Standard_Input -- 1844 -------------------- 1845 1846 function Standard_Input return File_Type is 1847 begin 1848 return Standard_In; 1849 end Standard_Input; 1850 1851 function Standard_Input return File_Access is 1852 begin 1853 return Standard_In'Access; 1854 end Standard_Input; 1855 1856 --------------------- 1857 -- Standard_Output -- 1858 --------------------- 1859 1860 function Standard_Output return File_Type is 1861 begin 1862 return Standard_Out; 1863 end Standard_Output; 1864 1865 function Standard_Output return File_Access is 1866 begin 1867 return Standard_Out'Access; 1868 end Standard_Output; 1869 1870 -------------------- 1871 -- Terminate_Line -- 1872 -------------------- 1873 1874 procedure Terminate_Line (File : File_Type) is 1875 begin 1876 FIO.Check_File_Open (AP (File)); 1877 1878 -- For file other than In_File, test for needing to terminate last line 1879 1880 if Mode (File) /= In_File then 1881 1882 -- If not at start of line definition need new line 1883 1884 if File.Col /= 1 then 1885 New_Line (File); 1886 1887 -- For files other than standard error and standard output, we 1888 -- make sure that an empty file has a single line feed, so that 1889 -- it is properly formatted. We avoid this for the standard files 1890 -- because it is too much of a nuisance to have these odd line 1891 -- feeds when nothing has been written to the file. 1892 1893 elsif (File /= Standard_Err and then File /= Standard_Out) 1894 and then (File.Line = 1 and then File.Page = 1) 1895 then 1896 New_Line (File); 1897 end if; 1898 end if; 1899 end Terminate_Line; 1900 1901 ------------ 1902 -- Ungetc -- 1903 ------------ 1904 1905 procedure Ungetc (ch : int; File : File_Type) is 1906 begin 1907 if ch /= EOF then 1908 if ungetc (ch, File.Stream) = EOF then 1909 raise Device_Error; 1910 end if; 1911 end if; 1912 end Ungetc; 1913 1914 ----------- 1915 -- Write -- 1916 ----------- 1917 1918 -- This is the primitive Stream Write routine, used when a Text_IO file 1919 -- is treated directly as a stream using Text_IO.Streams.Stream. 1920 1921 procedure Write 1922 (File : in out Wide_Text_AFCB; 1923 Item : Stream_Element_Array) 1924 is 1925 pragma Warnings (Off, File); 1926 -- Because in this implementation we don't need IN OUT, we only read 1927 1928 Siz : constant size_t := Item'Length; 1929 1930 begin 1931 if File.Mode = FCB.In_File then 1932 raise Mode_Error; 1933 end if; 1934 1935 -- Now we do the write. Since this is a text file, it is normally in 1936 -- text mode, but stream data must be written in binary mode, so we 1937 -- temporarily set binary mode for the write, resetting it after. 1938 -- These calls have no effect in a system (like Unix) where there is 1939 -- no distinction between text and binary files. 1940 1941 set_binary_mode (fileno (File.Stream)); 1942 1943 if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then 1944 raise Device_Error; 1945 end if; 1946 1947 set_text_mode (fileno (File.Stream)); 1948 end Write; 1949 1950begin 1951 -- Initialize Standard Files 1952 1953 for J in WC_Encoding_Method loop 1954 if WC_Encoding = WC_Encoding_Letters (J) then 1955 Default_WCEM := J; 1956 end if; 1957 end loop; 1958 1959 Initialize_Standard_Files; 1960 1961 FIO.Chain_File (AP (Standard_In)); 1962 FIO.Chain_File (AP (Standard_Out)); 1963 FIO.Chain_File (AP (Standard_Err)); 1964 1965end Ada.Wide_Text_IO; 1966