Merge branch 'topic/1092' into 'master'

Improve user-defined indexing functions support

Closes #1092

See merge request eng/libadalang/libadalang!1445

ada/ast.py

@@ -8756,41 +8756,85 @@ def refined_parent_primitives_env():
     )
 
     @langkit_property()
-    def constant_indexing_fns():
-        return (
-            Entity.get_aspect('Constant_Indexing', True).value
-            ._.cast_or_raise(T.Name).all_env_elements_internal(seq=False)
-            .filtermap(
-                lambda e: e.cast(T.BasicDecl),
-                lambda env_el:
-                env_el.cast_or_raise(T.BasicDecl).subp_spec_or_null.then(
-                    lambda ss: origin.bind(
-                        env_el.node,
-                        ss.unpacked_formal_params.at(0)
-                        ._.formal_decl.formal_type.matching_formal_type(Entity)
-                    )
+    def indexing_fns(name=T.Name.entity):
+        """
+        Return the indexing functions locally defined for this type. If the
+        type is the one for which the aspect has been defined, then return its
+        corresponding user-defined functions. If this type is derived from a
+        type having the aspect, this property only returns any overrides
+        defined for it.
+        """
+        return name.then(
+            # Get all elements for name in self's env
+            lambda name: env.bind(
+                Entity.node_env,
+                origin.bind(
+                    Entity.origin_node,
+                    name.all_env_els_impl(seq=False)
                 )
             )
-        )
+        ).filtermap(
+            lambda e: e.cast(T.BasicDecl),
+            lambda env_el:
+            # Unfortunately, we can't use `UserDefinedFunctionSubpSpec` (as in
+            # `user_defined_literal_fns`) here to filter candidates since user
+            # defined functions can have many parameters without any
+            # constraints on them. Only the first parameter should be a the
+            # type of Entity.
+            env_el.cast_or_raise(T.BasicDecl).subp_spec_or_null.then(
+                lambda ss: origin.bind(
+                    env_el.node,
+                    ss.unpacked_formal_params.at(0)
+                    ._.formal_decl.formal_type.matching_formal_type(Entity)
+                )
+            )
+        ).unique
 
-    @langkit_property()
-    def variable_indexing_fns():
-        return Entity.get_aspect('Variable_Indexing', True).value.then(
-            lambda a: a.cast_or_raise(T.Name)
-            .all_env_elements_internal(seq=False).filtermap(
-                lambda e: e.cast(T.BasicDecl),
-                lambda env_el:
-                env_el.cast_or_raise(T.BasicDecl).subp_spec_or_null.then(
-                    lambda ss: origin.bind(
-                        env_el.node,
-                        ss.unpacked_formal_params.at(0)
-                        ._.formal_decl.formal_type.matching_formal_type(Entity)
-                        & ss.return_type.is_implicit_deref
-                    )
+    @langkit_property(return_type=T.BasicDecl.entity.array)
+    def all_indexing_fns_impl(name=T.Name.entity, root_type=T.TypeDecl.entity):
+        """
+        Get all the indexing functions designated by ``name`` defined for
+        this type by recursing parent types until ``root_type``.
+        """
+        return Entity.indexing_fns(name).concat(
+            # The user indexing functions can be overriden, so recurse on all
+            # base types to get them all.
+            Entity.base_type.then(
+                lambda bt: If(
+                    Entity == root_type,
+                    No(T.BasicDecl.entity.array),
+                    bt.cast_or_raise(T.TypeDecl)
+                    .all_indexing_fns_impl(name, root_type)
                 )
             )
         )
 
+    @langkit_property(return_type=T.BasicDecl.entity.array)
+    def all_indexing_fns(sym=T.Symbol):
+        """
+        Return all the indexing functions defined for this type, including
+        ones defined by its parents.
+        """
+        return Entity.get_aspect(sym).value.then(
+            lambda val: Let(
+                # The indexing function's name is specified on the type for
+                # which the aspect is defined (which is returned by
+                # `get_aspect` here).
+                lambda fn_name=val.cast_or_raise(T.Name),
+                # The root type of the type derivation chain (to stop the
+                # recursion in `all_indexing_fns`).
+                root_type=val.parent.parent.cast(T.TypeDecl):
+                Entity.all_indexing_fns_impl(fn_name, root_type)
+            )
+        )
+
+    constant_indexing_fns = Property(
+        Entity.all_indexing_fns('Constant_Indexing')
+    )
+    variable_indexing_fns = Property(
+        Entity.all_indexing_fns('Variable_Indexing')
+    )
+
     @langkit_property(return_type=T.BasicDecl.entity.array)
     def user_defined_literal_fns(aspect=T.Symbol):
         """
@@ -9881,6 +9925,7 @@ def get_type():
     has_ud_indexing = Property(
         Entity.from_type_bound.has_ud_indexing
     )
+
     constant_indexing_fns = Property(
         Entity.from_type_bound.constant_indexing_fns
     )
@@ -16680,13 +16725,23 @@ def subscriptable_type_equation(typ=T.BaseTypeDecl.entity):
             typ.constant_indexing_fns.concat(typ.variable_indexing_fns)
             .logic_any(lambda fn: Let(
                 lambda
-                formal=fn.subp_spec_or_null.unpacked_formal_params.at(1),
+                formals=fn.subp_spec_or_null.unpacked_formal_params,
                 ret_type=fn.subp_spec_or_null.return_type,
-                param=Entity.params.at(0).expr:
+                params=Entity.params:
 
-                Bind(Self.type_var, ret_type)
-                & Bind(param.expected_type_var, formal.formal_decl.formal_type)
-                & param.matches_expected_type
+                If(
+                    # The user indexing function that matches has one more
+                    # parameter than that call expression.
+                    formals.length == params.length + 1,
+                    Bind(Self.type_var, ret_type)
+                    & params.logic_all(
+                        lambda i, param:
+                        Bind(param.expr.expected_type_var,
+                             formals.at(i + 1).formal_decl.formal_type)
+                        & param.expr.matches_expected_type
+                    ),
+                    LogicFalse()
+                )
             )),
 
             LogicFalse()
@@ -16776,7 +16831,11 @@ def check_for_type(typ=T.BaseTypeDecl.entity):
 
                 # Types with user defined indexing
                 typ.has_ud_indexing
-                & Self.suffix.cast(T.AssocList).then(lambda al: al.length == 1)
+                & Self.suffix.cast(T.AssocList).then(
+                    # All such `CallExpr`s shall have at least two parameters
+                    # (:rmlink:`4.1.6`).
+                    lambda al: al.length >= 1
+                )
             ),
 
             Entity.parent.cast(T.CallExpr).then(
@@ -18932,13 +18991,11 @@ def env_elements_baseid():
                     b.subp_spec_or_null.then(
                         lambda spec:
                         Entity.call_matches_spec(spec, pc, params, b),
-
                         # In the case of ObjectDecls/CompDecls in general,
                         # verify that the callexpr is valid for the given
                         # type designator.
                         default_val=pc.check_for_type(b.expr_type)
                     ),
-
                     lambda _: False
                 )),
 

testsuite/tests/name_resolution/ud_indexing_5/test.adb

@@ -0,0 +1,86 @@
+procedure Test is
+
+   package Pkg is
+      type Window is tagged private
+         with Constant_Indexing => CRef,
+              Variable_Indexing => VRef;
+
+      type Color is (R, G, B);
+
+      type Pixel is record
+         C : Color;
+         X, Y : Natural;
+      end record;
+
+      subtype Name is String(1..6);
+
+      type Ref_Rec (D : access Pixel) is null record
+         with Implicit_Dereference => D;
+
+      function CRef (W : in Window; N : in Name) return Pixel;
+
+      function VRef (W : aliased in out Window; N : in Name) return Ref_Rec;
+
+      function CRef (W : in Window; X, Y : in Natural) return Pixel;
+
+      function VRef (W : aliased in out Window;
+                     X, Y : in Natural) return Ref_Rec;
+
+   private
+
+      type PArray is array (1..10) of aliased Pixel;
+      type Window is tagged record
+         Count : Natural := 0;
+         Pixels : PArray;
+      end record;
+   end Pkg;
+
+   package body Pkg is
+
+      function CRef (W : in Window; X, Y : in Natural) return Pixel is
+      begin
+         return W.Pixels (1);
+      end CRef;
+
+      function VRef (W : aliased in out Window;
+                     X, Y : in Natural) return Ref_Rec is
+      begin
+         return (D => W.Pixels (1)'Access);
+      end VRef;
+
+      function CRef (W : in Window; N : in Name) return Pixel is
+      begin
+         return W.Pixels (1);
+      end CRef;
+
+      function VRef (W : aliased in out Window; N : in Name) return Ref_Rec is
+      begin
+         return (D => W.Pixels (1)'Access);
+      end VRef;
+
+   end Pkg;
+
+   use Pkg;
+
+   procedure P (W : in out Window; X, Y : Natural) is
+      procedure Ident (C : Color) is null;
+   begin
+      Ident (W (X, Y).C);
+      pragma Test_Statement;
+
+      Ident (W.CRef (X, Y).C);
+      pragma Test_Statement;
+
+      Ident (W ("ABCDEF").C);
+      pragma Test_Statement;
+
+      W (X, Y).C := R;
+      pragma Test_Statement;
+
+      W ("ABCDEF").C := G;
+      pragma Test_Statement;
+   end P;
+
+begin
+   null;
+end Test;