@@ -12971,29 +12971,39 @@ package body Sem_Ch3 is
or else Is_Incomplete_Or_Private_Type (Desig_Type))
and then not Is_Constrained (Desig_Type)
then
- -- ??? The following code is a temporary bypass to ignore a
- -- discriminant constraint on access type if it is constraining
- -- the current record. Avoid creating the implicit subtype of the
- -- record we are currently compiling since right now, we cannot
- -- handle these. For now, just return the access type itself.
+ -- If this is a constrained access definition for a record
+ -- component, we leave the type as an unconstrained access,
+ -- and mark the component so that its actual type is build
+ -- at a point of use (e.g an assignment statement). THis is
+ -- handled in sem_util, Build_Actual_Subtype_Of_Component.
if Desig_Type = Current_Scope
and then No (Def_Id)
then
- Error_Msg_Warn := SPARK_Mode /= On;
- Error_Msg_N ("<<constraint is ignored on component that is "
- & "access to current record", S);
-
+ Desig_Subtype :=
+ Create_Itype
+ (E_Void, Related_Nod, Scope_Id => Scope (Desig_Type));
Set_Ekind (Desig_Subtype, E_Record_Subtype);
Def_Id := Entity (Subtype_Mark (S));
+ -- We indicate that the component has a pet-object
+ -- constraint for uniform treatment at a point of use,
+ -- even though the constraint may be independent of
+ -- discriminants of enclosing type.
+
+ if Nkind (Related_Nod) = N_Component_Declaration then
+ Set_Has_Per_Object_Constraint
+ (Defining_Identifier (Related_Nod));
+ end if;
+
-- This call added to ensure that the constraint is analyzed
-- (needed for a B test). Note that we still return early from
- -- this procedure to avoid recursive processing. ???
+ -- this procedure to avoid recursive processing.
Constrain_Discriminated_Type
(Desig_Subtype, S, Related_Nod, For_Access => True);
return;
+
end if;
-- Enforce rule that the constraint is illegal if there is an
@@ -4812,16 +4812,15 @@ package body Sem_Ch4 is
Set_Etype (N, Etype (Comp));
else
- -- Component type depends on discriminants. Enter the
- -- main attributes of the subtype.
+ -- If discriminants were present in the component
+ -- declaration, they have been replaced by the
+ -- actual values in the prefix object.
declare
Subt : constant Entity_Id :=
Defining_Identifier (Act_Decl);
-
begin
Set_Etype (Subt, Base_Type (Etype (Comp)));
- Set_Ekind (Subt, Ekind (Etype (Comp)));
Set_Etype (N, Subt);
end;
end if;
@@ -1187,18 +1187,28 @@ package body Sem_Util is
is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Prefix (N);
+
D : Elmt_Id;
Id : Node_Id;
Index_Typ : Entity_Id;
+ Sel : Entity_Id := Empty;
Desig_Typ : Entity_Id;
-- This is either a copy of T, or if T is an access type, then it is
-- the directly designated type of this access type.
+ function Build_Access_Record_Constraint (C : List_Id) return List_Id;
+ -- If the record component is a constrained access to the current
+ -- record, the subtype has not been constructed during analysis of
+ -- the enclosing record type (see Analyze_Access). In that case build
+ -- a constrainted access subtype after replacing references to the
+ -- enclosing discriminants by the corresponding discriminant values
+ -- of the prefix.
+
function Build_Actual_Array_Constraint return List_Id;
-- If one or more of the bounds of the component depends on
-- discriminants, build actual constraint using the discriminants
- -- of the prefix.
+ -- of the prefx, as above.
function Build_Actual_Record_Constraint return List_Id;
-- Similar to previous one, for discriminated components constrained
@@ -1286,10 +1296,53 @@ package body Sem_Util is
return Constraints;
end Build_Actual_Record_Constraint;
+ ------------------------------------
+ -- Build_Access_Record_Constraint --
+ ------------------------------------
+
+ function Build_Access_Record_Constraint (C : List_Id) return List_Id is
+ Constraints : constant List_Id := New_List;
+ D : Node_Id;
+ D_Val : Node_Id;
+
+ begin
+ -- Retrieve the constraint from the compomnent declaration, because
+ -- the component subtype has not been constructed and the component
+ -- type is an unconstrained access.
+
+ D := First (C);
+ while Present (D) loop
+ if Nkind (D) = N_Discriminant_Association
+ and then Denotes_Discriminant (Expression (D))
+ then
+ D_Val := New_Copy_Tree (D);
+ Set_Expression (D_Val,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (P),
+ Selector_Name =>
+ New_Occurrence_Of (Entity (Expression (D)), Loc)));
+
+ elsif Denotes_Discriminant (D) then
+ D_Val := Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (P),
+ Selector_Name => New_Occurrence_Of (Entity (D), Loc));
+
+ else
+ D_Val := New_Copy_Tree (D);
+ end if;
+
+ Append (D_Val, Constraints);
+ Next (D);
+ end loop;
+
+ return Constraints;
+ end Build_Access_Record_Constraint;
+
-- Start of processing for Build_Actual_Subtype_Of_Component
begin
- -- Why the test for Spec_Expression mode here???
+ -- The subtype does not need to be created for a selected component
+ -- in a Spec_Expression,
if In_Spec_Expression then
return Empty;
@@ -1314,19 +1367,33 @@ package body Sem_Util is
Remove_Side_Effects (P);
return Build_Actual_Subtype (T, N);
end if;
+
else
return Empty;
end if;
+
+ elsif Nkind (N) = N_Selected_Component then
+ -- THe entity of the selected compomnent allows us to retrieve
+ -- the original constraint from its component declaration.
+
+ Sel := Entity (Selector_Name (N));
+ if Nkind (Parent (Sel)) /= N_Component_Declaration then
+ return Empty;
+ end if;
end if;
- if Ekind (T) = E_Access_Subtype then
+ if Is_Access_Type (T) then
Desig_Typ := Designated_Type (T);
+
else
Desig_Typ := T;
end if;
if Ekind (Desig_Typ) = E_Array_Subtype then
Id := First_Index (Desig_Typ);
+
+ -- Check whether an index bound is constrained by a discriminant.
+
while Present (Id) loop
Index_Typ := Underlying_Type (Etype (Id));
@@ -1345,6 +1412,7 @@ package body Sem_Util is
elsif Is_Composite_Type (Desig_Typ)
and then Has_Discriminants (Desig_Typ)
+ and then not Is_Empty_Elmt_List (Discriminant_Constraint (Desig_Typ))
and then not Has_Unknown_Discriminants (Desig_Typ)
then
if Is_Private_Type (Desig_Typ)
@@ -1364,6 +1432,37 @@ package body Sem_Util is
Next_Elmt (D);
end loop;
+
+ -- Special processing for an access record component that is
+ -- the target of an assignment. If the designated type is an
+ -- unconstrained discriminated record we create its actual
+ -- subtype now.
+
+ elsif Ekind (T) = E_Access_Type
+ and then Present (Sel)
+ and then Has_Per_Object_Constraint (Sel)
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then N = Name (Parent (N))
+ -- and then not Inside_Init_Proc
+ -- and then Has_Discriminants (Desig_Typ)
+ -- and then not Is_Constrained (Desig_Typ)
+ then
+ declare
+ S_Indic : constant Node_Id :=
+ (Subtype_Indication
+ (Component_Definition (Parent (Sel))));
+ Discs : List_Id;
+ begin
+ if Nkind (S_Indic) = N_Subtype_Indication then
+ Discs := Constraints (Constraint (S_Indic));
+
+ Remove_Side_Effects (P);
+ return Build_Component_Subtype
+ (Build_Access_Record_Constraint (Discs), Loc, T);
+ else
+ return Empty;
+ end if;
+ end;
end if;
-- If none of the above, the actual and nominal subtypes are the same
@@ -6,7 +6,7 @@ procedure Warn24 is
type List_Acc is access List_D;
type List_D (D : Boolean) is record
- Next : List_Acc (D); -- { dg-warning "constraint is ignored on component that is access to current record" }
+ Next : List_Acc (D);
end record;
X : List_D (True);