2011-12-20 Ed Schonberg <schonberg@adacore.com>

	* sem_ch13.adb (Check_Indexing_Functions): The return type of an
	indexing function can be the default element type, and does not
	need to be a reference type.
	* sem_ch4.adb (Try_Container_Indexing): Ditto.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182536 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c6afe58..26d8fcb 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2011-12-20  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch13.adb (Check_Indexing_Functions): The return type of an
+       indexing function can be the default element type, and does not
+       need to be a reference type.
+       * sem_ch4.adb (Try_Container_Indexing): Ditto.
+
 2011-12-20  Robert Dewar  <dewar@adacore.com>
 
        * a-cdlili.ads, sem_cat.adb, sem_ch10.adb: Minor reformatting.

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 22b2bec..8c7452f 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1867,6 +1867,11 @@ package body Sem_Ch13 is
          ------------------------
 
          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
@@ -1874,6 +1879,21 @@ package body Sem_Ch13 is
                    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);

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 1c5654e..4163231 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -6491,18 +6491,22 @@ package body Sem_Ch4 is
          Rewrite (N, Indexing);
          Analyze (N);
 
-         --  The return type of the indexing function is a reference type, so
-         --  add the dereference as a possible interpretation.
-
-         Disc := First_Discriminant (Etype (Func));
-         while Present (Disc) loop
-            if Has_Implicit_Dereference (Disc) then
-               Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
-               exit;
-            end if;
+         --  If the return type of the indexing function is a reference type,
+         --  add the dereference as a possible interpretation. Note that the
+         --  indexing aspect may be a function that returns the element type
+         --  with no intervening implicit dereference.
+
+         if Has_Discriminants (Etype (Func)) then
+            Disc := First_Discriminant (Etype (Func));
+            while Present (Disc) loop
+               if Has_Implicit_Dereference (Disc) then
+                  Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
+                  exit;
+               end if;
 
-            Next_Discriminant (Disc);
-         end loop;
+               Next_Discriminant (Disc);
+            end loop;
+         end if;
 
       else
          Indexing := Make_Function_Call (Loc,
@@ -6528,16 +6532,18 @@ package body Sem_Ch4 is
 
                   --  Add implicit dereference interpretation
 
-                  Disc := First_Discriminant (Etype (It.Nam));
-                  while Present (Disc) loop
-                     if Has_Implicit_Dereference (Disc) then
-                        Add_One_Interp
-                          (N, Disc, Designated_Type (Etype (Disc)));
-                        exit;
-                     end if;
+                  if Has_Discriminants (Etype (It.Nam)) then
+                     Disc := First_Discriminant (Etype (It.Nam));
+                     while Present (Disc) loop
+                        if Has_Implicit_Dereference (Disc) then
+                           Add_One_Interp
+                             (N, Disc, Designated_Type (Etype (Disc)));
+                           exit;
+                        end if;
 
-                     Next_Discriminant (Disc);
-                  end loop;
+                        Next_Discriminant (Disc);
+                     end loop;
+                  end if;
 
                   exit;
                end if;