[multiple changes]

2010-10-08  Geert Bosch  <bosch@adacore.com>

	* a-textio.adb (Get_Line): Rewrite to use fgets instead of fgetc.

2010-10-08  Javier Miranda  <miranda@adacore.com>

	* sem_prag.adb (Analyze_Pragma): Relax semantic rule of
	Java_Constructors because in the JRE library we generate occurrences
	in which the "this" parameter is not the first formal.

From-SVN: r165170

3 files changed, 209 insertions, 88 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 87ee729f41c..eb440cec55a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2010-10-08  Geert Bosch  <bosch@adacore.com>
+
+	* a-textio.adb (Get_Line): Rewrite to use fgets instead of fgetc.
+
+2010-10-08  Javier Miranda  <miranda@adacore.com>
+
+	* sem_prag.adb (Analyze_Pragma): Relax semantic rule of
+	Java_Constructors because in the JRE library we generate occurrences
+	in which the "this" parameter is not the first formal.
+
 2010-10-08  Robert Dewar  <dewar@adacore.com>
 
 	* par-ch3.adb: Minor reformatting.
diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb
index 0dd54632068..27a0c3b7f74 100644
--- a/gcc/ada/a-textio.adb
+++ b/gcc/ada/a-textio.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          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- --
@@ -29,13 +29,15 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Ada.Streams;          use Ada.Streams;
-with Interfaces.C_Streams; use Interfaces.C_Streams;
+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;
-with System.WCh_Con;       use System.WCh_Con;
+with System.WCh_Cnv;          use System.WCh_Cnv;
+with System.WCh_Con;          use System.WCh_Con;
 
 with Ada.Unchecked_Conversion;
 with Ada.Unchecked_Deallocation;
@@ -693,20 +695,120 @@ package body Ada.Text_IO is
       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 (Item'First + Last)'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 (Item'First + Last)'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));
-      Last := Item'First - 1;
 
       --  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 Last >= Item'Last then
+      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.
 
@@ -717,67 +819,44 @@ package body Ada.Text_IO is
       --  Otherwise we need to read some characters
 
       else
-         ch := Getc (File);
-
-         --  If we are at the end of file now, it means we are trying to
-         --  skip a file terminator and we raise End_Error (RM A.10.7(20))
+         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 ch = EOF then
-            raise End_Error;
+         if N > 1 then
+            N := Get_Chunk (N);
          end if;
 
-         --  Loop through characters. Don't bother if we hit a page mark,
-         --  since in normal files, page marks can only follow line marks
-         --  in any case and we only promise to treat the page nonsense
-         --  correctly in the absense of such rogue page marks.
+         --  Almost there, only a little bit more to read
 
-         loop
-            --  Exit the loop if read is terminated by encountering line mark
-
-            exit when ch = LM;
-
-            --  Otherwise store the character, note that we know that ch is
-            --  something other than LM or EOF. It could possibly be a page
-            --  mark if there is a stray page mark in the middle of a line,
-            --  but this is not an official page mark in any case, since
-            --  official page marks can only follow a line mark. The whole
-            --  page business is pretty much nonsense anyway, so we do not
-            --  want to waste time trying to make sense out of non-standard
-            --  page marks in the file! This means that the behavior of
-            --  Get_Line is different from repeated Get of a character, but
-            --  that's too bad. We only promise that page numbers etc make
-            --  sense if the file is formatted in a standard manner.
-
-            --  Note: we do not adjust the column number because it is quicker
-            --  to adjust it once at the end of the operation than incrementing
-            --  it each time around the loop.
-
-            Last := Last + 1;
-            Item (Last) := Character'Val (ch);
-
-            --  All done if the string is full, this is the case in which
-            --  we do not skip the following line mark. We need to adjust
-            --  the column number in this case.
-
-            if Last = Item'Last then
-               File.Col := File.Col + Count (Item'Length);
-               return;
-            end if;
+         if N = 1 then
+            ch := Getc (File);
 
-            --  Otherwise read next character. We also exit from the loop if
-            --  we read an end of file. This is the case where the last line
-            --  is not terminated with a line mark, and we consider that there
-            --  is an implied line mark in this case (this is a non-standard
-            --  file, but it is nice to treat it reasonably).
+            --  If we get EOF after already reading data, this is an incomplete
+            --  last line, in which case no End_Error should be raised.
 
-            ch := Getc (File);
-            exit when ch = EOF;
-         end loop;
+            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)
+      --  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;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 3a9a48289c2..90424cdeeb1 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -2378,7 +2378,7 @@ package body Sem_Prag is
                      --  need to force visibility for client (error will be
                      --  output in any case, and this is the situation in which
                      --  we do not want a client to get a warning, since the
-                     --  warning is in the body or the spec private part.
+                     --  warning is in the body or the spec private part).
 
                      else
                         if Cont = False then
@@ -8903,10 +8903,11 @@ package body Sem_Prag is
 
          when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
          Java_Constructor : declare
-            Convention : Convention_Id;
-            Def_Id     : Entity_Id;
-            Hom_Id     : Entity_Id;
-            Id         : Entity_Id;
+            Convention  : Convention_Id;
+            Def_Id      : Entity_Id;
+            Hom_Id      : Entity_Id;
+            Id          : Entity_Id;
+            This_Formal : Entity_Id;
 
          begin
             GNAT_Pragma;
