diff options
Diffstat (limited to 'gcc/ada/sem_ch13.adb')
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 109 |
1 files changed, 59 insertions, 50 deletions
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 564ff0dfc0a..83d31081fac 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1360,6 +1360,8 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is + pragma Assert (Present (E)); + procedure Decorate (Asp : Node_Id; Prag : Node_Id); -- Establish linkages between an aspect and its corresponding pragma @@ -1578,6 +1580,7 @@ package body Sem_Ch13 is Ent : Node_Id; L : constant List_Id := Aspect_Specifications (N); + pragma Assert (Present (L)); Ins_Node : Node_Id := N; -- Insert pragmas/attribute definition clause after this node when no @@ -1605,8 +1608,6 @@ package body Sem_Ch13 is -- of visibility for the expression analysis. Thus, we just insert -- the pragma after the node N. - pragma Assert (Present (L)); - -- Loop through aspects Aspect := First (L); @@ -1906,9 +1907,6 @@ package body Sem_Ch13 is ----------------------------------------- procedure Analyze_Aspect_Implicit_Dereference is - Disc : Entity_Id; - Parent_Disc : Entity_Id; - begin if not Is_Type (E) or else not Has_Discriminants (E) then Error_Msg_N @@ -1924,45 +1922,56 @@ package body Sem_Ch13 is -- Missing synchronized types??? - Disc := First_Discriminant (E); - while Present (Disc) loop - if Chars (Expr) = Chars (Disc) - and then Ekind_In (Etype (Disc), - E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Type) - then - Set_Has_Implicit_Dereference (E); - Set_Has_Implicit_Dereference (Disc); - exit; - end if; + declare + Disc : Entity_Id := First_Discriminant (E); + begin + while Present (Disc) loop + if Chars (Expr) = Chars (Disc) + and then Ekind_In + (Etype (Disc), + E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Type) + then + Set_Has_Implicit_Dereference (E); + Set_Has_Implicit_Dereference (Disc); + exit; + end if; - Next_Discriminant (Disc); - end loop; + Next_Discriminant (Disc); + end loop; - -- Error if no proper access discriminant + -- Error if no proper access discriminant - if No (Disc) then - Error_Msg_NE ("not an access discriminant of&", Expr, E); - return; - end if; - end if; + if Present (Disc) then + -- For a type extension, check whether parent has + -- a reference discriminant, to verify that use is + -- proper. - -- For a type extension, check whether parent has a - -- reference discriminant, to verify that use is proper. - - if Is_Derived_Type (E) - and then Has_Discriminants (Etype (E)) - then - Parent_Disc := Get_Reference_Discriminant (Etype (E)); + if Is_Derived_Type (E) + and then Has_Discriminants (Etype (E)) + then + declare + Parent_Disc : constant Entity_Id := + Get_Reference_Discriminant (Etype (E)); + begin + if Present (Parent_Disc) + and then Corresponding_Discriminant (Disc) /= + Parent_Disc + then + Error_Msg_N + ("reference discriminant does not match " + & "discriminant of parent type", Expr); + end if; + end; + end if; - if Present (Parent_Disc) - and then Corresponding_Discriminant (Disc) /= Parent_Disc - then - Error_Msg_N - ("reference discriminant does not match discriminant " - & "of parent type", Expr); - end if; + else + Error_Msg_NE + ("not an access discriminant of&", Expr, E); + end if; + end; end if; + end Analyze_Aspect_Implicit_Dereference; ----------------------- @@ -6529,7 +6538,7 @@ package body Sem_Ch13 is Max : Uint; -- Minimum and maximum values of entries - Max_Node : Node_Id; + Max_Node : Node_Id := Empty; -- init to avoid warning -- Pointer to node for literal providing max value begin @@ -8384,7 +8393,7 @@ package body Sem_Ch13 is -- This is the expression for the result of the function. It is -- is build by connecting the component predicates with AND THEN. - Expr_M : Node_Id; + Expr_M : Node_Id := Empty; -- init to avoid warning -- This is the corresponding return expression for the Predicate_M -- function. It differs in that raise expressions are marked for -- special expansion (see Process_REs). @@ -9925,7 +9934,7 @@ package body Sem_Ch13 is -- this tagged type and the parent component. Tagged_Parent will point -- to this parent type. For all other cases, Tagged_Parent is Empty. - Parent_Last_Bit : Uint; + Parent_Last_Bit : Uint := No_Uint; -- init to avoid warning -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the -- last bit position for any field in the parent type. We only need to -- check overlap for fields starting below this point. @@ -14317,7 +14326,7 @@ package body Sem_Ch13 is if Source_Siz /= Target_Siz then Error_Msg ("?z?types for unchecked conversion have different sizes!", - Eloc); + Eloc, Act_Unit); if All_Errors_Mode then Error_Msg_Name_1 := Chars (Source); @@ -14353,17 +14362,17 @@ package body Sem_Ch13 is if Bytes_Big_Endian then Error_Msg ("\?z?target value will include ^ undefined " - & "low order bits!", Eloc); + & "low order bits!", Eloc, Act_Unit); else Error_Msg ("\?z?target value will include ^ undefined " - & "high order bits!", Eloc); + & "high order bits!", Eloc, Act_Unit); end if; else Error_Msg ("\?z?^ trailing bits of target value will be " - & "undefined!", Eloc); + & "undefined!", Eloc, Act_Unit); end if; else pragma Assert (Source_Siz > Target_Siz); @@ -14371,17 +14380,17 @@ package body Sem_Ch13 is if Bytes_Big_Endian then Error_Msg ("\?z?^ low order bits of source will be " - & "ignored!", Eloc); + & "ignored!", Eloc, Act_Unit); else Error_Msg ("\?z?^ high order bits of source will be " - & "ignored!", Eloc); + & "ignored!", Eloc, Act_Unit); end if; else Error_Msg ("\?z?^ trailing bits of source will be " - & "ignored!", Eloc); + & "ignored!", Eloc, Act_Unit); end if; end if; end if; @@ -14435,10 +14444,10 @@ package body Sem_Ch13 is Error_Msg_Node_2 := D_Source; Error_Msg ("?z?alignment of & (^) is stricter than " - & "alignment of & (^)!", Eloc); + & "alignment of & (^)!", Eloc, Act_Unit); Error_Msg ("\?z?resulting access value may have invalid " - & "alignment!", Eloc); + & "alignment!", Eloc, Act_Unit); end if; end; end if; |