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