FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sem_attr.adb (Analyze_Attribute): In case of 'Class applied to an abstract interface type call...

Browse source 
2006-02-13  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute): In case of 'Class applied to an
	abstract interface type call analyze_and_resolve to expand the type
	conversion into the corresponding displacement of the
	reference to the base of the object.
	(Eval_Attribute, case Width): For systems where IEEE extended precision
	is supported, the maximum exponent occupies 4 decimal digits.
	(Accessibility_Message): Add '\' in 2-line warning message.
	(Resolve_Attribute): Likewise.
	(case Attribute_Access): Significantly revise checks
	for illegal access-to-subprogram Access attributes to properly enforce
	the rules of 3.10.2(32/2).
	Diagnose use of current instance with an illegal attribute.

        * sem_util.ads, sem_util.adb (Enclosing_Generic_Body): Change formal
        to a Node_Id.
        (Enclosing_Generic_Unit): New function to return a node's innermost
        enclosing generic declaration node.
        (Compile_Time_Constraint_Error): Remove '!' in warning messages.
        (Type_Access_Level): The accessibility level of anonymous acccess types
        associated with discriminants is that of the current instance of the
        type, and that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
        (Compile_Time_Constraint_Error): Handle case of conditional expression.
        (Kill_Current_Values_For_Entity): New function
        (Enter_Name): Change formal type to Entity_Id

From-SVN: r111089
This commit is contained in:
Javier Miranda 2006-02-15 10:43:54 +01:00 • committed by Arnaud Charlet
parent 9b96e234f8
commit b8dc622e9f
3 changed files with 322 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

