sem_res.adb (Comes_From_Predefined_Lib_Unit): New.

2007-08-16  Hristian Kirtchev  <kirtchev@adacore.com>
	    Bob Duff  <duff@adacore.com>
	    Nicolas Setton  <setton@adacore.com>

	* sem_res.adb (Comes_From_Predefined_Lib_Unit): New.
	(Resolve): Alphabetize local variables. Add new variable From_Lib. When
	the statement which is being resolved comes from a predefined library
	unit, all non-predefined library interpretations are skipped.
	(Resolve_Op_Concat): If string concatenation was folded in the parser,
	but the "&" is user defined, give an error, because the folding would
	be wrong.

	* sinfo.ads, sinfo.adb (Is_Folded_In_Parser): New flag to indicate that
	the parser has folded a long sequence of concatenations of string
	literals.

	* trans.c (Handled_Sequence_Of_Statements_to_gnu): Mark "JMPBUF_SAVE"
	and "JMP_BUF" variables as artificial.
	(N_String_Literal): Do not use alloca for very long string literals. Use
	xmalloc/free instead. Otherwise the stack might overflow.

	* utils.c (init_gigi_decls): Mark "JMPBUF_T" type as created by the
	compiler.

From-SVN: r127550

gcc/ada/sem_res.adb

@@ -37,6 +37,7 @@ with Exp_Ch6;  use Exp_Ch6;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
+with Fname;    use Fname;
 with Freeze;   use Freeze;
 with Itypes;   use Itypes;
 with Lib;      use Lib;
@@ -1546,16 +1547,21 @@ package body Sem_Res is
    -------------
 
    procedure Resolve (N : Node_Id; Typ : Entity_Id) is
+      Ambiguous : Boolean   := False;
+      Ctx_Type  : Entity_Id := Typ;
+      Expr_Type : Entity_Id := Empty; -- prevent junk warning
+      Err_Type  : Entity_Id := Empty;
+      Found     : Boolean   := False;
+      From_Lib  : Boolean;
       I         : Interp_Index;
-      I1        : Interp_Index := 0; -- prevent junk warning
+      I1        : Interp_Index := 0;  -- prevent junk warning
       It        : Interp;
       It1       : Interp;
-      Found     : Boolean   := False;
       Seen      : Entity_Id := Empty; -- prevent junk warning
-      Ctx_Type  : Entity_Id := Typ;
-      Expr_Type : Entity_Id := Empty; -- prevent junk warning
-      Err_Type  : Entity_Id := Empty;
-      Ambiguous : Boolean   := False;
+
+      function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
+      --  Determine whether a node comes from a predefined library unit or
+      --  Standard.
 
       procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
       --  Try and fix up a literal so that it matches its expected type. New
@@ -1564,6 +1570,18 @@ package body Sem_Res is
       procedure Resolution_Failed;
       --  Called when attempt at resolving current expression fails
 
+      ------------------------------------
+      -- Comes_From_Predefined_Lib_Unit --
+      -------------------------------------
+
+      function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is
+      begin
+         return
+           Sloc (Nod) = Standard_Location
+             or else Is_Predefined_File_Name (Unit_File_Name (
+                       Get_Source_Unit (Sloc (Nod))));
+      end Comes_From_Predefined_Lib_Unit;
+
       --------------------
       -- Patch_Up_Value --
       --------------------
@@ -1660,6 +1678,8 @@ package body Sem_Res is
            ("prefix must statically denote a non-remote subprogram", N);
       end if;
 
+      From_Lib := Comes_From_Predefined_Lib_Unit (N);
+
       --  If the context is a Remote_Access_To_Subprogram, access attributes
       --  must be resolved with the corresponding fat pointer. There is no need
       --  to check for the attribute name since the return type of an
@@ -1817,6 +1837,16 @@ package body Sem_Res is
                --  some more obscure cases are handled in Disambiguate.
 
                else
