atree.ads, atree.adb (Traverse_Func): Walk Field2 last, and eliminate the resulting tail recursion by hand.
2007-12-19 Bob Duff <duff@adacore.com> * atree.ads, atree.adb (Traverse_Func): Walk Field2 last, and eliminate the resulting tail recursion by hand. This prevents running out of memory on deeply nested concatenations, since Field2 is where the left operand of concatenations is stored. Fix bug (was returning OK_Orig in some cases). Fix return subtype to clarify that it can only return OK or Abandon. * sem_res.adb (Resolve_Op_Concat): Replace the recursion on the left operand by iteration, in order to avoid running out of memory on deeply-nested concatenations. Use the Parent pointer to get back up the tree. (Resolve_Op_Concat_Arg, Resolve_Op_Concat_First, Resolve_Op_Concat_Rest): New procedures split out of Resolve_Op_Concat, so the iterative algorithm in Resolve_Op_Concat is clearer. * checks.adb (Remove_Checks): Use Traverse_Proc instead of Traverse_Func, because the former already takes care of discarding the result. * errout.adb (First_Node): Use Traverse_Proc instead of Traverse_Func, because the former already takes care of discarding the result. (Remove_Warning_Messages): Use appropriate subtype for Status and Discard From-SVN: r131070
This commit is contained in:
parent
160df97907
commit
10303118b3
|
@ -2624,12 +2624,12 @@ package body Atree is
|
||||||
-- Traverse_Func --
|
-- Traverse_Func --
|
||||||
-------------------
|
-------------------
|
||||||
|
|
||||||
function Traverse_Func (Node : Node_Id) return Traverse_Result is
|
function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is
|
||||||
|
|
||||||
function Traverse_Field
|
function Traverse_Field
|
||||||
(Nod : Node_Id;
|
(Nod : Node_Id;
|
||||||
Fld : Union_Id;
|
Fld : Union_Id;
|
||||||
FN : Field_Num) return Traverse_Result;
|
FN : Field_Num) return Traverse_Final_Result;
|
||||||
-- Fld is one of the fields of Nod. If the field points to syntactic
|
-- Fld is one of the fields of Nod. If the field points to syntactic
|
||||||
-- node or list, then this node or list is traversed, and the result is
|
-- node or list, then this node or list is traversed, and the result is
|
||||||
-- the result of this traversal. Otherwise a value of True is returned
|
-- the result of this traversal. Otherwise a value of True is returned
|
||||||
|
@ -2642,7 +2642,7 @@ package body Atree is
|
||||||
function Traverse_Field
|
function Traverse_Field
|
||||||
(Nod : Node_Id;
|
(Nod : Node_Id;
|
||||||
Fld : Union_Id;
|
Fld : Union_Id;
|
||||||
FN : Field_Num) return Traverse_Result
|
FN : Field_Num) return Traverse_Final_Result
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if Fld = Union_Id (Empty) then
|
if Fld = Union_Id (Empty) then
|
||||||
|
@ -2697,10 +2697,21 @@ package body Atree is
|
||||||
end if;
|
end if;
|
||||||
end Traverse_Field;
|
end Traverse_Field;
|
||||||
|
|
||||||
|
Cur_Node : Node_Id := Node;
|
||||||
|
|
||||||
-- Start of processing for Traverse_Func
|
-- Start of processing for Traverse_Func
|
||||||
|
|
||||||
begin
|
begin
|
||||||
case Process (Node) is
|
-- We walk Field2 last, and if it is a node, we eliminate the tail
|
||||||
|
-- recursion by jumping back to this label. This is because Field2 is
|
||||||
|
-- where the Left_Opnd field of N_Op_Concat is stored, and in practice
|
||||||
|
-- concatenations are sometimes deeply nested, as in X1&X2&...&XN. This
|
||||||
|
-- trick prevents us from running out of memory in that case. We don't
|
||||||
|
-- bother eliminating the tail recursion if Field2 is a list.
|
||||||
|
|
||||||
|
<<Tail_Recurse>>
|
||||||
|
|
||||||
|
case Process (Cur_Node) is
|
||||||
when Abandon =>
|
when Abandon =>
|
||||||
return Abandon;
|
return Abandon;
|
||||||
|
|
||||||
|
@ -2708,41 +2719,37 @@ package body Atree is
|
||||||
return OK;
|
return OK;
|
||||||
|
|
||||||
when OK =>
|
when OK =>
|
||||||
if Traverse_Field (Node, Union_Id (Field1 (Node)), 1) = Abandon
|
null;
|
||||||
or else
|
|
||||||
Traverse_Field (Node, Union_Id (Field2 (Node)), 2) = Abandon
|
|
||||||
or else
|
|
||||||
Traverse_Field (Node, Union_Id (Field3 (Node)), 3) = Abandon
|
|
||||||
or else
|
|
||||||
Traverse_Field (Node, Union_Id (Field4 (Node)), 4) = Abandon
|
|
||||||
or else
|
|
||||||
Traverse_Field (Node, Union_Id (Field5 (Node)), 5) = Abandon
|
|
||||||
then
|
|
||||||
return Abandon;
|
|
||||||
else
|
|
||||||
return OK;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
when OK_Orig =>
|
when OK_Orig =>
|
||||||
declare
|
Cur_Node := Original_Node (Cur_Node);
|
||||||
Onod : constant Node_Id := Original_Node (Node);
|
|
||||||
begin
|
|
||||||
if Traverse_Field (Onod, Union_Id (Field1 (Onod)), 1) = Abandon
|
|
||||||
or else
|
|
||||||
Traverse_Field (Onod, Union_Id (Field2 (Onod)), 2) = Abandon
|
|
||||||
or else
|
|
||||||
Traverse_Field (Onod, Union_Id (Field3 (Onod)), 3) = Abandon
|
|
||||||
or else
|
|
||||||
Traverse_Field (Onod, Union_Id (Field4 (Onod)), 4) = Abandon
|
|
||||||
or else
|
|
||||||
Traverse_Field (Onod, Union_Id (Field5 (Onod)), 5) = Abandon
|
|
||||||
then
|
|
||||||
return Abandon;
|
|
||||||
else
|
|
||||||
return OK_Orig;
|
|
||||||
end if;
|
|
||||||
end;
|
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
|
if Traverse_Field (Cur_Node, Field1 (Cur_Node), 1) = Abandon
|
||||||
|
or else -- skip Field2 here
|
||||||
|
Traverse_Field (Cur_Node, Field3 (Cur_Node), 3) = Abandon
|
||||||
|
or else
|
||||||
|
Traverse_Field (Cur_Node, Field4 (Cur_Node), 4) = Abandon
|
||||||
|
or else
|
||||||
|
Traverse_Field (Cur_Node, Field5 (Cur_Node), 5) = Abandon
|
||||||
|
then
|
||||||
|
return Abandon;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
if Field2 (Cur_Node) not in Node_Range then
|
||||||
|
return Traverse_Field (Cur_Node, Field2 (Cur_Node), 2);
|
||||||
|
elsif Is_Syntactic_Field (Nkind (Cur_Node), 2) and then
|
||||||
|
Field2 (Cur_Node) /= Empty_List_Or_Node
|
||||||
|
then
|
||||||
|
-- Here is the tail recursion step, we reset Cur_Node and jump
|
||||||
|
-- back to the start of the procedure, which has the same
|
||||||
|
-- semantic effect as a call.
|
||||||
|
|
||||||
|
Cur_Node := Node_Id (Field2 (Cur_Node));
|
||||||
|
goto Tail_Recurse;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return OK;
|
||||||
end Traverse_Func;
|
end Traverse_Func;
|
||||||
|
|
||||||
-------------------
|
-------------------
|
||||||
|
@ -2751,7 +2758,7 @@ package body Atree is
|
||||||
|
|
||||||
procedure Traverse_Proc (Node : Node_Id) is
|
procedure Traverse_Proc (Node : Node_Id) is
|
||||||
function Traverse is new Traverse_Func (Process);
|
function Traverse is new Traverse_Func (Process);
|
||||||
Discard : Traverse_Result;
|
Discard : Traverse_Final_Result;
|
||||||
pragma Warnings (Off, Discard);
|
pragma Warnings (Off, Discard);
|
||||||
begin
|
begin
|
||||||
Discard := Traverse (Node);
|
Discard := Traverse (Node);
|
||||||
|
|
|
@ -503,18 +503,22 @@ package Atree is
|
||||||
-- function is used only by Sinfo.CN to change nodes into their
|
-- function is used only by Sinfo.CN to change nodes into their
|
||||||
-- corresponding entities.
|
-- corresponding entities.
|
||||||
|
|
||||||
type Traverse_Result is (OK, OK_Orig, Skip, Abandon);
|
type Traverse_Result is (Abandon, OK, OK_Orig, Skip);
|
||||||
-- This is the type of the result returned by the Process function passed
|
-- This is the type of the result returned by the Process function passed
|
||||||
-- to Traverse_Func and Traverse_Proc and also the type of the result of
|
-- to Traverse_Func and Traverse_Proc. See below for details.
|
||||||
-- Traverse_Func itself. See descriptions below for details.
|
|
||||||
|
subtype Traverse_Final_Result is Traverse_Result range Abandon .. OK;
|
||||||
|
-- This is the type of the final result returned Traverse_Func, based on
|
||||||
|
-- the results of Process calls. See below for details.
|
||||||
|
|
||||||
generic
|
generic
|
||||||
with function Process (N : Node_Id) return Traverse_Result is <>;
|
with function Process (N : Node_Id) return Traverse_Result is <>;
|
||||||
function Traverse_Func (Node : Node_Id) return Traverse_Result;
|
function Traverse_Func (Node : Node_Id) return Traverse_Final_Result;
|
||||||
-- This is a generic function that, given the parent node for a subtree,
|
-- This is a generic function that, given the parent node for a subtree,
|
||||||
-- traverses all syntactic nodes of this tree, calling the given function
|
-- traverses all syntactic nodes of this tree, calling the given function
|
||||||
-- Process on each one. The traversal is controlled as follows by the
|
-- Process on each one, in pre order (i.e. top-down). The order of
|
||||||
-- result returned by Process:
|
-- traversing subtrees is arbitrary. The traversal is controlled as follows
|
||||||
|
-- by the result returned by Process:
|
||||||
|
|
||||||
-- OK The traversal continues normally with the syntactic
|
-- OK The traversal continues normally with the syntactic
|
||||||
-- children of the node just processed.
|
-- children of the node just processed.
|
||||||
|
@ -537,7 +541,7 @@ package Atree is
|
||||||
with function Process (N : Node_Id) return Traverse_Result is <>;
|
with function Process (N : Node_Id) return Traverse_Result is <>;
|
||||||
procedure Traverse_Proc (Node : Node_Id);
|
procedure Traverse_Proc (Node : Node_Id);
|
||||||
pragma Inline (Traverse_Proc);
|
pragma Inline (Traverse_Proc);
|
||||||
-- This is similar to Traverse_Func except that no result is returned,
|
-- This is the same as Traverse_Func except that no result is returned,
|
||||||
-- i.e. Traverse_Func is called and the result is simply discarded.
|
-- i.e. Traverse_Func is called and the result is simply discarded.
|
||||||
|
|
||||||
---------------------------
|
---------------------------
|
||||||
|
|
|
@ -2360,7 +2360,6 @@ package body Checks is
|
||||||
Analyze_And_Resolve (N, Typ);
|
Analyze_And_Resolve (N, Typ);
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
end Apply_Universal_Integer_Attribute_Checks;
|
end Apply_Universal_Integer_Attribute_Checks;
|
||||||
|
|
||||||
-------------------------------
|
-------------------------------
|
||||||
|
@ -5366,14 +5365,11 @@ package body Checks is
|
||||||
-------------------
|
-------------------
|
||||||
|
|
||||||
procedure Remove_Checks (Expr : Node_Id) is
|
procedure Remove_Checks (Expr : Node_Id) is
|
||||||
Discard : Traverse_Result;
|
|
||||||
pragma Warnings (Off, Discard);
|
|
||||||
|
|
||||||
function Process (N : Node_Id) return Traverse_Result;
|
function Process (N : Node_Id) return Traverse_Result;
|
||||||
-- Process a single node during the traversal
|
-- Process a single node during the traversal
|
||||||
|
|
||||||
function Traverse is new Traverse_Func (Process);
|
procedure Traverse is new Traverse_Proc (Process);
|
||||||
-- The traversal function itself
|
-- The traversal procedure itself
|
||||||
|
|
||||||
-------------
|
-------------
|
||||||
-- Process --
|
-- Process --
|
||||||
|
@ -5389,7 +5385,7 @@ package body Checks is
|
||||||
|
|
||||||
case Nkind (N) is
|
case Nkind (N) is
|
||||||
when N_And_Then =>
|
when N_And_Then =>
|
||||||
Discard := Traverse (Left_Opnd (N));
|
Traverse (Left_Opnd (N));
|
||||||
return Skip;
|
return Skip;
|
||||||
|
|
||||||
when N_Attribute_Reference =>
|
when N_Attribute_Reference =>
|
||||||
|
@ -5425,7 +5421,7 @@ package body Checks is
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
when N_Or_Else =>
|
when N_Or_Else =>
|
||||||
Discard := Traverse (Left_Opnd (N));
|
Traverse (Left_Opnd (N));
|
||||||
return Skip;
|
return Skip;
|
||||||
|
|
||||||
when N_Selected_Component =>
|
when N_Selected_Component =>
|
||||||
|
@ -5446,7 +5442,7 @@ package body Checks is
|
||||||
-- Start of processing for Remove_Checks
|
-- Start of processing for Remove_Checks
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Discard := Traverse (Expr);
|
Traverse (Expr);
|
||||||
end Remove_Checks;
|
end Remove_Checks;
|
||||||
|
|
||||||
----------------------------
|
----------------------------
|
||||||
|
|
|
@ -1235,15 +1235,12 @@ package body Errout is
|
||||||
Sfile : constant Source_File_Index := Get_Source_File_Index (L);
|
Sfile : constant Source_File_Index := Get_Source_File_Index (L);
|
||||||
Earliest : Node_Id;
|
Earliest : Node_Id;
|
||||||
Eloc : Source_Ptr;
|
Eloc : Source_Ptr;
|
||||||
Discard : Traverse_Result;
|
|
||||||
|
|
||||||
pragma Warnings (Off, Discard);
|
|
||||||
|
|
||||||
function Test_Earlier (N : Node_Id) return Traverse_Result;
|
function Test_Earlier (N : Node_Id) return Traverse_Result;
|
||||||
-- Function applied to every node in the construct
|
-- Function applied to every node in the construct
|
||||||
|
|
||||||
function Search_Tree_First is new Traverse_Func (Test_Earlier);
|
procedure Search_Tree_First is new Traverse_Proc (Test_Earlier);
|
||||||
-- Create traversal function
|
-- Create traversal procedure
|
||||||
|
|
||||||
------------------
|
------------------
|
||||||
-- Test_Earlier --
|
-- Test_Earlier --
|
||||||
|
@ -1273,7 +1270,7 @@ package body Errout is
|
||||||
begin
|
begin
|
||||||
Earliest := Original_Node (C);
|
Earliest := Original_Node (C);
|
||||||
Eloc := Sloc (Earliest);
|
Eloc := Sloc (Earliest);
|
||||||
Discard := Search_Tree_First (Original_Node (C));
|
Search_Tree_First (Original_Node (C));
|
||||||
return Earliest;
|
return Earliest;
|
||||||
end First_Node;
|
end First_Node;
|
||||||
|
|
||||||
|
@ -1982,7 +1979,7 @@ package body Errout is
|
||||||
-- to the tree is harmless.
|
-- to the tree is harmless.
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Status : Traverse_Result;
|
Status : Traverse_Final_Result;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Is_List_Member (N) then
|
if Is_List_Member (N) then
|
||||||
|
@ -2006,7 +2003,7 @@ package body Errout is
|
||||||
begin
|
begin
|
||||||
if Warnings_Detected /= 0 then
|
if Warnings_Detected /= 0 then
|
||||||
declare
|
declare
|
||||||
Discard : Traverse_Result;
|
Discard : Traverse_Final_Result;
|
||||||
pragma Warnings (Off, Discard);
|
pragma Warnings (Off, Discard);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -131,6 +131,23 @@ package body Sem_Res is
|
||||||
-- of the task, it must be replaced with a reference to the discriminant
|
-- of the task, it must be replaced with a reference to the discriminant
|
||||||
-- of the task being called.
|
-- of the task being called.
|
||||||
|
|
||||||
|
procedure Resolve_Op_Concat_Arg
|
||||||
|
(N : Node_Id;
|
||||||
|
Arg : Node_Id;
|
||||||
|
Typ : Entity_Id;
|
||||||
|
Is_Comp : Boolean);
|
||||||
|
-- Internal procedure for Resolve_Op_Concat to resolve one operand of
|
||||||
|
-- concatenation operator. The operand is either of the array type or of
|
||||||
|
-- the component type. If the operand is an aggregate, and the component
|
||||||
|
-- type is composite, this is ambiguous if component type has aggregates.
|
||||||
|
|
||||||
|
procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id);
|
||||||
|
-- Does the first part of the work of Resolve_Op_Concat
|
||||||
|
|
||||||
|
procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id);
|
||||||
|
-- Does the "rest" of the work of Resolve_Op_Concat, after the left operand
|
||||||
|
-- has been resolved. See Resolve_Op_Concat for details.
|
||||||
|
|
||||||
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id);
|
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id);
|
||||||
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id);
|
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id);
|
||||||
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id);
|
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id);
|
||||||
|
@ -6354,116 +6371,167 @@ package body Sem_Res is
|
||||||
-----------------------
|
-----------------------
|
||||||
|
|
||||||
procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
|
procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
|
||||||
|
|
||||||
|
-- We wish to avoid deep recursion, because concatenations are often
|
||||||
|
-- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
|
||||||
|
-- operands nonrecursively until we find something that is not a simple
|
||||||
|
-- concatenation (A in this case). We resolve that, and then walk back
|
||||||
|
-- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest
|
||||||
|
-- to do the rest of the work at each level. The Parent pointers allow
|
||||||
|
-- us to avoid recursion, and thus avoid running out of memory. See also
|
||||||
|
-- Sem_Ch4.Analyze_Concatenation, where a similar hack is used.
|
||||||
|
|
||||||
|
NN : Node_Id := N;
|
||||||
|
Op1 : Node_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
-- The following code is equivalent to:
|
||||||
|
|
||||||
|
-- Resolve_Op_Concat_First (NN, Typ);
|
||||||
|
-- Resolve_Op_Concat_Arg (N, ...);
|
||||||
|
-- Resolve_Op_Concat_Rest (N, Typ);
|
||||||
|
|
||||||
|
-- where the Resolve_Op_Concat_Arg call recurses back here if the left
|
||||||
|
-- operand is a concatenation.
|
||||||
|
|
||||||
|
-- Walk down left operands
|
||||||
|
|
||||||
|
loop
|
||||||
|
Resolve_Op_Concat_First (NN, Typ);
|
||||||
|
Op1 := Left_Opnd (NN);
|
||||||
|
exit when not (Nkind (Op1) = N_Op_Concat
|
||||||
|
and then not Is_Array_Type (Component_Type (Typ))
|
||||||
|
and then Entity (Op1) = Entity (NN));
|
||||||
|
NN := Op1;
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
-- Now (given the above example) NN is A&B and Op1 is A
|
||||||
|
|
||||||
|
-- First resolve Op1 ...
|
||||||
|
|
||||||
|
Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN));
|
||||||
|
|
||||||
|
-- ... then walk NN back up until we reach N (where we started), calling
|
||||||
|
-- Resolve_Op_Concat_Rest along the way.
|
||||||
|
|
||||||
|
loop
|
||||||
|
Resolve_Op_Concat_Rest (NN, Typ);
|
||||||
|
exit when NN = N;
|
||||||
|
NN := Parent (NN);
|
||||||
|
end loop;
|
||||||
|
end Resolve_Op_Concat;
|
||||||
|
|
||||||
|
---------------------------
|
||||||
|
-- Resolve_Op_Concat_Arg --
|
||||||
|
---------------------------
|
||||||
|
|
||||||
|
procedure Resolve_Op_Concat_Arg
|
||||||
|
(N : Node_Id;
|
||||||
|
Arg : Node_Id;
|
||||||
|
Typ : Entity_Id;
|
||||||
|
Is_Comp : Boolean)
|
||||||
|
is
|
||||||
Btyp : constant Entity_Id := Base_Type (Typ);
|
Btyp : constant Entity_Id := Base_Type (Typ);
|
||||||
Op1 : constant Node_Id := Left_Opnd (N);
|
|
||||||
Op2 : constant Node_Id := Right_Opnd (N);
|
|
||||||
|
|
||||||
procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
|
|
||||||
-- Internal procedure to resolve one operand of concatenation operator.
|
|
||||||
-- The operand is either of the array type or of the component type.
|
|
||||||
-- If the operand is an aggregate, and the component type is composite,
|
|
||||||
-- this is ambiguous if component type has aggregates.
|
|
||||||
|
|
||||||
-------------------------------
|
|
||||||
-- Resolve_Concatenation_Arg --
|
|
||||||
-------------------------------
|
|
||||||
|
|
||||||
procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
|
|
||||||
begin
|
|
||||||
if In_Instance then
|
|
||||||
if Is_Comp
|
|
||||||
or else (not Is_Overloaded (Arg)
|
|
||||||
and then Etype (Arg) /= Any_Composite
|
|
||||||
and then Covers (Component_Type (Typ), Etype (Arg)))
|
|
||||||
then
|
|
||||||
Resolve (Arg, Component_Type (Typ));
|
|
||||||
else
|
|
||||||
Resolve (Arg, Btyp);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
|
|
||||||
|
|
||||||
if Nkind (Arg) = N_Aggregate
|
|
||||||
and then Is_Composite_Type (Component_Type (Typ))
|
|
||||||
then
|
|
||||||
if Is_Private_Type (Component_Type (Typ)) then
|
|
||||||
Resolve (Arg, Btyp);
|
|
||||||
|
|
||||||
else
|
|
||||||
Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
|
|
||||||
Set_Etype (Arg, Any_Type);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
else
|
|
||||||
if Is_Overloaded (Arg)
|
|
||||||
and then Has_Compatible_Type (Arg, Typ)
|
|
||||||
and then Etype (Arg) /= Any_Type
|
|
||||||
then
|
|
||||||
|
|
||||||
declare
|
|
||||||
I : Interp_Index;
|
|
||||||
It : Interp;
|
|
||||||
Func : Entity_Id;
|
|
||||||
|
|
||||||
begin
|
|
||||||
Get_First_Interp (Arg, I, It);
|
|
||||||
Func := It.Nam;
|
|
||||||
Get_Next_Interp (I, It);
|
|
||||||
|
|
||||||
-- Special-case the error message when the overloading
|
|
||||||
-- is caused by a function that yields and array and
|
|
||||||
-- can be called without parameters.
|
|
||||||
|
|
||||||
if It.Nam = Func then
|
|
||||||
Error_Msg_Sloc := Sloc (Func);
|
|
||||||
Error_Msg_N ("ambiguous call to function#", Arg);
|
|
||||||
Error_Msg_NE
|
|
||||||
("\\interpretation as call yields&", Arg, Typ);
|
|
||||||
Error_Msg_NE
|
|
||||||
("\\interpretation as indexing of call yields&",
|
|
||||||
Arg, Component_Type (Typ));
|
|
||||||
|
|
||||||
else
|
|
||||||
Error_Msg_N
|
|
||||||
("ambiguous operand for concatenation!", Arg);
|
|
||||||
Get_First_Interp (Arg, I, It);
|
|
||||||
while Present (It.Nam) loop
|
|
||||||
Error_Msg_Sloc := Sloc (It.Nam);
|
|
||||||
|
|
||||||
if Base_Type (It.Typ) = Base_Type (Typ)
|
|
||||||
or else Base_Type (It.Typ) =
|
|
||||||
Base_Type (Component_Type (Typ))
|
|
||||||
then
|
|
||||||
Error_Msg_N ("\\possible interpretation#", Arg);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Get_Next_Interp (I, It);
|
|
||||||
end loop;
|
|
||||||
end if;
|
|
||||||
end;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Resolve (Arg, Component_Type (Typ));
|
|
||||||
|
|
||||||
if Nkind (Arg) = N_String_Literal then
|
|
||||||
Set_Etype (Arg, Component_Type (Typ));
|
|
||||||
end if;
|
|
||||||
|
|
||||||
if Arg = Left_Opnd (N) then
|
|
||||||
Set_Is_Component_Left_Opnd (N);
|
|
||||||
else
|
|
||||||
Set_Is_Component_Right_Opnd (N);
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
|
begin
|
||||||
|
if In_Instance then
|
||||||
|
if Is_Comp
|
||||||
|
or else (not Is_Overloaded (Arg)
|
||||||
|
and then Etype (Arg) /= Any_Composite
|
||||||
|
and then Covers (Component_Type (Typ), Etype (Arg)))
|
||||||
|
then
|
||||||
|
Resolve (Arg, Component_Type (Typ));
|
||||||
else
|
else
|
||||||
Resolve (Arg, Btyp);
|
Resolve (Arg, Btyp);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Check_Unset_Reference (Arg);
|
elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
|
||||||
end Resolve_Concatenation_Arg;
|
if Nkind (Arg) = N_Aggregate
|
||||||
|
and then Is_Composite_Type (Component_Type (Typ))
|
||||||
|
then
|
||||||
|
if Is_Private_Type (Component_Type (Typ)) then
|
||||||
|
Resolve (Arg, Btyp);
|
||||||
|
else
|
||||||
|
Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
|
||||||
|
Set_Etype (Arg, Any_Type);
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Start of processing for Resolve_Op_Concat
|
else
|
||||||
|
if Is_Overloaded (Arg)
|
||||||
|
and then Has_Compatible_Type (Arg, Typ)
|
||||||
|
and then Etype (Arg) /= Any_Type
|
||||||
|
then
|
||||||
|
declare
|
||||||
|
I : Interp_Index;
|
||||||
|
It : Interp;
|
||||||
|
Func : Entity_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Get_First_Interp (Arg, I, It);
|
||||||
|
Func := It.Nam;
|
||||||
|
Get_Next_Interp (I, It);
|
||||||
|
|
||||||
|
-- Special-case the error message when the overloading is
|
||||||
|
-- caused by a function that yields an array and can be
|
||||||
|
-- called without parameters.
|
||||||
|
|
||||||
|
if It.Nam = Func then
|
||||||
|
Error_Msg_Sloc := Sloc (Func);
|
||||||
|
Error_Msg_N ("ambiguous call to function#", Arg);
|
||||||
|
Error_Msg_NE
|
||||||
|
("\\interpretation as call yields&", Arg, Typ);
|
||||||
|
Error_Msg_NE
|
||||||
|
("\\interpretation as indexing of call yields&",
|
||||||
|
Arg, Component_Type (Typ));
|
||||||
|
|
||||||
|
else
|
||||||
|
Error_Msg_N
|
||||||
|
("ambiguous operand for concatenation!", Arg);
|
||||||
|
Get_First_Interp (Arg, I, It);
|
||||||
|
while Present (It.Nam) loop
|
||||||
|
Error_Msg_Sloc := Sloc (It.Nam);
|
||||||
|
|
||||||
|
if Base_Type (It.Typ) = Base_Type (Typ)
|
||||||
|
or else Base_Type (It.Typ) =
|
||||||
|
Base_Type (Component_Type (Typ))
|
||||||
|
then
|
||||||
|
Error_Msg_N ("\\possible interpretation#", Arg);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Get_Next_Interp (I, It);
|
||||||
|
end loop;
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Resolve (Arg, Component_Type (Typ));
|
||||||
|
|
||||||
|
if Nkind (Arg) = N_String_Literal then
|
||||||
|
Set_Etype (Arg, Component_Type (Typ));
|
||||||
|
end if;
|
||||||
|
|
||||||
|
if Arg = Left_Opnd (N) then
|
||||||
|
Set_Is_Component_Left_Opnd (N);
|
||||||
|
else
|
||||||
|
Set_Is_Component_Right_Opnd (N);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
else
|
||||||
|
Resolve (Arg, Btyp);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Check_Unset_Reference (Arg);
|
||||||
|
end Resolve_Op_Concat_Arg;
|
||||||
|
|
||||||
|
-----------------------------
|
||||||
|
-- Resolve_Op_Concat_First --
|
||||||
|
-----------------------------
|
||||||
|
|
||||||
|
procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is
|
||||||
|
Btyp : constant Entity_Id := Base_Type (Typ);
|
||||||
|
Op1 : constant Node_Id := Left_Opnd (N);
|
||||||
|
Op2 : constant Node_Id := Right_Opnd (N);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- The parser folds an enormous sequence of concatenations of string
|
-- The parser folds an enormous sequence of concatenations of string
|
||||||
|
@ -6488,30 +6556,18 @@ package body Sem_Res is
|
||||||
Error_Msg_N ("concatenation not available for limited array", N);
|
Error_Msg_N ("concatenation not available for limited array", N);
|
||||||
Explain_Limited_Type (Btyp, N);
|
Explain_Limited_Type (Btyp, N);
|
||||||
end if;
|
end if;
|
||||||
|
end Resolve_Op_Concat_First;
|
||||||
|
|
||||||
-- If the operands are themselves concatenations, resolve them as such
|
----------------------------
|
||||||
-- directly. This removes several layers of recursion and allows GNAT to
|
-- Resolve_Op_Concat_Rest --
|
||||||
-- handle larger multiple concatenations.
|
----------------------------
|
||||||
|
|
||||||
if Nkind (Op1) = N_Op_Concat
|
procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is
|
||||||
and then not Is_Array_Type (Component_Type (Typ))
|
Op1 : constant Node_Id := Left_Opnd (N);
|
||||||
and then Entity (Op1) = Entity (N)
|
Op2 : constant Node_Id := Right_Opnd (N);
|
||||||
then
|
|
||||||
Resolve_Op_Concat (Op1, Typ);
|
|
||||||
else
|
|
||||||
Resolve_Concatenation_Arg
|
|
||||||
(Op1, Is_Component_Left_Opnd (N));
|
|
||||||
end if;
|
|
||||||
|
|
||||||
if Nkind (Op2) = N_Op_Concat
|
begin
|
||||||
and then not Is_Array_Type (Component_Type (Typ))
|
Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N));
|
||||||
and then Entity (Op2) = Entity (N)
|
|
||||||
then
|
|
||||||
Resolve_Op_Concat (Op2, Typ);
|
|
||||||
else
|
|
||||||
Resolve_Concatenation_Arg
|
|
||||||
(Op2, Is_Component_Right_Opnd (N));
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Generate_Operator_Reference (N, Typ);
|
Generate_Operator_Reference (N, Typ);
|
||||||
|
|
||||||
|
@ -6520,7 +6576,7 @@ package body Sem_Res is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- If this is not a static concatenation, but the result is a
|
-- If this is not a static concatenation, but the result is a
|
||||||
-- string type (and not an array of strings) insure that static
|
-- string type (and not an array of strings) ensure that static
|
||||||
-- string operands have their subtypes properly constructed.
|
-- string operands have their subtypes properly constructed.
|
||||||
|
|
||||||
if Nkind (N) /= N_String_Literal
|
if Nkind (N) /= N_String_Literal
|
||||||
|
@ -6529,7 +6585,7 @@ package body Sem_Res is
|
||||||
Set_String_Literal_Subtype (Op1, Typ);
|
Set_String_Literal_Subtype (Op1, Typ);
|
||||||
Set_String_Literal_Subtype (Op2, Typ);
|
Set_String_Literal_Subtype (Op2, Typ);
|
||||||
end if;
|
end if;
|
||||||
end Resolve_Op_Concat;
|
end Resolve_Op_Concat_Rest;
|
||||||
|
|
||||||
----------------------
|
----------------------
|
||||||
-- Resolve_Op_Expon --
|
-- Resolve_Op_Expon --
|
||||||
|
|
Loading…
Reference in New Issue