214
gcc/ada/sem_attr.adb
View file

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -56,7 +56,6 @@ with Sem_Util; use Sem_Util;
with Stand; use Stand; with Stand; use Stand;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with Stand;
with Stringt; use Stringt; with Stringt; use Stringt;
with Targparm; use Targparm; with Targparm; use Targparm;
with Ttypes; use Ttypes; with Ttypes; use Ttypes;
@ -1151,7 +1150,7 @@ package body Sem_Attr is
end if; end if;
if Ekind (Typ) = E_Incomplete_Type if Ekind (Typ) = E_Incomplete_Type
and then not Present (Full_View (Typ)) and then No (Full_View (Typ))
then then
Error_Attr Error_Attr
("prefix of % attribute cannot be an incomplete type", P); ("prefix of % attribute cannot be an incomplete type", P);
@ -1665,11 +1664,45 @@ package body Sem_Attr is
if Is_Entity_Name (P) if Is_Entity_Name (P)
and then Present (Entity (P)) and then Present (Entity (P))
and then Is_Type (Entity (P)) and then Is_Type (Entity (P))
and then Ekind (Entity (P)) = E_Incomplete_Type
then then
P_Type := Get_Full_View (P_Type); if Ekind (Entity (P)) = E_Incomplete_Type then
Set_Entity (P, P_Type); P_Type := Get_Full_View (P_Type);
Set_Etype (P, P_Type); Set_Entity (P, P_Type);
Set_Etype (P, P_Type);
elsif Entity (P) = Current_Scope
and then Is_Record_Type (Entity (P))
then
-- Use of current instance within the type. Verify that if the
-- attribute appears within a constraint, it yields an access
-- type, other uses are illegal.
declare
Par : Node_Id;
begin
Par := Parent (N);
while Present (Par)
and then Nkind (Parent (Par)) /= N_Component_Definition
loop
Par := Parent (Par);
end loop;
if Present (Par)
and then Nkind (Par) = N_Subtype_Indication
then
if Attr_Id /= Attribute_Access
and then Attr_Id /= Attribute_Unchecked_Access
and then Attr_Id /= Attribute_Unrestricted_Access
then
Error_Msg_N
("in a constraint the current instance can only"
& " be used with an access attribute", N);
end if;
end if;
end;
end if;
end if; end if;
if P_Type = Any_Type then if P_Type = Any_Type then
@ -2274,6 +2307,8 @@ package body Sem_Attr is
----------- -----------
when Attribute_Class => Class : declare when Attribute_Class => Class : declare
P : constant Entity_Id := Prefix (N);
begin begin
Check_Restriction (No_Dispatch, N); Check_Restriction (No_Dispatch, N);
Check_Either_E0_Or_E1; Check_Either_E0_Or_E1;
@ -2288,12 +2323,22 @@ package body Sem_Attr is
Make_Type_Conversion (Loc, Make_Type_Conversion (Loc,
Subtype_Mark => Subtype_Mark =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix (N), Prefix => P,
Attribute_Name => Name_Class), Attribute_Name => Name_Class),
Expression => Relocate_Node (E1))); Expression => Relocate_Node (E1)));
Save_Interps (E1, Expression (N)); Save_Interps (E1, Expression (N));
Analyze (N);
if not Is_Interface (Etype (P)) then
Analyze (N);
-- Ada 2005 (AI-251): In case of abstract interfaces we have to
-- analyze and resolve the type conversion to generate the code
-- that displaces the reference to the base of the object.
else
Analyze_And_Resolve (N, Etype (P));
end if;
-- Otherwise we just need to find the proper type -- Otherwise we just need to find the proper type
@ -4725,10 +4770,10 @@ package body Sem_Attr is
then then
P_Type := Etype (P_Entity); P_Type := Etype (P_Entity);
-- If the entity is an array constant with an unconstrained -- If the entity is an array constant with an unconstrained nominal
-- nominal subtype then get the type from the initial value. -- subtype then get the type from the initial value. If the value has
-- If the value has been expanded into assignments, the expression -- been expanded into assignments, there is no expression and the
-- is not present and the attribute reference remains dynamic. -- attribute reference remains dynamic.
-- We could do better here and retrieve the type ??? -- We could do better here and retrieve the type ???
if Ekind (P_Entity) = E_Constant if Ekind (P_Entity) = E_Constant
@ -6447,7 +6492,8 @@ package body Sem_Attr is
-- nnn is set to 2 for Short_Float and Float (32 bit -- nnn is set to 2 for Short_Float and Float (32 bit
-- floats), and 3 for Long_Float and Long_Long_Float. -- floats), and 3 for Long_Float and Long_Long_Float.
-- This is not quite right, but is good enough. -- For machines where Long_Long_Float is the IEEE
-- extended precision type, the exponent takes 4 digits.
declare declare
Len : Int := Len : Int :=
@ -6456,8 +6502,10 @@ package body Sem_Attr is
begin begin
if Esize (P_Type) <= 32 then if Esize (P_Type) <= 32 then
Len := Len + 6; Len := Len + 6;
else elsif Esize (P_Type) = 64 then
Len := Len + 7; Len := Len + 7;
else
Len := Len + 8;
end if; end if;
Fold_Uint (N, UI_From_Int (Len), True); Fold_Uint (N, UI_From_Int (Len), True);
@ -6782,7 +6830,7 @@ package body Sem_Attr is
Error_Msg_N Error_Msg_N
("?non-local pointer cannot point to local object", P); ("?non-local pointer cannot point to local object", P);
Error_Msg_N Error_Msg_N
("?Program_Error will be raised at run time", P); ("\?Program_Error will be raised at run time", P);
Rewrite (N, Rewrite (N,
Make_Raise_Program_Error (Loc, Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed)); Reason => PE_Accessibility_Check_Failed));
@ -6953,49 +7001,115 @@ package body Sem_Attr is
elsif Aname = Name_Unrestricted_Access then elsif Aname = Name_Unrestricted_Access then
null; -- Nothing to check null; -- Nothing to check
-- Check the static accessibility rule of 3.10.2(32) -- Check the static accessibility rule of 3.10.2(32).
-- In an instance body, if subprogram and type are both -- This rule also applies within the private part of an
-- local, other rules prevent dangling references, and no -- instantiation. This rule does not apply to anonymous
-- warning is needed. -- access-to-subprogram types (Ada 2005).
elsif Attr_Id = Attribute_Access elsif Attr_Id = Attribute_Access
and then not In_Instance_Body
and then Subprogram_Access_Level (Entity (P)) > and then Subprogram_Access_Level (Entity (P)) >
Type_Access_Level (Btyp) Type_Access_Level (Btyp)
and then Ekind (Btyp) /= and then Ekind (Btyp) /=
E_Anonymous_Access_Subprogram_Type E_Anonymous_Access_Subprogram_Type
and then Ekind (Btyp) /= and then Ekind (Btyp) /=
E_Anonymous_Access_Protected_Subprogram_Type E_Anonymous_Access_Protected_Subprogram_Type
then
if not In_Instance_Body then
Error_Msg_N
("subprogram must not be deeper than access type",
P);
elsif Scope (Entity (P)) /= Scope (Btyp) then
Error_Msg_N
("subprogram must not be deeper than access type?",
P);
Error_Msg_N
("Constraint_Error will be raised ?", P);
Set_Raises_Constraint_Error (N);
end if;
-- Check the restriction of 3.10.2(32) that disallows
-- the type of the access attribute to be declared
-- outside a generic body when the subprogram is declared
-- within that generic body.
-- Ada2005: If the expected type is for an access
-- parameter, this clause does not apply.
elsif Present (Enclosing_Generic_Body (Entity (P)))
and then Enclosing_Generic_Body (Entity (P)) /=
Enclosing_Generic_Body (Btyp)
and then
Ekind (Btyp) /= E_Anonymous_Access_Subprogram_Type
then then
Error_Msg_N Error_Msg_N
("access type must not be outside generic body", P); ("subprogram must not be deeper than access type", P);
-- Check the restriction of 3.10.2(32) that disallows the
-- access attribute within a generic body when the ultimate
-- ancestor of the type of the attribute is declared outside
-- of the generic unit and the subprogram is declared within
-- that generic unit. This includes any such attribute that
-- occurs within the body of a generic unit that is a child
-- of the generic unit where the subprogram is declared.
-- The rule also prohibits applying the attibute when the
-- access type is a generic formal access type (since the
-- level of the actual type is not known). This restriction
-- does not apply when the attribute type is an anonymous
-- access-to-subprogram type. Note that this check was
-- revised by AI-229, because the originally Ada 95 rule
-- was too lax. The original rule only applied when the
-- subprogram was declared within the body of the generic,
-- which allowed the possibility of dangling references).
-- The rule was also too strict in some case, in that it
-- didn't permit the access to be declared in the generic
-- spec, whereas the revised rule does (as long as it's not
-- a formal type).
-- There are a couple of subtleties of the test for applying
-- the check that are worth noting. First, we only apply it
-- when the levels of the subprogram and access type are the
-- same (the case where the subprogram is statically deeper
-- was applied above, and the case where the type is deeper
-- is always safe). Second, we want the check to apply
-- within nested generic bodies and generic child unit
-- bodies, but not to apply to an attribute that appears in
-- the generic unit's specification. This is done by testing
-- that the attribute's innermost enclosing generic body is
-- not the same as the innermost generic body enclosing the
-- generic unit where the subprogram is declared (we don't
-- want the check to apply when the access attribute is in
-- the spec and there's some other generic body enclosing
-- generic). Finally, there's no point applying the check
-- when within an instance, because any violations will
-- have been caught by the compilation of the generic unit.
elsif Attr_Id = Attribute_Access
and then not In_Instance
and then Present (Enclosing_Generic_Unit (Entity (P)))
and then Present (Enclosing_Generic_Body (N))
and then Enclosing_Generic_Body (N) /=
Enclosing_Generic_Body
(Enclosing_Generic_Unit (Entity (P)))
and then Subprogram_Access_Level (Entity (P)) =
Type_Access_Level (Btyp)
and then Ekind (Btyp) /=
E_Anonymous_Access_Subprogram_Type
and then Ekind (Btyp) /=
E_Anonymous_Access_Protected_Subprogram_Type
then
-- The attribute type's ultimate ancestor must be
-- declared within the same generic unit as the
-- subprogram is declared. The error message is
-- specialized to say "ancestor" for the case where
-- the access type is not its own ancestor, since
-- saying simply "access type" would be very confusing.
if Enclosing_Generic_Unit (Entity (P)) /=
Enclosing_Generic_Unit (Root_Type (Btyp))
then
if Root_Type (Btyp) = Btyp then
Error_Msg_N
("access type must not be outside generic unit",
N);
else
Error_Msg_N
("ancestor access type must not be outside " &
"generic unit", N);
end if;
-- If the ultimate ancestor of the attribute's type is
-- a formal type, then the attribute is illegal because
-- the actual type might be declared at a higher level.
-- The error message is specialized to say "ancestor"
-- for the case where the access type is not its own
-- ancestor, since saying simply "access type" would be
-- very confusing.
elsif Is_Generic_Type (Root_Type (Btyp)) then
if Root_Type (Btyp) = Btyp then
Error_Msg_N
("access type must not be a generic formal type",
N);
else
Error_Msg_N
("ancestor access type must not be a generic " &
"formal type", N);
end if;
end if;
end if; end if;
end if; end if;
@ -7095,7 +7209,7 @@ package body Sem_Attr is
Error_Msg_N Error_Msg_N
("?non-local pointer cannot point to local object", P); ("?non-local pointer cannot point to local object", P);
Error_Msg_N Error_Msg_N
("?Program_Error will be raised at run time", P); ("\?Program_Error will be raised at run time", P);
Rewrite (N, Rewrite (N,
Make_Raise_Program_Error (Loc, Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed)); Reason => PE_Accessibility_Check_Failed));

