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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127550
138bc75d-0d04-0410-961f-
82ee72b054a4
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;
-------------
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
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 --
--------------------
("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
-- 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);
-- 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
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
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
-- 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
-- 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
------------------
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
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
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);
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);
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;
};
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
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);
{
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. */
/* 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
{
= 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. */
projects / platform / upstream / linaro-gcc.git / commitdiff