+                  --  If the current statement is part of a predefined library
+                  --  unit, then all interpretations which come from user level
+                  --  packages should not be considered.
+
+                  if From_Lib
+                    and then not Comes_From_Predefined_Lib_Unit (It.Nam)
+                  then
+                     goto Continue;
+                  end if;
+
                   Error_Msg_Sloc := Sloc (Seen);
                   It1 := Disambiguate (N, I1, I, Typ);
 
@@ -6335,6 +6365,22 @@ package body Sem_Res is
    --  Start of processing for Resolve_Op_Concat
 
    begin
+      --  The parser folds an enormous sequence of concatenations of string
+      --  literals into "" & "...", where the Is_Folded_In_Parser flag is set
+      --  in the right. If the expression resolves to a predefined "&"
+      --  operator, all is well. Otherwise, the parser's folding is wrong, so
+      --  we give an error. See P_Simple_Expression in Par.Ch4.
+
+      if Nkind (Op2) = N_String_Literal
+        and then Is_Folded_In_Parser (Op2)
+        and then Ekind (Entity (N)) = E_Function
+      then
+         pragma Assert (Nkind (Op1) = N_String_Literal  --  should be ""
+               and then String_Length (Strval (Op1)) = 0);
+         Error_Msg_N ("too many user-defined concatenations", N);
+         return;
+      end if;
+
       Set_Etype (N, Btyp);
 
       if Is_Limited_Composite (Btyp) then

gcc/ada/sinfo.adb

@@ -1590,6 +1590,14 @@ package body Sinfo is
       return Flag8 (N);
    end Is_Entry_Barrier_Function;
 
+   function Is_Folded_In_Parser
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_String_Literal);
+      return Flag4 (N);
+   end Is_Folded_In_Parser;
+
    function Is_In_Discriminant_Check
       (N : Node_Id) return Boolean is
    begin
@@ -4289,6 +4297,14 @@ package body Sinfo is
       Set_Flag8 (N, Val);
    end Set_Is_Entry_Barrier_Function;
 
+   procedure Set_Is_Folded_In_Parser
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_String_Literal);
+      Set_Flag4 (N, Val);
+   end Set_Is_Folded_In_Parser;
+
    procedure Set_Is_In_Discriminant_Check
       (N : Node_Id; Val : Boolean := True) is
    begin

gcc/ada/sinfo.ads

@@ -1202,11 +1202,6 @@ package Sinfo is
    --    conditions holds, and the flag is set, then the division or
    --    multiplication can be (and is) converted to a shift.
 
-   --  Is_Overloaded (Flag5-Sem)
-   --    A flag present in all expression nodes. Used temporarily during
-   --    overloading determination. The setting of this flag is not relevant
-   --    once overloading analysis is complete.
-
    --  Is_Protected_Subprogram_Body (Flag7-Sem)
    --    A flag set in a Subprogram_Body block to indicate that it is the
    --    implemenation of a protected subprogram. Such a body needs cleanup
@@ -1820,11 +1815,19 @@ package Sinfo is
 
       --  A STRING_ELEMENT is either a pair of quotation marks ("), or a
       --  single GRAPHIC_CHARACTER other than a quotation mark.
+      --
+      --  Is_Folded_In_Parser is True if the parser created this literal by
+      --  folding a sequence of "&" operators. For example, if the source code
+      --  says "aaa" & "bbb" & "ccc", and the produces "aaabbbccc", the flag is
+      --  set. This flag is needed because the parser doesn't know about
+      --  visibility, so the folded result might be wrong, and semantic
+      --  analysis needs to check for that.
 
       --  N_String_Literal
       --  Sloc points to literal
       --  Strval (Str3) contains Id of string value
       --  Has_Wide_Character (Flag11-Sem)
+      --  Is_Folded_In_Parser (Flag4)
       --  plus fields for expression
 
       ------------------
@@ -7870,6 +7873,9 @@ package Sinfo is
    function Is_Entry_Barrier_Function
      (N : Node_Id) return Boolean;    -- Flag8
 
+   function Is_Folded_In_Parser
+     (N : Node_Id) return Boolean;    -- Flag4
+
    function Is_In_Discriminant_Check
      (N : Node_Id) return Boolean;    -- Flag11
 
@@ -8725,6 +8731,9 @@ package Sinfo is
    procedure Set_Is_Entry_Barrier_Function
      (N : Node_Id; Val : Boolean := True);    -- Flag8
 
+   procedure Set_Is_Folded_In_Parser
+     (N : Node_Id; Val : Boolean := True);    -- Flag4
+
    procedure Set_Is_In_Discriminant_Check
      (N : Node_Id; Val : Boolean := True);    -- Flag11
 
@@ -10817,6 +10826,7 @@ package Sinfo is
    pragma Inline (Is_Controlling_Actual);
    pragma Inline (Is_Dynamic_Coextension);
    pragma Inline (Is_Entry_Barrier_Function);
+   pragma Inline (Is_Folded_In_Parser);
    pragma Inline (Is_In_Discriminant_Check);
    pragma Inline (Is_Machine_Number);
    pragma Inline (Is_Null_Loop);
@@ -11098,6 +11108,7 @@ package Sinfo is
    pragma Inline (Set_Is_Controlling_Actual);
    pragma Inline (Set_Is_Dynamic_Coextension);
    pragma Inline (Set_Is_Entry_Barrier_Function);
+   pragma Inline (Set_Is_Folded_In_Parser);
    pragma Inline (Set_Is_In_Discriminant_Check);
    pragma Inline (Set_Is_Machine_Number);
    pragma Inline (Set_Is_Null_Loop);

gcc/ada/trans.c

@@ -101,6 +101,11 @@ DEF_VEC_ALLOC_P(parm_attr,gc);
 
 struct language_function GTY(())
 {
+/* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca, for
+   fear of running out of stack space. If we need more, we use xmalloc/free
+   instead. */
+#define ALLOCA_THRESHOLD 1000
+
   VEC(parm_attr,gc) *parm_attr_cache;
 };
 
@@ -2508,6 +2513,8 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
 					  build_call_0_expr (get_jmpbuf_decl),
 					  false, false, false, false, NULL,
 					  gnat_node);
+      DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
+
       /* The __builtin_setjmp receivers will immediately reinstall it.  Now
 	 because of the unstructured form of EH used by setjmp_longjmp, there
 	 might be forward edges going to __builtin_setjmp receivers on which
@@ -2517,6 +2524,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
 					 NULL_TREE, jmpbuf_type,
 					 NULL_TREE, false, false, false, false,
 					 NULL, gnat_node);
+      DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
 
       set_block_jmpbuf_decl (gnu_jmpbuf_decl);
 
@@ -3118,8 +3126,12 @@ gnat_to_gnu (Node_Id gnat_node)
 	{
 	  String_Id gnat_string = Strval (gnat_node);
 	  int length = String_Length (gnat_string);
-	  char *string = (char *) alloca (length + 1);
 	  int i;
+	  char *string;
+	  if (length >= ALLOCA_THRESHOLD)
+             string = xmalloc (length + 1); /* in case of large strings */
+          else
+             string = (char *) alloca (length + 1);
 
 	  /* Build the string with the characters in the literal.  Note
 	     that Ada strings are 1-origin.  */
@@ -3135,6 +3147,9 @@ gnat_to_gnu (Node_Id gnat_node)
 	  /* Strings in GCC don't normally have types, but we want
 	     this to not be converted to the array type.  */
 	  TREE_TYPE (gnu_result) = gnu_result_type;
+
+	  if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */
+             free (string);
 	}
       else
 	{

gcc/ada/utils.c

@@ -592,7 +592,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
     = build_array_type (gnat_type_for_mode (Pmode, 0),
 			build_index_type (build_int_cst (NULL_TREE, 5)));
   create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
-		    false, true, Empty);
+		    true, true, Empty);
   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
 
   /* Functions to get and set the jumpbuf pointer for the current thread.  */