aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/sem_util.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/sem_util.adb')
-rw-r--r--gcc/ada/sem_util.adb93
1 files changed, 73 insertions, 20 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8b9dfca..5f6f464 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2119,11 +2119,37 @@ package body Sem_Util is
then
return Skip;
+ -- For now we skip aggregate discriminants since they require
+ -- performing the analysis in two phases to identify conflicts:
+ -- first one analyzing discriminants and second one analyzing
+ -- the rest of components (since at runtime discriminants are
+ -- evaluated prior to components): too much computation cost
+ -- to identify a corner case???
+
+ elsif Nkind (Parent (N)) = N_Component_Association
+ and then Nkind_In (Parent (Parent (N)),
+ N_Aggregate,
+ N_Extension_Aggregate)
+ then
+ declare
+ Choice : constant Node_Id := First (Choices (Parent (N)));
+ begin
+ if Ekind (Entity (N)) = E_Discriminant then
+ return Skip;
+
+ elsif Expression (Parent (N)) = N
+ and then Nkind (Choice) = N_Identifier
+ and then Ekind (Entity (Choice)) = E_Discriminant
+ then
+ return Skip;
+ end if;
+ end;
+
-- Analyze if N is a writable actual of a function
elsif Nkind (Parent (N)) = N_Function_Call then
declare
- Call : constant Node_Id := Parent (N);
+ Call : constant Node_Id := Parent (N);
Actual : Node_Id;
Formal : Node_Id;
@@ -2136,32 +2162,59 @@ package body Sem_Util is
return Abandon;
end if;
- Formal := First_Formal (Id);
- Actual := First_Actual (Call);
- while Present (Actual) and then Present (Formal) loop
- if Actual = N then
- if Ekind_In (Formal, E_Out_Parameter,
- E_In_Out_Parameter)
- then
- Is_Writable_Actual := True;
- end if;
+ if Ekind_In (Id, E_Function, E_Generic_Function)
+ and then Has_Out_Or_In_Out_Parameter (Id)
+ then
+ Formal := First_Formal (Id);
+ Actual := First_Actual (Call);
+ while Present (Actual) and then Present (Formal) loop
+ if Actual = N then
+ if Ekind_In (Formal, E_Out_Parameter,
+ E_In_Out_Parameter)
+ then
+ Is_Writable_Actual := True;
+ end if;
- exit;
- end if;
+ exit;
+ end if;
- Next_Formal (Formal);
- Next_Actual (Actual);
- end loop;
+ Next_Formal (Formal);
+ Next_Actual (Actual);
+ end loop;
+ end if;
end;
end if;
if Is_Writable_Actual then
if Contains (Writable_Actuals_List, N) then
- Error_Msg_NE
- ("value may be affected by call to& "
- & "because order of evaluation is arbitrary", N, Id);
- Error_Node := N;
- return Abandon;
+
+ -- Report the error on the second occurrence of the
+ -- identifier. We cannot assume that N is the second
+ -- occurrence since traverse_func walks through Field2
+ -- last (see comment in the body of traverse_func).
+
+ declare
+ Elmt : Elmt_Id := First_Elmt (Writable_Actuals_List);
+
+ begin
+ while Present (Elmt)
+ and then Entity (Node (Elmt)) /= Entity (N)
+ loop
+ Next_Elmt (Elmt);
+ end loop;
+
+ if Sloc (N) > Sloc (Node (Elmt)) then
+ Error_Node := N;
+ else
+ Error_Node := Node (Elmt);
+ end if;
+
+ Error_Msg_NE
+ ("value may be affected by call to& "
+ & "because order of evaluation is arbitrary",
+ Error_Node, Id);
+ return Abandon;
+ end;
end if;
Append_New_Elmt (N, To => Writable_Actuals_List);