@@ -8997,36 +8998,70 @@ package body Sem_Prag is
                if not Is_Value_Type (Etype (Def_Id)) then
                   if No (First_Formal (Def_Id)) then
                      Error_Msg_Name_1 := Pname;
-                     Error_Msg_N
-                       ("first formal of % function must be named `this`",
-                        Def_Id);
+                     Error_Msg_N ("% function must have parameters", Def_Id);
+                     return;
+                  end if;
+
+                  --  In the JRE library we have several occurrences in which
+                  --  the "this" parameter is not the first formal.
 
-                  elsif Get_Name_String (Chars (First_Formal (Def_Id)))
-                          /= "this"
+                  This_Formal := First_Formal (Def_Id);
+
+                  --  In the JRE library we have several occurrences in which
+                  --  the "this" parameter is not the first formal. Search for
+                  --  it.
+
+                  if VM_Target = JVM_Target then
+                     while Present (This_Formal)
+                       and then Get_Name_String (Chars (This_Formal)) /= "this"
+                     loop
+                        Next_Formal (This_Formal);
+                     end loop;
+
+                     if No (This_Formal) then
+                        This_Formal := First_Formal (Def_Id);
+                     end if;
+                  end if;
+
+                  --  Warning: The first parameter should be named "this".
+                  --  We temporarily allow it because we have the following
+                  --  case in the Java runtime (file s-osinte.ads) ???
+
+                  --    function new_Thread
+                  --      (Self_Id : System.Address) return Thread_Id;
+                  --    pragma Java_Constructor (new_Thread);
+
+                  if VM_Target = JVM_Target
+                    and then Get_Name_String (Chars (First_Formal (Def_Id)))
+                               = "self_id"
+                    and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
                   then
+                     null;
+
+                  elsif Get_Name_String (Chars (This_Formal)) /= "this" then
                      Error_Msg_Name_1 := Pname;
                      Error_Msg_N
                        ("first formal of % function must be named `this`",
-                        Parent (First_Formal (Def_Id)));
+                        Parent (This_Formal));
 
-                  elsif not Is_Access_Type (Etype (First_Formal (Def_Id))) then
+                  elsif not Is_Access_Type (Etype (This_Formal)) then
                      Error_Msg_Name_1 := Pname;
                      Error_Msg_N
                        ("first formal of % function must be an access type",
-                        Parameter_Type (Parent (First_Formal (Def_Id))));
+                        Parameter_Type (Parent (This_Formal)));
 
                   --  For delegates the type of the first formal must be a
                   --  named access-to-subprogram type (see previous example)
 
                   elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
-                    and then Ekind (Etype (First_Formal (Def_Id)))
+                    and then Ekind (Etype (This_Formal))
                                /= E_Access_Subprogram_Type
                   then
                      Error_Msg_Name_1 := Pname;
                      Error_Msg_N
                        ("first formal of % function must be a named access" &
                         " to subprogram type",
-                        Parameter_Type (Parent (First_Formal (Def_Id))));
+                        Parameter_Type (Parent (This_Formal)));
 
                   --  Warning: We should reject anonymous access types because
                   --  the constructor must not be handled as a primitive of the
@@ -9034,20 +9069,19 @@ package body Sem_Prag is
                   --  is currently generated by cil2ada???
 
                   elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
-                    and then not Ekind_In (Etype (First_Formal (Def_Id)),
-                                   E_Access_Type,
-                                   E_General_Access_Type,
-                                   E_Anonymous_Access_Type)
+                    and then not Ekind_In (Etype (This_Formal),
+                                             E_Access_Type,
+                                             E_General_Access_Type,
+                                             E_Anonymous_Access_Type)
                   then
                      Error_Msg_Name_1 := Pname;
                      Error_Msg_N
                        ("first formal of % function must be a named access" &
                         " type",
-                        Parameter_Type (Parent (First_Formal (Def_Id))));
+                        Parameter_Type (Parent (This_Formal)));
 
                   elsif Atree.Convention
-                         (Designated_Type (Etype (First_Formal (Def_Id))))
-                           /= Convention
+                         (Designated_Type (Etype (This_Formal))) /= Convention
                   then
                      Error_Msg_Name_1 := Pname;
 
@@ -9055,23 +9089,21 @@ package body Sem_Prag is
                         Error_Msg_N
                           ("pragma% requires convention 'Cil in designated" &
                            " type",
-                           Parameter_Type (Parent (First_Formal (Def_Id))));
+                           Parameter_Type (Parent (This_Formal)));
                      else
                         Error_Msg_N
                           ("pragma% requires convention 'Java in designated" &
                            " type",
-                           Parameter_Type (Parent (First_Formal (Def_Id))));
+                           Parameter_Type (Parent (This_Formal)));
                      end if;
 
-                  elsif No (Expression (Parent (First_Formal (Def_Id))))
-                    or else
-                      Nkind (Expression (Parent (First_Formal (Def_Id)))) /=
-                        N_Null
+                  elsif No (Expression (Parent (This_Formal)))
+                    or else Nkind (Expression (Parent (This_Formal))) /= N_Null
                   then
                      Error_Msg_Name_1 := Pname;
                      Error_Msg_N
                        ("pragma% requires first formal with default `null`",
-                        Parameter_Type (Parent (First_Formal (Def_Id))));
+                        Parameter_Type (Parent (This_Formal)));
                   end if;
                end if;