Commit dae2b8ea by Hristian Kirtchev Committed by Arnaud Charlet

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
parent ace980d5
...@@ -37,6 +37,7 @@ with Exp_Ch6; use Exp_Ch6; ...@@ -37,6 +37,7 @@ with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze; with Freeze; use Freeze;
with Itypes; use Itypes; with Itypes; use Itypes;
with Lib; use Lib; with Lib; use Lib;
...@@ -1546,16 +1547,21 @@ package body Sem_Res is ...@@ -1546,16 +1547,21 @@ package body Sem_Res is
------------- -------------
procedure Resolve (N : Node_Id; Typ : Entity_Id) 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; I : Interp_Index;
I1 : Interp_Index := 0; -- prevent junk warning I1 : Interp_Index := 0; -- prevent junk warning
It : Interp; It : Interp;
It1 : Interp; It1 : Interp;
Found : Boolean := False;
Seen : Entity_Id := Empty; -- prevent junk warning Seen : Entity_Id := Empty; -- prevent junk warning
Ctx_Type : Entity_Id := Typ;
Expr_Type : Entity_Id := Empty; -- prevent junk warning function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
Err_Type : Entity_Id := Empty; -- Determine whether a node comes from a predefined library unit or
Ambiguous : Boolean := False; -- Standard.
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
-- Try and fix up a literal so that it matches its expected type. New -- Try and fix up a literal so that it matches its expected type. New
...@@ -1564,6 +1570,18 @@ package body Sem_Res is ...@@ -1564,6 +1570,18 @@ package body Sem_Res is
procedure Resolution_Failed; procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails -- 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 -- -- Patch_Up_Value --
-------------------- --------------------
...@@ -1660,6 +1678,8 @@ package body Sem_Res is ...@@ -1660,6 +1678,8 @@ package body Sem_Res is
("prefix must statically denote a non-remote subprogram", N); ("prefix must statically denote a non-remote subprogram", N);
end if; end if;
From_Lib := Comes_From_Predefined_Lib_Unit (N);
-- If the context is a Remote_Access_To_Subprogram, access attributes -- If the context is a Remote_Access_To_Subprogram, access attributes
-- must be resolved with the corresponding fat pointer. There is no need -- must be resolved with the corresponding fat pointer. There is no need
-- to check for the attribute name since the return type of an -- to check for the attribute name since the return type of an
...@@ -1817,6 +1837,16 @@ package body Sem_Res is ...@@ -1817,6 +1837,16 @@ package body Sem_Res is
-- some more obscure cases are handled in Disambiguate. -- some more obscure cases are handled in Disambiguate.
else 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); Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ); It1 := Disambiguate (N, I1, I, Typ);
...@@ -6335,6 +6365,22 @@ package body Sem_Res is ...@@ -6335,6 +6365,22 @@ package body Sem_Res is
-- Start of processing for Resolve_Op_Concat -- Start of processing for Resolve_Op_Concat
begin 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); Set_Etype (N, Btyp);
if Is_Limited_Composite (Btyp) then if Is_Limited_Composite (Btyp) then
......
...@@ -1590,6 +1590,14 @@ package body Sinfo is ...@@ -1590,6 +1590,14 @@ package body Sinfo is
return Flag8 (N); return Flag8 (N);
end Is_Entry_Barrier_Function; 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 function Is_In_Discriminant_Check
(N : Node_Id) return Boolean is (N : Node_Id) return Boolean is
begin begin
...@@ -4289,6 +4297,14 @@ package body Sinfo is ...@@ -4289,6 +4297,14 @@ package body Sinfo is
Set_Flag8 (N, Val); Set_Flag8 (N, Val);
end Set_Is_Entry_Barrier_Function; 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 procedure Set_Is_In_Discriminant_Check
(N : Node_Id; Val : Boolean := True) is (N : Node_Id; Val : Boolean := True) is
begin begin
......
...@@ -1202,11 +1202,6 @@ package Sinfo is ...@@ -1202,11 +1202,6 @@ package Sinfo is
-- conditions holds, and the flag is set, then the division or -- conditions holds, and the flag is set, then the division or
-- multiplication can be (and is) converted to a shift. -- 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) -- Is_Protected_Subprogram_Body (Flag7-Sem)
-- A flag set in a Subprogram_Body block to indicate that it is the -- A flag set in a Subprogram_Body block to indicate that it is the
-- implemenation of a protected subprogram. Such a body needs cleanup -- implemenation of a protected subprogram. Such a body needs cleanup
...@@ -1820,11 +1815,19 @@ package Sinfo is ...@@ -1820,11 +1815,19 @@ package Sinfo is
-- A STRING_ELEMENT is either a pair of quotation marks ("), or a -- A STRING_ELEMENT is either a pair of quotation marks ("), or a
-- single GRAPHIC_CHARACTER other than a quotation mark. -- 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 -- N_String_Literal
-- Sloc points to literal -- Sloc points to literal
-- Strval (Str3) contains Id of string value -- Strval (Str3) contains Id of string value
-- Has_Wide_Character (Flag11-Sem) -- Has_Wide_Character (Flag11-Sem)
-- Is_Folded_In_Parser (Flag4)
-- plus fields for expression -- plus fields for expression
------------------ ------------------
...@@ -7870,6 +7873,9 @@ package Sinfo is ...@@ -7870,6 +7873,9 @@ package Sinfo is
function Is_Entry_Barrier_Function function Is_Entry_Barrier_Function
(N : Node_Id) return Boolean; -- Flag8 (N : Node_Id) return Boolean; -- Flag8
function Is_Folded_In_Parser
(N : Node_Id) return Boolean; -- Flag4
function Is_In_Discriminant_Check function Is_In_Discriminant_Check
(N : Node_Id) return Boolean; -- Flag11 (N : Node_Id) return Boolean; -- Flag11
...@@ -8725,6 +8731,9 @@ package Sinfo is ...@@ -8725,6 +8731,9 @@ package Sinfo is
procedure Set_Is_Entry_Barrier_Function procedure Set_Is_Entry_Barrier_Function
(N : Node_Id; Val : Boolean := True); -- Flag8 (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 procedure Set_Is_In_Discriminant_Check
(N : Node_Id; Val : Boolean := True); -- Flag11 (N : Node_Id; Val : Boolean := True); -- Flag11
...@@ -10817,6 +10826,7 @@ package Sinfo is ...@@ -10817,6 +10826,7 @@ package Sinfo is
pragma Inline (Is_Controlling_Actual); pragma Inline (Is_Controlling_Actual);
pragma Inline (Is_Dynamic_Coextension); pragma Inline (Is_Dynamic_Coextension);
pragma Inline (Is_Entry_Barrier_Function); pragma Inline (Is_Entry_Barrier_Function);
pragma Inline (Is_Folded_In_Parser);
pragma Inline (Is_In_Discriminant_Check); pragma Inline (Is_In_Discriminant_Check);
pragma Inline (Is_Machine_Number); pragma Inline (Is_Machine_Number);
pragma Inline (Is_Null_Loop); pragma Inline (Is_Null_Loop);
...@@ -11098,6 +11108,7 @@ package Sinfo is ...@@ -11098,6 +11108,7 @@ package Sinfo is
pragma Inline (Set_Is_Controlling_Actual); pragma Inline (Set_Is_Controlling_Actual);
pragma Inline (Set_Is_Dynamic_Coextension); pragma Inline (Set_Is_Dynamic_Coextension);
pragma Inline (Set_Is_Entry_Barrier_Function); 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_In_Discriminant_Check);
pragma Inline (Set_Is_Machine_Number); pragma Inline (Set_Is_Machine_Number);
pragma Inline (Set_Is_Null_Loop); pragma Inline (Set_Is_Null_Loop);
......
...@@ -101,6 +101,11 @@ DEF_VEC_ALLOC_P(parm_attr,gc); ...@@ -101,6 +101,11 @@ DEF_VEC_ALLOC_P(parm_attr,gc);
struct language_function GTY(()) 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; VEC(parm_attr,gc) *parm_attr_cache;
}; };
...@@ -2508,6 +2513,8 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) ...@@ -2508,6 +2513,8 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
build_call_0_expr (get_jmpbuf_decl), build_call_0_expr (get_jmpbuf_decl),
false, false, false, false, NULL, false, false, false, false, NULL,
gnat_node); gnat_node);
DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
/* The __builtin_setjmp receivers will immediately reinstall it. Now /* The __builtin_setjmp receivers will immediately reinstall it. Now
because of the unstructured form of EH used by setjmp_longjmp, there because of the unstructured form of EH used by setjmp_longjmp, there
might be forward edges going to __builtin_setjmp receivers on which 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) ...@@ -2517,6 +2524,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
NULL_TREE, jmpbuf_type, NULL_TREE, jmpbuf_type,
NULL_TREE, false, false, false, false, NULL_TREE, false, false, false, false,
NULL, gnat_node); NULL, gnat_node);
DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
set_block_jmpbuf_decl (gnu_jmpbuf_decl); set_block_jmpbuf_decl (gnu_jmpbuf_decl);
...@@ -3118,8 +3126,12 @@ gnat_to_gnu (Node_Id gnat_node) ...@@ -3118,8 +3126,12 @@ gnat_to_gnu (Node_Id gnat_node)
{ {
String_Id gnat_string = Strval (gnat_node); String_Id gnat_string = Strval (gnat_node);
int length = String_Length (gnat_string); int length = String_Length (gnat_string);
char *string = (char *) alloca (length + 1);
int i; 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 /* Build the string with the characters in the literal. Note
that Ada strings are 1-origin. */ that Ada strings are 1-origin. */
...@@ -3135,6 +3147,9 @@ gnat_to_gnu (Node_Id gnat_node) ...@@ -3135,6 +3147,9 @@ gnat_to_gnu (Node_Id gnat_node)
/* Strings in GCC don't normally have types, but we want /* Strings in GCC don't normally have types, but we want
this to not be converted to the array type. */ this to not be converted to the array type. */
TREE_TYPE (gnu_result) = gnu_result_type; TREE_TYPE (gnu_result) = gnu_result_type;
if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */
free (string);
} }
else else
{ {
......
...@@ -592,7 +592,7 @@ init_gigi_decls (tree long_long_float_type, tree exception_type) ...@@ -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_array_type (gnat_type_for_mode (Pmode, 0),
build_index_type (build_int_cst (NULL_TREE, 5))); build_index_type (build_int_cst (NULL_TREE, 5)));
create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL, create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
false, true, Empty); true, true, Empty);
jmpbuf_ptr_type = build_pointer_type (jmpbuf_type); jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
/* Functions to get and set the jumpbuf pointer for the current thread. */ /* Functions to get and set the jumpbuf pointer for the current thread. */
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment