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 --
-- --
-- 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 --
-- 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 Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
@ -1151,7 +1150,7 @@ package body Sem_Attr is
end if;
if Ekind (Typ) = E_Incomplete_Type
and then not Present (Full_View (Typ))
and then No (Full_View (Typ))
then
Error_Attr
("prefix of % attribute cannot be an incomplete type", P);
@ -1665,11 +1664,45 @@ package body Sem_Attr is
if Is_Entity_Name (P)
and then Present (Entity (P))
and then Is_Type (Entity (P))
and then Ekind (Entity (P)) = E_Incomplete_Type
then
P_Type := Get_Full_View (P_Type);
Set_Entity (P, P_Type);
Set_Etype (P, P_Type);
if Ekind (Entity (P)) = E_Incomplete_Type then
P_Type := Get_Full_View (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;
if P_Type = Any_Type then
@ -2274,6 +2307,8 @@ package body Sem_Attr is
-----------
when Attribute_Class => Class : declare
P : constant Entity_Id := Prefix (N);
begin
Check_Restriction (No_Dispatch, N);
Check_Either_E0_Or_E1;
@ -2288,12 +2323,22 @@ package body Sem_Attr is
Make_Type_Conversion (Loc,
Subtype_Mark =>
Make_Attribute_Reference (Loc,
Prefix => Prefix (N),
Prefix => P,
Attribute_Name => Name_Class),
Expression => Relocate_Node (E1)));
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
@ -4725,10 +4770,10 @@ package body Sem_Attr is
then
P_Type := Etype (P_Entity);
-- If the entity is an array constant with an unconstrained
-- nominal subtype then get the type from the initial value.
-- If the value has been expanded into assignments, the expression
-- is not present and the attribute reference remains dynamic.
-- If the entity is an array constant with an unconstrained nominal
-- subtype then get the type from the initial value. If the value has
-- been expanded into assignments, there is no expression and the
-- attribute reference remains dynamic.
-- We could do better here and retrieve the type ???
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
-- 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
Len : Int :=
@ -6456,8 +6502,10 @@ package body Sem_Attr is
begin
if Esize (P_Type) <= 32 then
Len := Len + 6;
else
elsif Esize (P_Type) = 64 then
Len := Len + 7;
else
Len := Len + 8;
end if;
Fold_Uint (N, UI_From_Int (Len), True);
@ -6782,7 +6830,7 @@ package body Sem_Attr is
Error_Msg_N
("?non-local pointer cannot point to local object", P);
Error_Msg_N
("?Program_Error will be raised at run time", P);
("\?Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
@ -6953,49 +7001,115 @@ package body Sem_Attr is
elsif Aname = Name_Unrestricted_Access then
null; -- Nothing to check
-- Check the static accessibility rule of 3.10.2(32)
-- In an instance body, if subprogram and type are both
-- local, other rules prevent dangling references, and no
-- warning is needed.
-- Check the static accessibility rule of 3.10.2(32).
-- This rule also applies within the private part of an
-- instantiation. This rule does not apply to anonymous
-- access-to-subprogram types (Ada 2005).
elsif Attr_Id = Attribute_Access
and then not In_Instance_Body
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
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
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;
@ -7095,7 +7209,7 @@ package body Sem_Attr is
Error_Msg_N
("?non-local pointer cannot point to local object", P);
Error_Msg_N
("?Program_Error will be raised at run time", P);
("\?Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));

171
gcc/ada/sem_util.adb
View file

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -138,8 +138,8 @@ package body Sem_Util is
Rtyp := Typ;
end if;
Discard_Node (
Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
Discard_Node
(Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
if not Rep then
return;
@ -1103,6 +1103,7 @@ package body Sem_Util is
Msgl : Natural;
Wmsg : Boolean;
P : Node_Id;
OldP : Node_Id;
Msgs : Boolean;
Eloc : Source_Ptr;
@ -1157,28 +1158,72 @@ package body Sem_Util is
-- Should we generate a warning? The answer is not quite yes. The
-- very annoying exception occurs in the case of a short circuit
-- 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;
P := N;
loop
OldP := P;
P := Parent (P);
if (Nkind (P) = N_And_Then
and then Compile_Time_Known_Value (Left_Opnd (P))
and then Is_False (Expr_Value (Left_Opnd (P))))
or else (Nkind (P) = N_Or_Else
and then Compile_Time_Known_Value (Left_Opnd (P))
and then Is_True (Expr_Value (Left_Opnd (P))))
-- And then with False as left operand
if Nkind (P) = N_And_Then
and then Compile_Time_Known_Value (Left_Opnd (P))
and then Is_False (Expr_Value (Left_Opnd (P)))
then
Msgs := False;
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
and then Nkind (Parent (P)) = N_Aggregate
then
null; -- Keep going.
null;
-- Keep going if within subexpression
else
exit when Nkind (P) not in N_Subexpr;
@ -1195,11 +1240,11 @@ package body Sem_Util is
if Wmsg then
if Inside_Init_Proc then
Error_Msg_NEL
("\& will be raised for objects of this type!?",
("\?& will be raised for objects of this type",
N, Standard_Constraint_Error, Eloc);
else
Error_Msg_NEL
("\& will be raised at run time!?",
("\?& will be raised at run time",
N, Standard_Constraint_Error, Eloc);
end if;
else
@ -1536,15 +1581,14 @@ package body Sem_Util is
----------------------------
function Enclosing_Generic_Body
(E : Entity_Id) return Node_Id
(N : Node_Id) return Node_Id
is
P : Node_Id;
Decl : Node_Id;
Spec : Node_Id;
begin
P := Parent (E);
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Package_Body
or else Nkind (P) = N_Subprogram_Body
@ -1568,6 +1612,47 @@ package body Sem_Util is
return Empty;
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 --
-------------------------------
@ -1660,7 +1745,7 @@ package body Sem_Util is
-- 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);
E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
S : constant Entity_Id := Current_Scope;
@ -2450,7 +2535,7 @@ package body Sem_Util is
Atyp : Entity_Id;
begin
if not Present (Utyp) then
if No (Utyp) then
Utyp := Typ;
end if;
@ -5054,6 +5139,20 @@ package body Sem_Util is
-- 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
S : Entity_Id;
@ -5066,18 +5165,10 @@ package body Sem_Util is
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
Ent : Entity_Id;
begin
Ent := E;
while Present (Ent) loop
if Is_Object (Ent) then
Set_Current_Value (Ent, Empty);
if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False);
end if;
end if;
Kill_Current_Values (Ent);
Next_Entity (Ent);
end loop;
end Kill_Current_Values_For_Entity_Chain;
@ -5570,6 +5661,7 @@ package body Sem_Util is
-- side effects have been removed.
Exp := Prefix (Expression (Parent (Entity (P))));
goto Continue;
else
return;
@ -5581,22 +5673,22 @@ package body Sem_Util is
or else Nkind (Exp) = N_Unchecked_Type_Conversion
then
Exp := Expression (Exp);
goto Continue;
elsif Nkind (Exp) = N_Slice
or else Nkind (Exp) = N_Indexed_Component
or else Nkind (Exp) = N_Selected_Component
then
Exp := Prefix (Exp);
goto Continue;
else
return;
end if;
-- Now look for entity being referenced
if Present (Ent) then
if Is_Object (Ent) then
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
@ -5604,13 +5696,16 @@ package body Sem_Util is
Set_Never_Set_In_Source (Ent, False);
end if;
Set_Is_True_Constant (Ent, False);
Set_Current_Value (Ent, Empty);
Set_Is_True_Constant (Ent, False);
Set_Current_Value (Ent, Empty);
Set_Is_Known_Null (Ent, False);
if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False);
end if;
-- Follow renaming chain
if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
and then Present (Renamed_Object (Ent))
then
@ -6746,6 +6841,18 @@ package body Sem_Util is
end if;
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;
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));

27
gcc/ada/sem_util.ads
View file

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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;
Loc : Source_Ptr := No_Location;
Warn : Boolean := False) return Node_Id;
-- Subsidiary to Apply_Compile_Time_Constraint_Error and Checks routines.
-- Does not modify any nodes, but generates a warning (or error) message.
-- For convenience, the function always returns its first argument. The
-- message is a warning if the message ends with ?, or we are operating
-- in Ada 83 mode, or if the Warn parameter is set to True.
-- This is similar to Apply_Compile_Time_Constraint_Error in that it
-- generates a warning (or error) message in the same manner, but it does
-- not replace any nodes. For convenience, the function always returns its
-- first argument. The message is a warning if the message ends with ?, or
-- 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);
-- 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
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
-- 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;
-- Returns the entity of enclosing N_Compilation_Unit Node which is the
-- 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
-- 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
-- duplications (error message is issued if a conflict is found)
-- 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
-- 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);
-- 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