Skip to content

R
riscv-gcc-1
Commit 130c236a by Thomas Quinot Committed by Arnaud Charlet
Options

sem_util.adb (Is_Aliased_View): Defend against the case where this subprogram is… 

sem_util.adb (Is_Aliased_View): Defend against the case where this subprogram is called with a parameter that...

2004-10-26  Thomas Quinot  <quinot@act-europe.fr>
	    Ed Schonberg   <schonberg@gnat.com>

	* 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
parent 65b03d7d
Showing with 31 additions and 23 deletions
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);
......
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)
return
(Is_Object (E)
and then
(Is_Aliased (E)
or else (Present (Renamed_Object (E))
and then Is_Aliased_View (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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment