[Ada] Fix bug in computation of 'Width
Arnaud Charlet
charlet@adacore.com
Wed Feb 15 10:20:00 GMT 2006
Tested on i686-linux, committed on trunk
This fixes a long-standing bug in the computation of the Width attribute.
For 96-bit floating-point types, the maximum exponent in decimal form is
one digit longer than for 64-bit (Long_Float) types. This error led to
an array overflow in the computation of the image of floating-point values
greater or equal to 1.0E1000.
The following must compile and execute quietly on a system where the
run-time is compiled with assertions enabled.
--
with Text_IO; use Text_IO;
procedure Img is
begin
declare
LLI : String := Long_Long_Float'image (Long_Long_Float'Last);
begin
null;
end;
exception
when others => Put_Line ("FAILED");
end;
In a component definition, the current instance of the enclosing type
can only be used with an attribute that yields an access type.
Compilation of main.adb must produce in a single line;
--
main.adb:5:33: In a constraint the current instance can only be used
with an access attribute
--
procedure Main is
type Bar(E : Integer) is null record;
type CurrentType(D : Integer) is
record
Field : Bar(CurrentType'Size);
end record;
begin
null;
end Main;
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
-------------- next part --------------
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 110833)
+++ sem_attr.adb (working copy)
@@ -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 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 @@
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 @@
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 @@
-----------
when Attribute_Class => Class : declare
+ P : constant Entity_Id := Prefix (N);
+
begin
Check_Restriction (No_Dispatch, N);
Check_Either_E0_Or_E1;
@@ -2288,13 +2323,23 @@
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
else
@@ -4725,10 +4770,10 @@
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 @@
-- 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 @@
begin
if Esize (P_Type) <= 32 then
Len := Len + 6;
+ elsif Esize (P_Type) = 64 then
+ Len := Len + 7;
else
- Len := Len + 7;
+ Len := Len + 8;
end if;
Fold_Uint (N, UI_From_Int (Len), True);
@@ -6782,7 +6830,7 @@
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,12 +7001,13 @@
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) /=
@@ -6966,36 +7015,101 @@
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);
+ 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
+ -- 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).
- -- 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.
+ -- 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.
- -- Ada2005: If the expected type is for an access
- -- parameter, this clause does not apply.
+ 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.
- 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);
+ 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 @@
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));
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 110833)
+++ sem_util.ads (working copy)
@@ -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 @@
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 @@
-- 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 @@
-- 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 @@
-- 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
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 110833)
+++ sem_util.adb (working copy)
@@ -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 @@
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 @@
Msgl : Natural;
Wmsg : Boolean;
P : Node_Id;
+ OldP : Node_Id;
Msgs : Boolean;
Eloc : Source_Ptr;
@@ -1157,29 +1158,73 @@
-- 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;
end if;
@@ -1195,11 +1240,11 @@
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 @@
----------------------------
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 @@
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 @@
-- 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 @@
Atyp : Entity_Id;
begin
- if not Present (Utyp) then
+ if No (Utyp) then
Utyp := Typ;
end if;
@@ -5054,6 +5139,20 @@
-- 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 @@
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 @@
-- side effects have been removed.
Exp := Prefix (Expression (Parent (Entity (P))));
+ goto Continue;
else
return;
@@ -5581,22 +5673,22 @@
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 @@
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 @@
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));
More information about the Gcc-patches
mailing list