+ ------------------------------
+ -- Check_Indexing_Functions --
+ ------------------------------
+
+ procedure Check_Indexing_Functions is
+
+ procedure Check_One_Function (Subp : Entity_Id);
+ -- Check one possible interpretation
+
+ ------------------------
+ -- Check_One_Function --
+ ------------------------
+
+ procedure Check_One_Function (Subp : Entity_Id) is
+ Default_Element : constant Node_Id :=
+ Find_Aspect
+ (Etype (First_Formal (Subp)),
+ Aspect_Iterator_Element);
+
+ begin
+ if not Check_Primitive_Function (Subp) then
+ Error_Msg_NE
+ ("aspect Indexing requires a function that applies to type&",
+ Subp, Ent);
+ end if;
+
+ -- An indexing function must return either the default element of
+ -- the container, or a reference type.
+
+ if Present (Default_Element) then
+ Analyze (Default_Element);
+ if Is_Entity_Name (Default_Element)
+ and then Covers (Entity (Default_Element), Etype (Subp))
+ then
+ return;
+ end if;
+ end if;
+
+ -- Otherwise the return type must be a reference type.
+
+ if not Has_Implicit_Dereference (Etype (Subp)) then
+ Error_Msg_N
+ ("function for indexing must return a reference type", Subp);
+ end if;
+ end Check_One_Function;
+
+ -- Start of processing for Check_Indexing_Functions
+
+ begin
+ if In_Instance then
+ return;
+ end if;
+
+ Analyze (Expr);
+
+ if not Is_Overloaded (Expr) then
+ Check_One_Function (Entity (Expr));
+
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+
+ -- Note that analysis will have added the interpretation
+ -- that corresponds to the dereference. We only check the
+ -- subprogram itself.
+
+ if Is_Overloadable (It.Nam) then
+ Check_One_Function (It.Nam);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+ end Check_Indexing_Functions;
+
+ ------------------------------
+ -- Check_Iterator_Functions --
+ ------------------------------
+
+ procedure Check_Iterator_Functions is
+ Default : Entity_Id;
+
+ function Valid_Default_Iterator (Subp : Entity_Id) return Boolean;
+ -- Check one possible interpretation for validity
+
+ ----------------------------
+ -- Valid_Default_Iterator --
+ ----------------------------
+
+ function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is
+ Formal : Entity_Id;
+
+ begin
+ if not Check_Primitive_Function (Subp) then
+ return False;
+ else
+ Formal := First_Formal (Subp);
+ end if;
+
+ -- False if any subsequent formal has no default expression
+
+ Formal := Next_Formal (Formal);
+ while Present (Formal) loop
+ if No (Expression (Parent (Formal))) then
+ return False;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- True if all subsequent formals have default expressions
+
+ return True;
+ end Valid_Default_Iterator;
+
+ -- Start of processing for Check_Iterator_Functions
+
+ begin
+ Analyze (Expr);
+
+ if not Is_Entity_Name (Expr) then
+ Error_Msg_N ("aspect Iterator must be a function name", Expr);
+ end if;
+
+ if not Is_Overloaded (Expr) then
+ if not Check_Primitive_Function (Entity (Expr)) then
+ Error_Msg_NE
+ ("aspect Indexing requires a function that applies to type&",
+ Entity (Expr), Ent);
+ end if;
+
+ if not Valid_Default_Iterator (Entity (Expr)) then
+ Error_Msg_N ("improper function for default iterator", Expr);
+ end if;
+
+ else
+ Default := Empty;
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+ if not Check_Primitive_Function (It.Nam)
+ or else not Valid_Default_Iterator (It.Nam)
+ then
+ Remove_Interp (I);
+
+ elsif Present (Default) then
+ Error_Msg_N ("default iterator must be unique", Expr);
+
+ else
+ Default := It.Nam;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
+ if Present (Default) then
+ Set_Entity (Expr, Default);
+ Set_Is_Overloaded (Expr, False);
+ end if;
+ end if;
+ end Check_Iterator_Functions;
+
+ -------------------------------
+ -- Check_Primitive_Function --
+ -------------------------------
+
+ function Check_Primitive_Function (Subp : Entity_Id) return Boolean is
+ Ctrl : Entity_Id;
+
+ begin
+ if Ekind (Subp) /= E_Function then
+ return False;
+ end if;
+
+ if No (First_Formal (Subp)) then
+ return False;
+ else
+ Ctrl := Etype (First_Formal (Subp));
+ end if;
+
+ if Ctrl = Ent
+ or else Ctrl = Class_Wide_Type (Ent)
+ or else
+ (Ekind (Ctrl) = E_Anonymous_Access_Type
+ and then
+ (Designated_Type (Ctrl) = Ent
+ or else Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
+ then
+ null;
+
+ else
+ return False;
+ end if;
+
+ return True;
+ end Check_Primitive_Function;
+