From b0887a432e679835dba79c5d6825f110bdf8a138 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 11 Oct 2010 09:05:08 +0200 Subject: [multiple changes] 2010-10-11 Javier Miranda * a-textio.adb: Move new implementation of Get_Line to a subunit. * a-tigeli.adb: New subunit containing the implementation of Get_Line. 2010-10-11 Ed Schonberg * sem_aux.adb: Code clean up. From-SVN: r165272 --- gcc/ada/ChangeLog | 9 +++ gcc/ada/a-textio.adb | 191 +------------------------------------------ gcc/ada/a-tigeli.adb | 224 +++++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_aux.adb | 15 ++-- 4 files changed, 243 insertions(+), 196 deletions(-) create mode 100644 gcc/ada/a-tigeli.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e8132ab..0959150 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2010-10-11 Javier Miranda + + * a-textio.adb: Move new implementation of Get_Line to a subunit. + * a-tigeli.adb: New subunit containing the implementation of Get_Line. + +2010-10-11 Ed Schonberg + + * sem_aux.adb: Code clean up. + 2010-10-11 Robert Dewar * sem_ch3.adb, sem_aux.adb, sem_ch6.adb: Minor reformatting diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index 924bfe5..f8538ab 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -32,8 +32,6 @@ with Ada.Streams; use Ada.Streams; with Interfaces.C_Streams; use Interfaces.C_Streams; -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; with System.File_IO; with System.CRTL; with System.WCh_Cnv; use System.WCh_Cnv; @@ -686,197 +684,10 @@ package body Ada.Text_IO is Get_Immediate (Current_In, Item, Available); end Get_Immediate; - -------------- - -- Get_Line -- - -------------- - procedure Get_Line (File : File_Type; Item : out String; - Last : out Natural) - is - Chunk_Size : constant := 80; - -- We read into a fixed size auxiliary buffer. Because this buffer - -- needs to be pre-initialized, there is a trade-off between size and - -- speed. Experiments find returns are diminishing after 50 and this - -- size allows most lines to be processed with a single read. - - ch : int; - N : Natural; - - procedure memcpy (s1, s2 : chars; n : size_t); - pragma Import (C, memcpy); - - function memchr (s : chars; ch : int; n : size_t) return chars; - pragma Import (C, memchr); - - procedure memset (b : chars; ch : int; n : size_t); - pragma Import (C, memset); - - function Get_Chunk (N : Positive) return Natural; - -- Reads at most N - 1 characters into Item (Last + 1 .. Item'Last), - -- updating Last. Raises End_Error if nothing was read (End_Of_File). - -- Returns number of characters still to read (either 0 or 1) in - -- case of success. - - --------------- - -- Get_Chunk -- - --------------- - - function Get_Chunk (N : Positive) return Natural is - Buf : String (1 .. Chunk_Size); - S : constant chars := Buf (1)'Address; - P : chars; - - begin - if N = 1 then - return N; - end if; - - memset (S, 10, size_t (N)); - - if fgets (S, N, File.Stream) = Null_Address then - if ferror (File.Stream) /= 0 then - raise Device_Error; - - -- If incomplete last line, pretend we found a LM - - elsif Last >= Item'First then - return 0; - - else - raise End_Error; - end if; - end if; - - P := memchr (S, LM, size_t (N)); - - -- If no LM is found, the buffer got filled without reading a new - -- line. Otherwise, the LM is either one from the input, or else one - -- from the initialization, which means an incomplete end-of-line was - -- encountered. Only in first case the LM will be followed by a 0. - - if P = Null_Address then - pragma Assert (Buf (N) = ASCII.NUL); - memcpy (Item (Last + 1)'Address, - Buf (1)'Address, size_t (N - 1)); - Last := Last + N - 1; - - return 1; - - else - -- P points to the LM character. Set K so Buf (K) is the character - -- right before. - - declare - K : Natural := Natural (P - S); - - begin - -- Now Buf (K + 2) should be 0, or otherwise Buf (K) is the 0 - -- put in by fgets, so compensate. - - if K + 2 > Buf'Last or else Buf (K + 2) /= ASCII.NUL then - - -- Incomplete last line, so remove the extra 0 - - pragma Assert (Buf (K) = ASCII.NUL); - K := K - 1; - end if; - - memcpy (Item (Last + 1)'Address, - Buf (1)'Address, size_t (K)); - Last := Last + K; - end; - - return 0; - end if; - end Get_Chunk; - - -- Start of processing for Get_Line - - begin - FIO.Check_Read_Status (AP (File)); - - -- Immediate exit for null string, this is a case in which we do not - -- need to test for end of file and we do not skip a line mark under - -- any circumstances. - - if Item'First > Item'Last then - return; - end if; - - N := Item'Last - Item'First + 1; - - Last := Item'First - 1; - - -- Here we have at least one character, if we are immediately before - -- a line mark, then we will just skip past it storing no characters. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - - -- Otherwise we need to read some characters - - else - while N >= Chunk_Size loop - if Get_Chunk (Chunk_Size) = 0 then - N := 0; - else - N := N - Chunk_Size + 1; - end if; - end loop; - - if N > 1 then - N := Get_Chunk (N); - end if; - - -- Almost there, only a little bit more to read - - if N = 1 then - ch := Getc (File); - - -- If we get EOF after already reading data, this is an incomplete - -- last line, in which case no End_Error should be raised. - - if ch = EOF and then Last < Item'First then - raise End_Error; - - elsif ch /= LM then - - -- Buffer really is full without having seen LM, update col - - Last := Last + 1; - Item (Last) := Character'Val (ch); - File.Col := File.Col + Count (Last - Item'First + 1); - return; - end if; - end if; - end if; - - -- We have skipped past, but not stored, a line mark. Skip following - -- page mark if one follows, but do not do this for a non-regular file - -- (since otherwise we get annoying wait for an extra character) - - File.Line := File.Line + 1; - File.Col := 1; - - if File.Before_LM_PM then - File.Line := 1; - File.Before_LM_PM := False; - File.Page := File.Page + 1; - - elsif File.Is_Regular_File then - ch := Getc (File); - - if ch = PM and then File.Is_Regular_File then - File.Line := 1; - File.Page := File.Page + 1; - else - Ungetc (ch, File); - end if; - end if; - end Get_Line; + Last : out Natural) is separate; procedure Get_Line (Item : out String; diff --git a/gcc/ada/a-tigeli.adb b/gcc/ada/a-tigeli.adb new file mode 100644 index 0000000..f37ccb4 --- /dev/null +++ b/gcc/ada/a-tigeli.adb @@ -0,0 +1,224 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +separate (Ada.Text_IO) +procedure Get_Line + (File : File_Type; + Item : out String; + Last : out Natural) +is + Chunk_Size : constant := 80; + -- We read into a fixed size auxiliary buffer. Because this buffer + -- needs to be pre-initialized, there is a trade-off between size and + -- speed. Experiments find returns are diminishing after 50 and this + -- size allows most lines to be processed with a single read. + + ch : int; + N : Natural; + + procedure memcpy (s1, s2 : chars; n : size_t); + pragma Import (C, memcpy); + + function memchr (s : chars; ch : int; n : size_t) return chars; + pragma Import (C, memchr); + + procedure memset (b : chars; ch : int; n : size_t); + pragma Import (C, memset); + + function Get_Chunk (N : Positive) return Natural; + -- Reads at most N - 1 characters into Item (Last + 1 .. Item'Last), + -- updating Last. Raises End_Error if nothing was read (End_Of_File). + -- Returns number of characters still to read (either 0 or 1) in + -- case of success. + + --------------- + -- Get_Chunk -- + --------------- + + function Get_Chunk (N : Positive) return Natural is + Buf : String (1 .. Chunk_Size); + S : constant chars := Buf (1)'Address; + P : chars; + + begin + if N = 1 then + return N; + end if; + + memset (S, 10, size_t (N)); + + if fgets (S, N, File.Stream) = Null_Address then + if ferror (File.Stream) /= 0 then + raise Device_Error; + + -- If incomplete last line, pretend we found a LM + + elsif Last >= Item'First then + return 0; + + else + raise End_Error; + end if; + end if; + + P := memchr (S, LM, size_t (N)); + + -- If no LM is found, the buffer got filled without reading a new + -- line. Otherwise, the LM is either one from the input, or else one + -- from the initialization, which means an incomplete end-of-line was + -- encountered. Only in first case the LM will be followed by a 0. + + if P = Null_Address then + pragma Assert (Buf (N) = ASCII.NUL); + memcpy (Item (Last + 1)'Address, + Buf (1)'Address, size_t (N - 1)); + Last := Last + N - 1; + + return 1; + + else + -- P points to the LM character. Set K so Buf (K) is the character + -- right before. + + declare + K : Natural := Natural (P - S); + + begin + -- Now Buf (K + 2) should be 0, or otherwise Buf (K) is the 0 + -- put in by fgets, so compensate. + + if K + 2 > Buf'Last or else Buf (K + 2) /= ASCII.NUL then + + -- Incomplete last line, so remove the extra 0 + + pragma Assert (Buf (K) = ASCII.NUL); + K := K - 1; + end if; + + memcpy (Item (Last + 1)'Address, + Buf (1)'Address, size_t (K)); + Last := Last + K; + end; + + return 0; + end if; + end Get_Chunk; + +-- Start of processing for Get_Line + +begin + FIO.Check_Read_Status (AP (File)); + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Item'First > Item'Last then + return; + end if; + + N := Item'Last - Item'First + 1; + + Last := Item'First - 1; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + while N >= Chunk_Size loop + if Get_Chunk (Chunk_Size) = 0 then + N := 0; + else + N := N - Chunk_Size + 1; + end if; + end loop; + + if N > 1 then + N := Get_Chunk (N); + end if; + + -- Almost there, only a little bit more to read + + if N = 1 then + ch := Getc (File); + + -- If we get EOF after already reading data, this is an incomplete + -- last line, in which case no End_Error should be raised. + + if ch = EOF and then Last < Item'First then + raise End_Error; + + elsif ch /= LM then + + -- Buffer really is full without having seen LM, update col + + Last := Last + 1; + Item (Last) := Character'Val (ch); + File.Col := File.Col + Count (Last - Item'First + 1); + return; + end if; + end if; + end if; + + -- We have skipped past, but not stored, a line mark. Skip following + -- page mark if one follows, but do not do this for a non-regular file + -- (since otherwise we get annoying wait for an extra character) + + File.Line := File.Line + 1; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + + elsif File.Is_Regular_File then + ch := Getc (File); + + if ch = PM and then File.Is_Regular_File then + File.Line := 1; + File.Page := File.Page + 1; + else + Ungetc (ch, File); + end if; + end if; +end Get_Line; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index b670d43..7bda710 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -578,7 +578,10 @@ package body Sem_Aux is Btype : constant Entity_Id := Base_Type (Ent); begin - if Ekind (Btype) = E_Limited_Private_Type + if Is_Limited_Record (Btype) then + return True; + + elsif Ekind (Btype) = E_Limited_Private_Type and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration then return not In_Package_Body (Scope ((Btype))); @@ -595,8 +598,11 @@ package body Sem_Aux is if not Is_Limited_Type (Etype (Btype)) then return False; + -- A descendant of a limited formal type is not immutably limited + -- in the generic body, or in the body of a generic child. + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then - return not In_Package_Body (Scope (Etype (Btype))); + return not In_Package_Body (Scope (Btype)); else return False; @@ -626,10 +632,7 @@ package body Sem_Aux is -- handled as build in place even though they might return objects -- of a type that is not inherently limited. - if Is_Limited_Record (Btype) then - return True; - - elsif Is_Class_Wide_Type (Btype) then + if Is_Class_Wide_Type (Btype) then return Is_Immutably_Limited_Type (Root_Type (Btype)); else -- cgit v1.1