From 130c236a6af56ccee2579b8d9b960d4473d8b339 Mon Sep 17 00:00:00 2001 From: Thomas Quinot Date: Wed, 27 Oct 2004 15:54:52 +0200 Subject: [PATCH] sem_util.adb (Is_Aliased_View): Defend against the case where this subprogram is called with a parameter that... 2004-10-26 Thomas Quinot Ed Schonberg * sem_util.adb (Is_Aliased_View): Defend against the case where this subprogram is called with a parameter that is not an object name. This situation arises for some cases of illegal code, which is diagnosed later, and in this case it is wrong to call Is_Aliased, as that might cause a compiler crash. (Explain_Limited_Type): Refine previous fix to include inherited components of derived types, to provide complete information. * exp_ch9.adb (Set_Privals): Set the Ekind of the actual object that is the prival for a protected object. It is necessary to mark this entity as a variable, in addition to flagging it as Aliased, because Sem_Util.Is_Aliased_View has been modified to avoid checking the Aliased flag on entities that are not objects. (Checking that flag for non-objects is erroneous and could lead to a compiler crash). From-SVN: r89674 --- gcc/ada/exp_ch9.adb | 1 + gcc/ada/sem_util.adb | 55 +++++++++++++++++++++++++------------------- 2 files changed, 32 insertions(+), 24 deletions(-) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 133bf555b9d..fc8e73020e8 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8745,6 +8745,7 @@ package body Exp_Ch9 is end loop; P_Subtype := Etype (Defining_Identifier (Obj_Decl)); + Set_Ekind (Priv, E_Variable); Set_Etype (Priv, P_Subtype); Set_Is_Aliased (Priv); Set_Object_Ref (Body_Ent, Priv); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index af36937145f..0fcad3ebcdd 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -448,7 +448,7 @@ package body Sem_Util is end loop; end if; - -- If none of the above, the actual and nominal subtypes are the same. + -- If none of the above, the actual and nominal subtypes are the same return Empty; end Build_Actual_Subtype_Of_Component; @@ -609,7 +609,7 @@ package body Sem_Util is end loop; end if; - -- If none of the above, the actual and nominal subtypes are the same. + -- If none of the above, the actual and nominal subtypes are the same return Empty; end Build_Discriminal_Subtype_Of_Component; @@ -1929,12 +1929,19 @@ package body Sem_Util is return; end if; - -- Otherwise find a limited component + -- Otherwise find a limited component. Check only components that + -- come from source, or inherited components that appear in the + -- source of the ancestor. C := First_Component (T); while Present (C) loop if Is_Limited_Type (Etype (C)) - and then Comes_From_Source (C) + and then + (Comes_From_Source (C) + or else + (Present (Original_Record_Component (C)) + and then + Comes_From_Source (Original_Record_Component (C)))) then Error_Msg_Node_2 := T; Error_Msg_NE ("\component& of type& has limited type", N, C); @@ -2106,7 +2113,7 @@ package body Sem_Util is pragma Warnings (Off, Res); function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id; - -- Compute recursively the qualified name without NUL at the end. + -- Compute recursively the qualified name without NUL at the end ---------------------------------- -- Internal_Full_Qualified_Name -- @@ -2606,7 +2613,7 @@ package body Sem_Util is end if; else - -- N is an expression, indicating a range with one value. + -- N is an expression, indicating a range with one value L := N; H := N; @@ -3153,22 +3160,22 @@ package body Sem_Util is begin if Is_Entity_Name (Obj) then - -- Shouldn't we check that we really have an object here? - -- If we do, then a-caldel.adb blows up mysteriously ??? - E := Entity (Obj); - return Is_Aliased (E) - or else (Present (Renamed_Object (E)) - and then Is_Aliased_View (Renamed_Object (E))) + return + (Is_Object (E) + and then + (Is_Aliased (E) + or else (Present (Renamed_Object (E)) + and then Is_Aliased_View (Renamed_Object (E))))) or else ((Is_Formal (E) or else Ekind (E) = E_Generic_In_Out_Parameter or else Ekind (E) = E_Generic_In_Parameter) and then Is_Tagged_Type (Etype (E))) - or else ((Ekind (E) = E_Task_Type or else - Ekind (E) = E_Protected_Type) + or else ((Ekind (E) = E_Task_Type + or else Ekind (E) = E_Protected_Type) and then In_Open_Scopes (E)) -- Current instance of type @@ -3237,7 +3244,7 @@ package body Sem_Util is -- Determines if given object has atomic components function Is_Atomic_Prefix (N : Node_Id) return Boolean; - -- If prefix is an implicit dereference, examine designated type. + -- If prefix is an implicit dereference, examine designated type function Is_Atomic_Prefix (N : Node_Id) return Boolean is begin @@ -3307,7 +3314,7 @@ package body Sem_Util is -- that depends on a discriminant. function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean; - -- Returns True if and only if Comp is declared within a variant part. + -- Returns True if and only if Comp is declared within a variant part ------------------------------ -- Has_Dependent_Constraint -- @@ -3608,7 +3615,7 @@ package body Sem_Util is if Etype (Indx) = Any_Type then return False; - -- If index is a range, use directly. + -- If index is a range, use directly elsif Nkind (Indx) = N_Range then Lbd := Low_Bound (Indx); @@ -3798,7 +3805,7 @@ package body Sem_Util is Into => Components, Report_Errors => Report_Errors); - -- Check that each component present is fully initialized. + -- Check that each component present is fully initialized Comp_Elmt := First_Elmt (Components); @@ -3984,7 +3991,7 @@ package body Sem_Util is when N_Explicit_Dereference => return True; - -- A view conversion of a tagged object is an object reference. + -- A view conversion of a tagged object is an object reference when N_Type_Conversion => return Is_Tagged_Type (Etype (Subtype_Mark (N))) @@ -4628,7 +4635,7 @@ package body Sem_Util is -- Determines if given object has volatile components function Is_Volatile_Prefix (N : Node_Id) return Boolean; - -- If prefix is an implicit dereference, examine designated type. + -- If prefix is an implicit dereference, examine designated type ------------------------ -- Is_Volatile_Prefix -- @@ -4939,7 +4946,7 @@ package body Sem_Util is begin if No (Last) then - -- Call node points to first actual in list. + -- Call node points to first actual in list Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); @@ -5012,7 +5019,7 @@ package body Sem_Util is elsif Actuals_To_Match > Formals_To_Match then - -- Too many actuals: will not work. + -- Too many actuals: will not work if Reporting then if Is_Entity_Name (Name (N)) then @@ -5442,7 +5449,7 @@ package body Sem_Util is Component := First_Entity (Btype); while Present (Component) loop - -- skip anonymous types generated by constrained components. + -- Skip anonymous types generated by constrained components if not Is_Type (Component) then P := Trace_Components (Etype (Component), True); @@ -6374,7 +6381,7 @@ package body Sem_Util is N : Node_Id := Parent (Unit_Id); begin - -- Predefined operators do not have a full function declaration. + -- Predefined operators do not have a full function declaration if Ekind (Unit_Id) = E_Operator then return N; -- 2.30.2