diff options
Diffstat (limited to 'gcc/ada/a-witeio.adb')
| -rw-r--r-- | gcc/ada/a-witeio.adb | 213 |
1 files changed, 138 insertions, 75 deletions
diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index 621f4bd30ff..cfed9a7f0a4 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,6 +40,7 @@ with System.CRTL; with System.File_IO; with System.WCh_Cnv; use System.WCh_Cnv; with System.WCh_Con; use System.WCh_Con; + with Unchecked_Conversion; with Unchecked_Deallocation; @@ -65,14 +66,13 @@ package body Ada.Wide_Text_IO is -- Local Subprograms -- ----------------------- - function Getc_Immed (File : in File_Type) return int; + function Getc_Immed (File : File_Type) return int; -- This routine is identical to Getc, except that the read is done in -- Get_Immediate mode (i.e. without waiting for a line return). function Get_Wide_Char_Immed (C : Character; - File : File_Type) - return Wide_Character; + File : File_Type) return Wide_Character; -- This routine is identical to Get_Wide_Char, except that the reads are -- done in Get_Immediate mode (i.e. without waiting for a line return). @@ -86,11 +86,9 @@ package body Ada.Wide_Text_IO is ------------------- function AFCB_Allocate - (Control_Block : Wide_Text_AFCB) - return FCB.AFCB_Ptr + (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr is pragma Unreferenced (Control_Block); - begin return new Wide_Text_AFCB; end AFCB_Allocate; @@ -148,7 +146,7 @@ package body Ada.Wide_Text_IO is -- to exceed the value of Count'Last, i.e. no check is required for -- overflow raising layout error. - function Col (File : in File_Type) return Positive_Count is + function Col (File : File_Type) return Positive_Count is begin FIO.Check_File_Open (AP (File)); return File.Col; @@ -165,9 +163,9 @@ package body Ada.Wide_Text_IO is procedure Create (File : in out File_Type; - Mode : in File_Mode := Out_File; - Name : in String := ""; - Form : in String := "") + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") is Dummy_File_Control_Block : Wide_Text_AFCB; pragma Warnings (Off, Dummy_File_Control_Block); @@ -241,7 +239,7 @@ package body Ada.Wide_Text_IO is -- End_Of_File -- ----------------- - function End_Of_File (File : in File_Type) return Boolean is + function End_Of_File (File : File_Type) return Boolean is ch : int; begin @@ -302,7 +300,7 @@ package body Ada.Wide_Text_IO is -- End_Of_Line -- ----------------- - function End_Of_Line (File : in File_Type) return Boolean is + function End_Of_Line (File : File_Type) return Boolean is ch : int; begin @@ -336,7 +334,7 @@ package body Ada.Wide_Text_IO is -- End_Of_Page -- ----------------- - function End_Of_Page (File : in File_Type) return Boolean is + function End_Of_Page (File : File_Type) return Boolean is ch : int; begin @@ -386,7 +384,7 @@ package body Ada.Wide_Text_IO is -- Flush -- ----------- - procedure Flush (File : in File_Type) is + procedure Flush (File : File_Type) is begin FIO.Flush (AP (File)); end Flush; @@ -400,7 +398,7 @@ package body Ada.Wide_Text_IO is -- Form -- ---------- - function Form (File : in File_Type) return String is + function Form (File : File_Type) return String is begin return FIO.Form (AP (File)); end Form; @@ -410,7 +408,7 @@ package body Ada.Wide_Text_IO is --------- procedure Get - (File : in File_Type; + (File : File_Type; Item : out Wide_Character) is C : Character; @@ -434,7 +432,7 @@ package body Ada.Wide_Text_IO is end Get; procedure Get - (File : in File_Type; + (File : File_Type; Item : out Wide_String) is begin @@ -453,7 +451,7 @@ package body Ada.Wide_Text_IO is ------------------- procedure Get_Character - (File : in File_Type; + (File : File_Type; Item : out Character) is ch : int; @@ -501,7 +499,7 @@ package body Ada.Wide_Text_IO is ------------------- procedure Get_Immediate - (File : in File_Type; + (File : File_Type; Item : out Wide_Character) is ch : int; @@ -537,7 +535,7 @@ package body Ada.Wide_Text_IO is end Get_Immediate; procedure Get_Immediate - (File : in File_Type; + (File : File_Type; Item : out Wide_Character; Available : out Boolean) is @@ -580,7 +578,7 @@ package body Ada.Wide_Text_IO is -------------- procedure Get_Line - (File : in File_Type; + (File : File_Type; Item : out Wide_String; Last : out Natural) is @@ -671,22 +669,78 @@ package body Ada.Wide_Text_IO is Get_Line (Current_In, Item, Last); end Get_Line; + function Get_Line (File : File_Type) return Wide_String is + Buffer : Wide_String (1 .. 500); + Last : Natural; + + function Get_Rest (S : Wide_String) return Wide_String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : Wide_String) return Wide_String is + + -- Each time we allocate a buffer the same size as what we have + -- read so far. This limits us to a logarithmic number of calls + -- to Get_Rest and also ensures only a linear use of stack space. + + Buffer : Wide_String (1 .. S'Length); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant Wide_String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + else + return Get_Rest (R); + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Get_Rest (Buffer (1 .. Last)); + end if; + end Get_Line; + + function Get_Line return Wide_String is + begin + return Get_Line (Current_In); + end Get_Line; + ------------------- -- Get_Wide_Char -- ------------------- function Get_Wide_Char (C : Character; - File : File_Type) - return Wide_Character + File : File_Type) return Wide_Character is function In_Char return Character; -- Function used to obtain additional characters it the wide character -- sequence is more than one character long. + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + function In_Char return Character is ch : constant Integer := Getc (File); - begin if ch = EOF then raise End_Error; @@ -695,7 +749,7 @@ package body Ada.Wide_Text_IO is end if; end In_Char; - function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + -- Start of processing for In_Char begin return WC_In (C, File.WC_Method); @@ -707,16 +761,20 @@ package body Ada.Wide_Text_IO is function Get_Wide_Char_Immed (C : Character; - File : File_Type) - return Wide_Character + File : File_Type) return Wide_Character is function In_Char return Character; -- Function used to obtain additional characters it the wide character -- sequence is more than one character long. + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + function In_Char return Character is ch : constant Integer := Getc_Immed (File); - begin if ch = EOF then raise End_Error; @@ -725,7 +783,7 @@ package body Ada.Wide_Text_IO is end if; end In_Char; - function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + -- Start of processing for Get_Wide_Char_Immed begin return WC_In (C, File.WC_Method); @@ -752,7 +810,7 @@ package body Ada.Wide_Text_IO is -- Getc_Immed -- ---------------- - function Getc_Immed (File : in File_Type) return int is + function Getc_Immed (File : File_Type) return int is ch : int; end_of_file : int; @@ -785,7 +843,7 @@ package body Ada.Wide_Text_IO is -- Is_Open -- ------------- - function Is_Open (File : in File_Type) return Boolean is + function Is_Open (File : File_Type) return Boolean is begin return FIO.Is_Open (AP (File)); end Is_Open; @@ -798,7 +856,7 @@ package body Ada.Wide_Text_IO is -- to exceed the value of Count'Last, i.e. no check is required for -- overflow raising layout error. - function Line (File : in File_Type) return Positive_Count is + function Line (File : File_Type) return Positive_Count is begin FIO.Check_File_Open (AP (File)); return File.Line; @@ -813,7 +871,7 @@ package body Ada.Wide_Text_IO is -- Line_Length -- ----------------- - function Line_Length (File : in File_Type) return Count is + function Line_Length (File : File_Type) return Count is begin FIO.Check_Write_Status (AP (File)); return File.Line_Length; @@ -829,7 +887,7 @@ package body Ada.Wide_Text_IO is ---------------- procedure Look_Ahead - (File : in File_Type; + (File : File_Type; Item : out Wide_Character; End_Of_Line : out Boolean) is @@ -902,7 +960,7 @@ package body Ada.Wide_Text_IO is -- Mode -- ---------- - function Mode (File : in File_Type) return File_Mode is + function Mode (File : File_Type) return File_Mode is begin return To_TIO (FIO.Mode (AP (File))); end Mode; @@ -911,7 +969,7 @@ package body Ada.Wide_Text_IO is -- Name -- ---------- - function Name (File : in File_Type) return String is + function Name (File : File_Type) return String is begin return FIO.Name (AP (File)); end Name; @@ -921,8 +979,8 @@ package body Ada.Wide_Text_IO is -------------- procedure New_Line - (File : in File_Type; - Spacing : in Positive_Count := 1) + (File : File_Type; + Spacing : Positive_Count := 1) is begin -- Raise Constraint_Error if out of range value. The reason for this @@ -951,7 +1009,7 @@ package body Ada.Wide_Text_IO is File.Col := 1; end New_Line; - procedure New_Line (Spacing : in Positive_Count := 1) is + procedure New_Line (Spacing : Positive_Count := 1) is begin New_Line (Current_Out, Spacing); end New_Line; @@ -960,7 +1018,7 @@ package body Ada.Wide_Text_IO is -- New_Page -- -------------- - procedure New_Page (File : in File_Type) is + procedure New_Page (File : File_Type) is begin FIO.Check_Write_Status (AP (File)); @@ -1009,9 +1067,9 @@ package body Ada.Wide_Text_IO is procedure Open (File : in out File_Type; - Mode : in File_Mode; - Name : in String; - Form : in String := "") + Mode : File_Mode; + Name : String; + Form : String := "") is Dummy_File_Control_Block : Wide_Text_AFCB; pragma Warnings (Off, Dummy_File_Control_Block); @@ -1038,7 +1096,7 @@ package body Ada.Wide_Text_IO is -- to exceed the value of Count'Last, i.e. no check is required for -- overflow raising layout error. - function Page (File : in File_Type) return Positive_Count is + function Page (File : File_Type) return Positive_Count is begin FIO.Check_File_Open (AP (File)); return File.Page; @@ -1053,7 +1111,7 @@ package body Ada.Wide_Text_IO is -- Page_Length -- ----------------- - function Page_Length (File : in File_Type) return Count is + function Page_Length (File : File_Type) return Count is begin FIO.Check_Write_Status (AP (File)); return File.Page_Length; @@ -1069,25 +1127,30 @@ package body Ada.Wide_Text_IO is --------- procedure Put - (File : in File_Type; - Item : in Wide_Character) + (File : File_Type; + Item : Wide_Character) is procedure Out_Char (C : Character); -- Procedure to output one character of a wide character sequence + procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); + -------------- + -- Out_Char -- + -------------- + procedure Out_Char (C : Character) is begin Putc (Character'Pos (C), File); end Out_Char; - procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); + -- Start of processing for Put begin WC_Out (Item, File.WC_Method); File.Col := File.Col + 1; end Put; - procedure Put (Item : in Wide_Character) is + procedure Put (Item : Wide_Character) is begin Put (Current_Out, Item); end Put; @@ -1097,8 +1160,8 @@ package body Ada.Wide_Text_IO is --------- procedure Put - (File : in File_Type; - Item : in Wide_String) + (File : File_Type; + Item : Wide_String) is begin for J in Item'Range loop @@ -1106,7 +1169,7 @@ package body Ada.Wide_Text_IO is end loop; end Put; - procedure Put (Item : in Wide_String) is + procedure Put (Item : Wide_String) is begin Put (Current_Out, Item); end Put; @@ -1116,15 +1179,15 @@ package body Ada.Wide_Text_IO is -------------- procedure Put_Line - (File : in File_Type; - Item : in Wide_String) + (File : File_Type; + Item : Wide_String) is begin Put (File, Item); New_Line (File); end Put_Line; - procedure Put_Line (Item : in Wide_String) is + procedure Put_Line (Item : Wide_String) is begin Put (Current_Out, Item); New_Line (Current_Out); @@ -1231,7 +1294,7 @@ package body Ada.Wide_Text_IO is procedure Reset (File : in out File_Type; - Mode : in File_Mode) + Mode : File_Mode) is begin -- Don't allow change of mode for current file (RM A.10.2(5)) @@ -1273,8 +1336,8 @@ package body Ada.Wide_Text_IO is ------------- procedure Set_Col - (File : in File_Type; - To : in Positive_Count) + (File : File_Type; + To : Positive_Count) is ch : int; @@ -1333,7 +1396,7 @@ package body Ada.Wide_Text_IO is end if; end Set_Col; - procedure Set_Col (To : in Positive_Count) is + procedure Set_Col (To : Positive_Count) is begin Set_Col (Current_Out, To); end Set_Col; @@ -1342,7 +1405,7 @@ package body Ada.Wide_Text_IO is -- Set_Error -- --------------- - procedure Set_Error (File : in File_Type) is + procedure Set_Error (File : File_Type) is begin FIO.Check_Write_Status (AP (File)); Current_Err := File; @@ -1352,7 +1415,7 @@ package body Ada.Wide_Text_IO is -- Set_Input -- --------------- - procedure Set_Input (File : in File_Type) is + procedure Set_Input (File : File_Type) is begin FIO.Check_Read_Status (AP (File)); Current_In := File; @@ -1363,8 +1426,8 @@ package body Ada.Wide_Text_IO is -------------- procedure Set_Line - (File : in File_Type; - To : in Positive_Count) + (File : File_Type; + To : Positive_Count) is begin -- Raise Constraint_Error if out of range value. The reason for this @@ -1401,7 +1464,7 @@ package body Ada.Wide_Text_IO is end if; end Set_Line; - procedure Set_Line (To : in Positive_Count) is + procedure Set_Line (To : Positive_Count) is begin Set_Line (Current_Out, To); end Set_Line; @@ -1410,7 +1473,7 @@ package body Ada.Wide_Text_IO is -- Set_Line_Length -- --------------------- - procedure Set_Line_Length (File : in File_Type; To : in Count) is + procedure Set_Line_Length (File : File_Type; To : Count) is begin -- Raise Constraint_Error if out of range value. The reason for this -- explicit test is that we don't want junk values around, even if @@ -1424,7 +1487,7 @@ package body Ada.Wide_Text_IO is File.Line_Length := To; end Set_Line_Length; - procedure Set_Line_Length (To : in Count) is + procedure Set_Line_Length (To : Count) is begin Set_Line_Length (Current_Out, To); end Set_Line_Length; @@ -1433,7 +1496,7 @@ package body Ada.Wide_Text_IO is -- Set_Output -- ---------------- - procedure Set_Output (File : in File_Type) is + procedure Set_Output (File : File_Type) is begin FIO.Check_Write_Status (AP (File)); Current_Out := File; @@ -1443,7 +1506,7 @@ package body Ada.Wide_Text_IO is -- Set_Page_Length -- --------------------- - procedure Set_Page_Length (File : in File_Type; To : in Count) is + procedure Set_Page_Length (File : File_Type; To : Count) is begin -- Raise Constraint_Error if out of range value. The reason for this -- explicit test is that we don't want junk values around, even if @@ -1457,7 +1520,7 @@ package body Ada.Wide_Text_IO is File.Page_Length := To; end Set_Page_Length; - procedure Set_Page_Length (To : in Count) is + procedure Set_Page_Length (To : Count) is begin Set_Page_Length (Current_Out, To); end Set_Page_Length; @@ -1497,8 +1560,8 @@ package body Ada.Wide_Text_IO is --------------- procedure Skip_Line - (File : in File_Type; - Spacing : in Positive_Count := 1) + (File : File_Type; + Spacing : Positive_Count := 1) is ch : int; @@ -1580,7 +1643,7 @@ package body Ada.Wide_Text_IO is File.Before_Wide_Character := False; end Skip_Line; - procedure Skip_Line (Spacing : in Positive_Count := 1) is + procedure Skip_Line (Spacing : Positive_Count := 1) is begin Skip_Line (Current_In, Spacing); end Skip_Line; @@ -1589,7 +1652,7 @@ package body Ada.Wide_Text_IO is -- Skip_Page -- --------------- - procedure Skip_Page (File : in File_Type) is + procedure Skip_Page (File : File_Type) is ch : int; begin @@ -1741,7 +1804,7 @@ package body Ada.Wide_Text_IO is procedure Write (File : in out Wide_Text_AFCB; - Item : in Stream_Element_Array) + Item : Stream_Element_Array) is Siz : constant size_t := Item'Length; |