171
gcc/ada/sem_util.adb
View file

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -138,8 +138,8 @@ package body Sem_Util is
Rtyp := Typ; Rtyp := Typ;
end if; end if;
Discard_Node ( Discard_Node
Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
if not Rep then if not Rep then
return; return;
@ -1103,6 +1103,7 @@ package body Sem_Util is
Msgl : Natural; Msgl : Natural;
Wmsg : Boolean; Wmsg : Boolean;
P : Node_Id; P : Node_Id;
OldP : Node_Id;
Msgs : Boolean; Msgs : Boolean;
Eloc : Source_Ptr; Eloc : Source_Ptr;
@ -1157,28 +1158,72 @@ package body Sem_Util is
-- Should we generate a warning? The answer is not quite yes. The -- Should we generate a warning? The answer is not quite yes. The
-- very annoying exception occurs in the case of a short circuit -- very annoying exception occurs in the case of a short circuit
-- operator where the left operand is static and decisive. Climb -- operator where the left operand is static and decisive. Climb
-- parents to see if that is the case we have here. -- parents to see if that is the case we have here. Conditional
-- expressions with decisive conditions are a similar situation.
Msgs := True; Msgs := True;
P := N; P := N;
loop loop
OldP := P;
P := Parent (P); P := Parent (P);
if (Nkind (P) = N_And_Then -- And then with False as left operand
and then Compile_Time_Known_Value (Left_Opnd (P))
and then Is_False (Expr_Value (Left_Opnd (P)))) if Nkind (P) = N_And_Then
or else (Nkind (P) = N_Or_Else and then Compile_Time_Known_Value (Left_Opnd (P))
and then Compile_Time_Known_Value (Left_Opnd (P)) and then Is_False (Expr_Value (Left_Opnd (P)))
and then Is_True (Expr_Value (Left_Opnd (P))))
then then
Msgs := False; Msgs := False;
exit; exit;
-- OR ELSE with True as left operand
elsif Nkind (P) = N_Or_Else
and then Compile_Time_Known_Value (Left_Opnd (P))
and then Is_True (Expr_Value (Left_Opnd (P)))
then
Msgs := False;
exit;
-- Conditional expression
elsif Nkind (P) = N_Conditional_Expression then
declare
Cond : constant Node_Id := First (Expressions (P));
Texp : constant Node_Id := Next (Cond);
Fexp : constant Node_Id := Next (Texp);
begin
if Compile_Time_Known_Value (Cond) then
-- Condition is True and we are in the right operand
if Is_True (Expr_Value (Cond))
and then OldP = Fexp
then
Msgs := False;
exit;
-- Condition is False and we are in the left operand
elsif Is_False (Expr_Value (Cond))
and then OldP = Texp
then
Msgs := False;
exit;
end if;
end if;
end;
-- Special case for component association in aggregates, where
-- we want to keep climbing up to the parent aggregate.
elsif Nkind (P) = N_Component_Association elsif Nkind (P) = N_Component_Association
and then Nkind (Parent (P)) = N_Aggregate and then Nkind (Parent (P)) = N_Aggregate
then then
null; -- Keep going. null;
-- Keep going if within subexpression
else else
exit when Nkind (P) not in N_Subexpr; exit when Nkind (P) not in N_Subexpr;
@ -1195,11 +1240,11 @@ package body Sem_Util is
if Wmsg then if Wmsg then
if Inside_Init_Proc then if Inside_Init_Proc then
Error_Msg_NEL Error_Msg_NEL
("\& will be raised for objects of this type!?", ("\?& will be raised for objects of this type",
N, Standard_Constraint_Error, Eloc); N, Standard_Constraint_Error, Eloc);
else else
Error_Msg_NEL Error_Msg_NEL
("\& will be raised at run time!?", ("\?& will be raised at run time",
N, Standard_Constraint_Error, Eloc); N, Standard_Constraint_Error, Eloc);
end if; end if;
else else
@ -1536,15 +1581,14 @@ package body Sem_Util is
---------------------------- ----------------------------
function Enclosing_Generic_Body function Enclosing_Generic_Body
(E : Entity_Id) return Node_Id (N : Node_Id) return Node_Id
is is
P : Node_Id; P : Node_Id;
Decl : Node_Id; Decl : Node_Id;
Spec : Node_Id; Spec : Node_Id;
begin begin
P := Parent (E); P := Parent (N);
while Present (P) loop while Present (P) loop
if Nkind (P) = N_Package_Body if Nkind (P) = N_Package_Body
or else Nkind (P) = N_Subprogram_Body or else Nkind (P) = N_Subprogram_Body
@ -1568,6 +1612,47 @@ package body Sem_Util is
return Empty; return Empty;
end Enclosing_Generic_Body; end Enclosing_Generic_Body;
----------------------------
-- Enclosing_Generic_Unit --
----------------------------
function Enclosing_Generic_Unit
(N : Node_Id) return Node_Id
is
P : Node_Id;
Decl : Node_Id;
Spec : Node_Id;
begin
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Generic_Package_Declaration
or else Nkind (P) = N_Generic_Subprogram_Declaration
then
return P;
elsif Nkind (P) = N_Package_Body
or else Nkind (P) = N_Subprogram_Body
then
Spec := Corresponding_Spec (P);
if Present (Spec) then
Decl := Unit_Declaration_Node (Spec);
if Nkind (Decl) = N_Generic_Package_Declaration
or else Nkind (Decl) = N_Generic_Subprogram_Declaration
then
return Decl;
end if;
end if;
end if;
P := Parent (P);
end loop;
return Empty;
end Enclosing_Generic_Unit;
------------------------------- -------------------------------
-- Enclosing_Lib_Unit_Entity -- -- Enclosing_Lib_Unit_Entity --
------------------------------- -------------------------------
@ -1660,7 +1745,7 @@ package body Sem_Util is
-- Enter_Name -- -- Enter_Name --
---------------- ----------------
procedure Enter_Name (Def_Id : Node_Id) is procedure Enter_Name (Def_Id : Entity_Id) is
C : constant Entity_Id := Current_Entity (Def_Id); C : constant Entity_Id := Current_Entity (Def_Id);
E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
S : constant Entity_Id := Current_Scope; S : constant Entity_Id := Current_Scope;
@ -2450,7 +2535,7 @@ package body Sem_Util is
Atyp : Entity_Id; Atyp : Entity_Id;
begin begin
if not Present (Utyp) then if No (Utyp) then
Utyp := Typ; Utyp := Typ;
end if; end if;
@ -5054,6 +5139,20 @@ package body Sem_Util is
-- Kill_Current_Values -- -- Kill_Current_Values --
------------------------- -------------------------
procedure Kill_Current_Values (Ent : Entity_Id) is
begin
if Is_Object (Ent) then
Kill_Checks (Ent);
Set_Current_Value (Ent, Empty);
if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False);
end if;
Set_Is_Known_Null (Ent, False);
end if;
end Kill_Current_Values;
procedure Kill_Current_Values is procedure Kill_Current_Values is
S : Entity_Id; S : Entity_Id;
@ -5066,18 +5165,10 @@ package body Sem_Util is
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
Ent : Entity_Id; Ent : Entity_Id;
begin begin
Ent := E; Ent := E;
while Present (Ent) loop while Present (Ent) loop
if Is_Object (Ent) then Kill_Current_Values (Ent);
Set_Current_Value (Ent, Empty);
if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False);
end if;
end if;
Next_Entity (Ent); Next_Entity (Ent);
end loop; end loop;
end Kill_Current_Values_For_Entity_Chain; end Kill_Current_Values_For_Entity_Chain;
@ -5570,6 +5661,7 @@ package body Sem_Util is
-- side effects have been removed. -- side effects have been removed.
Exp := Prefix (Expression (Parent (Entity (P)))); Exp := Prefix (Expression (Parent (Entity (P))));
goto Continue;
else else
return; return;
@ -5581,22 +5673,22 @@ package body Sem_Util is
or else Nkind (Exp) = N_Unchecked_Type_Conversion or else Nkind (Exp) = N_Unchecked_Type_Conversion
then then
Exp := Expression (Exp); Exp := Expression (Exp);
goto Continue;
elsif Nkind (Exp) = N_Slice elsif Nkind (Exp) = N_Slice
or else Nkind (Exp) = N_Indexed_Component or else Nkind (Exp) = N_Indexed_Component
or else Nkind (Exp) = N_Selected_Component or else Nkind (Exp) = N_Selected_Component
then then
Exp := Prefix (Exp); Exp := Prefix (Exp);
goto Continue;
else else
return; return;
end if; end if;
-- Now look for entity being referenced -- Now look for entity being referenced
if Present (Ent) then if Present (Ent) then
if Is_Object (Ent) then if Is_Object (Ent) then
if Comes_From_Source (Exp) if Comes_From_Source (Exp)
or else Modification_Comes_From_Source or else Modification_Comes_From_Source
@ -5604,13 +5696,16 @@ package body Sem_Util is
Set_Never_Set_In_Source (Ent, False); Set_Never_Set_In_Source (Ent, False);
end if; end if;
Set_Is_True_Constant (Ent, False); Set_Is_True_Constant (Ent, False);
Set_Current_Value (Ent, Empty); Set_Current_Value (Ent, Empty);
Set_Is_Known_Null (Ent, False);
if not Can_Never_Be_Null (Ent) then if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False); Set_Is_Known_Non_Null (Ent, False);
end if; end if;
-- Follow renaming chain
if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
and then Present (Renamed_Object (Ent)) and then Present (Renamed_Object (Ent))
then then
@ -6746,6 +6841,18 @@ package body Sem_Util is
end if; end if;
Btyp := Root_Type (Btyp); Btyp := Root_Type (Btyp);
-- The accessibility level of anonymous acccess types associated with
-- discriminants is that of the current instance of the type, and
-- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
if Ekind (Typ) = E_Anonymous_Access_Type
and then Present (Associated_Node_For_Itype (Typ))
and then Nkind (Associated_Node_For_Itype (Typ)) =
N_Discriminant_Specification
then
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
end if;
end if; end if;
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));

