This patch implements the legality rules given in RM 4.1.6 on user-defined
indexing, most importantly the rule that the aspects cannot be specified for
a derived type if the parent type has such defined or inherited aspects.
Several reports include this illegal usage, which appears to be an intuitive
(if illegal) way of creating new container types. In order to simplify the
transition between this illegal usage and the proper one, the previous behavior
can be recovered by using the internal debugging option -gnatd.X.
This patch also handles properly element iterators over class-wide containers.
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-31 Ed Schonberg <schonb...@adacore.com>
* sem_ch4.adb (Try_Container_Indexing): If the container type is
class-wide, use specific type to locate iteration primitives.
* sem_ch13.adb (Check_Indexing_Functions): Add legality checks for
rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure.
Minor error message reformating.
* exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator
aspect for a derived type.
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 213327)
+++ exp_ch5.adb (working copy)
@@ -28,6 +28,7 @@
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
+with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
@@ -58,6 +59,7 @@
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
+with Uintp; use Uintp;
with Validsw; use Validsw;
package body Exp_Ch5 is
@@ -3292,17 +3294,90 @@
-- type of the iterator must be obtained from the aspect.
if Of_Present (I_Spec) then
- declare
- Default_Iter : constant Entity_Id :=
- Entity
- (Find_Value_Of_Aspect
- (Etype (Container),
- Aspect_Default_Iterator));
-
+ Handle_Of : declare
+ Default_Iter : Entity_Id;
Container_Arg : Node_Id;
Ent : Entity_Id;
+ function Get_Default_Iterator
+ (T : Entity_Id) return Entity_Id;
+ -- If the container is a derived type, the aspect holds the
+ -- parent operation. The required one is a primitive of the
+ -- derived type and is either inherited or overridden.
+
+ --------------------------
+ -- Get_Default_Iterator --
+ --------------------------
+
+ function Get_Default_Iterator
+ (T : Entity_Id) return Entity_Id
+ is
+ Iter : constant Entity_Id :=
+ Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator));
+ Prim : Elmt_Id;
+ Op : Entity_Id;
+
+ begin
+ Container_Arg := New_Copy_Tree (Container);
+
+ -- A previous version of GNAT allowed indexing aspects to
+ -- be redefined on derived container types, while the
+ -- default iterator was inherited from the aprent type.
+ -- This non-standard extension is preserved temporarily for
+ -- use by the modelling project under debug flag d.X.
+
+ if Debug_Flag_Dot_XX then
+ if Base_Type (Etype (Container)) /=
+ Base_Type (Etype (First_Formal (Iter)))
+ then
+ Container_Arg :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Etype (First_Formal (Iter)), Loc),
+ Expression => Container_Arg);
+ end if;
+
+ return Iter;
+
+ elsif Is_Derived_Type (T) then
+
+ -- The default iterator must be a primitive operation
+ -- of the type, at the same dispatch slot position.
+
+ Prim := First_Elmt (Primitive_Operations (T));
+ while Present (Prim) loop
+ Op := Node (Prim);
+
+ if Chars (Op) = Chars (Iter)
+ and then DT_Position (Op) = DT_Position (Iter)
+ then
+ return Op;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+
+ -- default iterator must exist.
+
+ pragma Assert (False);
+
+ else -- not a derived type
+ return Iter;
+ end if;
+ end Get_Default_Iterator;
+
+ -- Start of processing for Handle_Of
+
begin
+ if Is_Class_Wide_Type (Container_Typ) then
+ Default_Iter :=
+ Get_Default_Iterator (Etype (Base_Type (Container_Typ)));
+
+ else
+ Default_Iter := Get_Default_Iterator (Etype (Container));
+ end if;
+
Cursor := Make_Temporary (Loc, 'C');
-- For an container element iterator, the iterator type
@@ -3320,25 +3395,8 @@
Pack := Scope (Root_Type (Etype (Iter_Type)));
-- Rewrite domain of iteration as a call to the default
- -- iterator for the container type. If the container is
- -- a derived type and the aspect is inherited, convert
- -- container to parent type. The Cursor type is also
- -- inherited from the scope of the parent.
+ -- iterator for the container type.
- if Base_Type (Etype (Container)) =
- Base_Type (Etype (First_Formal (Default_Iter)))
- then
- Container_Arg := New_Copy_Tree (Container);
-
- else
- Container_Arg :=
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (Etype (First_Formal (Default_Iter)), Loc),
- Expression => New_Copy_Tree (Container));
- end if;
-
Rewrite (Name (I_Spec),
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Default_Iter, Loc),
@@ -3367,9 +3425,9 @@
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
- Subtype_Mark =>
+ Subtype_Mark =>
New_Occurrence_Of (Element_Type, Loc),
- Name =>
+ Name =>
Make_Indexed_Component (Loc,
Prefix => Relocate_Node (Container_Arg),
Expressions =>
@@ -3415,7 +3473,7 @@
else
Prepend_To (Stats, Decl);
end if;
- end;
+ end Handle_Of;
-- X in Iterate (S) : type of iterator is type of explicitly
-- given Iterate function, and the loop variable is the cursor.
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 213263)
+++ sem_ch4.adb (working copy)
@@ -6959,6 +6959,7 @@
Exprs : List_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
+ C_Type : Entity_Id;
Assoc : List_Id;
Disc : Entity_Id;
Func : Entity_Id;
@@ -6966,7 +6967,15 @@
Indexing : Node_Id;
begin
+ C_Type := Etype (Prefix);
+ -- If indexing a class-wide container, obtain indexing primitive
+ -- from specific type.
+
+ if Is_Class_Wide_Type (C_Type) then
+ C_Type := Etype (Base_Type (C_Type));
+ end if;
+
-- Check whether type has a specified indexing aspect
Func_Name := Empty;
@@ -7013,10 +7022,10 @@
-- Additional machinery may be needed for types that have several user-
-- defined Reference operations with different signatures ???
- elsif Is_Derived_Type (Etype (Prefix))
+ elsif Is_Derived_Type (C_Type)
and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix)
then
- Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name));
+ Func := Find_Prim_Op (C_Type, Chars (Func_Name));
Func_Name := New_Occurrence_Of (Func, Loc);
end if;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 213338)
+++ sem_ch13.adb (working copy)
@@ -1671,7 +1671,9 @@
and then not (Is_Type (E)
and then Is_Tagged_Type (E))
then
- Error_Msg_N ("indexing applies to a tagged type", N);
+ Error_Msg_N
+ ("indexing aspect can only apply to a tagged type",
+ Aspect);
goto Continue;
end if;
@@ -3471,53 +3473,138 @@
-- Check one possible interpretation. Sets Indexing_Found True if an
-- indexing function is found.
+ procedure Illegal_Indexing (Msg : String);
+ -- Diagnose illegal indexing function if not overloaded. In the
+ -- overloaded case indicate that no legal interpretation exists.
+
------------------------
-- Check_One_Function --
------------------------
procedure Check_One_Function (Subp : Entity_Id) is
- Default_Element : constant Node_Id :=
- Find_Value_Of_Aspect
- (Etype (First_Formal (Subp)),
- Aspect_Iterator_Element);
+ Default_Element : Node_Id;
+ Ret_Type : constant Entity_Id := Etype (Subp);
begin
+ if not Is_Overloadable (Subp) then
+ Illegal_Indexing ("illegal indexing function for type&");
+ return;
+
+ elsif Scope (Subp) /= Current_Scope then
+ Illegal_Indexing
+ ("indexing function must be declared in scope of type&");
+ return;
+
+ elsif No (First_Formal (Subp)) then
+ Illegal_Indexing
+ ("Indexing requires a function that applies to type&");
+ return;
+
+ elsif No (Next_Formal (First_Formal (Subp))) then
+ Illegal_Indexing
+ ("indexing function must have at least two parameters");
+ return;
+
+ elsif Is_Derived_Type (Ent) then
+ if (Attr = Name_Constant_Indexing
+ and then Present
+ (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing)))
+
+ or else (Attr = Name_Variable_Indexing
+ and then Present
+ (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
+ then
+ if Debug_Flag_Dot_XX then
+ null;
+
+ else
+ Illegal_Indexing
+ ("indexing function already inherited "
+ & "from parent type");
+ end if;
+
+ return;
+ end if;
+ end if;
+
if not Check_Primitive_Function (Subp)
and then not Is_Overloaded (Expr)
then
- Error_Msg_NE
- ("aspect Indexing requires a function that applies to type&",
- Subp, Ent);
+ Illegal_Indexing
+ ("Indexing aspect requires a function that applies to type&");
+ return;
end if;
-- An indexing function must return either the default element of
-- the container, or a reference type. For variable indexing it
-- must be the latter.
+ Default_Element :=
+ Find_Value_Of_Aspect
+ (Etype (First_Formal (Subp)), Aspect_Iterator_Element);
+
if Present (Default_Element) then
Analyze (Default_Element);
if Is_Entity_Name (Default_Element)
- and then Covers (Entity (Default_Element), Etype (Subp))
+ and then not Covers (Entity (Default_Element), Ret_Type)
+ and then False
then
- Indexing_Found := True;
+ Illegal_Indexing
+ ("wrong return type for indexing function");
return;
end if;
end if;
-- For variable_indexing the return type must be a reference type
- if Attr = Name_Variable_Indexing
- and then not Has_Implicit_Dereference (Etype (Subp))
- then
- Error_Msg_N
- ("function for indexing must return a reference type", Subp);
+ if Attr = Name_Variable_Indexing then
+ if not Has_Implicit_Dereference (Ret_Type) then
+ Illegal_Indexing
+ ("variable indexing must return a reference type");
+ return;
+ elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
+ then
+ Illegal_Indexing
+ ("variable indexing must return an access to variable");
+ return;
+ end if;
+
else
- Indexing_Found := True;
+ if Has_Implicit_Dereference (Ret_Type)
+ and then not
+ Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
+ then
+ Illegal_Indexing
+ ("constant indexing must return an access to constant");
+ return;
+
+ elsif Is_Access_Type (Etype (First_Formal (Subp)))
+ and then not Is_Access_Constant (Etype (First_Formal (Subp)))
+ then
+ Illegal_Indexing
+ ("constant indexing must apply to an access to constant");
+ return;
+ end if;
end if;
+
+ -- All checks succeeded.
+
+ Indexing_Found := True;
end Check_One_Function;
+ -----------------------
+ -- Illegal_Indexing --
+ -----------------------
+
+ procedure Illegal_Indexing (Msg : String) is
+ begin
+ if not Is_Overloaded (Expr) then
+ Error_Msg_NE (Msg, N, Ent);
+ end if;
+ end Illegal_Indexing;
+
-- Start of processing for Check_Indexing_Functions
begin