27
gcc/ada/sem_util.ads
View file

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -136,11 +136,12 @@ package Sem_Util is
Ent : Entity_Id := Empty; Ent : Entity_Id := Empty;
Loc : Source_Ptr := No_Location; Loc : Source_Ptr := No_Location;
Warn : Boolean := False) return Node_Id; Warn : Boolean := False) return Node_Id;
-- Subsidiary to Apply_Compile_Time_Constraint_Error and Checks routines. -- This is similar to Apply_Compile_Time_Constraint_Error in that it
-- Does not modify any nodes, but generates a warning (or error) message. -- generates a warning (or error) message in the same manner, but it does
-- For convenience, the function always returns its first argument. The -- not replace any nodes. For convenience, the function always returns its
-- message is a warning if the message ends with ?, or we are operating -- first argument. The message is a warning if the message ends with ?, or
-- in Ada 83 mode, or if the Warn parameter is set to True. -- we are operating in Ada 83 mode, or if the Warn parameter is set to
-- True.
procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id); procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
-- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag
@ -194,10 +195,15 @@ package Sem_Util is
-- an expanded name, a defining program unit name or an identifier -- an expanded name, a defining program unit name or an identifier
function Enclosing_Generic_Body function Enclosing_Generic_Body
(E : Entity_Id) return Node_Id; (N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing -- Returns the Node_Id associated with the innermost enclosing
-- generic body, if any. If none, then returns Empty. -- generic body, if any. If none, then returns Empty.
function Enclosing_Generic_Unit
(N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing
-- generic unit, if any. If none, then returns Empty.
function Enclosing_Lib_Unit_Entity return Entity_Id; function Enclosing_Lib_Unit_Entity return Entity_Id;
-- Returns the entity of enclosing N_Compilation_Unit Node which is the -- Returns the entity of enclosing N_Compilation_Unit Node which is the
-- root of the current scope (which must not be Standard_Standard, and -- root of the current scope (which must not be Standard_Standard, and
@ -216,7 +222,7 @@ package Sem_Util is
-- build and initialize a new freeze node and set Has_Delayed_Freeze -- build and initialize a new freeze node and set Has_Delayed_Freeze
-- true for entity E. -- true for entity E.
procedure Enter_Name (Def_Id : Node_Id); procedure Enter_Name (Def_Id : Entity_Id);
-- Insert new name in symbol table of current scope with check for -- Insert new name in symbol table of current scope with check for
-- duplications (error message is issued if a conflict is found) -- duplications (error message is issued if a conflict is found)
-- Note: Enter_Name is not used for overloadable entities, instead -- Note: Enter_Name is not used for overloadable entities, instead
@ -627,6 +633,11 @@ package Sem_Util is
-- Is_Known_Non_Null flags in variables, constants or parameters -- Is_Known_Non_Null flags in variables, constants or parameters
-- since these are also not known to be valid. -- since these are also not known to be valid.
procedure Kill_Current_Values (Ent : Entity_Id);
-- This performs the same processing as described above for the form with
-- no argument, but for the specific entity given. The call has no effect
-- if the entity Ent is not for an object.
procedure Kill_Size_Check_Code (E : Entity_Id); procedure Kill_Size_Check_Code (E : Entity_Id);
-- Called when an address clause or pragma Import is applied to an -- Called when an address clause or pragma Import is applied to an
-- entity. If the entity is a variable or a constant, and size check -- entity. If the entity is a variable or a constant, and size check