diff --git a/ada/ast.py b/ada/ast.py index 397f00dd4..a7b4a7ed3 100644 --- a/ada/ast.py +++ b/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 )), diff --git a/testsuite/tests/name_resolution/ud_indexing_5/test.adb b/testsuite/tests/name_resolution/ud_indexing_5/test.adb new file mode 100644 index 000000000..d2b9a7429 --- /dev/null +++ b/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; diff --git a/testsuite/tests/name_resolution/ud_indexing_5/test.out b/testsuite/tests/name_resolution/ud_indexing_5/test.out new file mode 100644 index 000000000..1d2d0ab35 --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_5/test.out @@ -0,0 +1,177 @@ +Analyzing test.adb +################## + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: None + type: + expected type: +Expr: + references: + type: + expected type: + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: None + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: + + +Done. diff --git a/testsuite/tests/name_resolution/ud_indexing_5/test.yaml b/testsuite/tests/name_resolution/ud_indexing_5/test.yaml new file mode 100644 index 000000000..173e325ff --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_5/test.yaml @@ -0,0 +1,2 @@ +driver: name-resolution +input_sources: [test.adb] diff --git a/testsuite/tests/name_resolution/ud_indexing_6/pkg-subpkg.adb b/testsuite/tests/name_resolution/ud_indexing_6/pkg-subpkg.adb new file mode 100644 index 000000000..c1ccce153 --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_6/pkg-subpkg.adb @@ -0,0 +1,11 @@ +package body Pkg.Subpkg is + function CRef (W : in New_Window; N : in Name) return Pixel is + begin + return W.Pixels (2); + end Cref; + + function CRef (W : in New_Window; N : in Name) return Integer is + begin + return W.Count; + end Cref; +end Pkg.Subpkg; diff --git a/testsuite/tests/name_resolution/ud_indexing_6/pkg-subpkg.ads b/testsuite/tests/name_resolution/ud_indexing_6/pkg-subpkg.ads new file mode 100644 index 000000000..ad5e24a2c --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_6/pkg-subpkg.ads @@ -0,0 +1,11 @@ +package Pkg.Subpkg is + type New_Window is new Pkg.Window with private; + + overriding + function CRef (W : in New_Window; N : in Name) return Pixel; + + not overriding + function CRef (W : in New_Window; N : in Name) return Integer; +private + type New_Window is new Pkg.Window with null record; +end Pkg.Subpkg; diff --git a/testsuite/tests/name_resolution/ud_indexing_6/pkg.adb b/testsuite/tests/name_resolution/ud_indexing_6/pkg.adb new file mode 100644 index 000000000..03eb3012c --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_6/pkg.adb @@ -0,0 +1,24 @@ +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; diff --git a/testsuite/tests/name_resolution/ud_indexing_6/pkg.ads b/testsuite/tests/name_resolution/ud_indexing_6/pkg.ads new file mode 100644 index 000000000..4eed5cb9d --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_6/pkg.ads @@ -0,0 +1,30 @@ +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; diff --git a/testsuite/tests/name_resolution/ud_indexing_6/test.adb b/testsuite/tests/name_resolution/ud_indexing_6/test.adb new file mode 100644 index 000000000..a2512d300 --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_6/test.adb @@ -0,0 +1,31 @@ +with Pkg; use Pkg; +with Pkg.Subpkg; use Pkg.Subpkg; + +procedure Test is + + procedure P (W : in out New_Window; X, Y : Natural) is + procedure Ident (C : Color) is null; + I : Integer; + 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; + + I := W ("ABCDEF"); + pragma Test_Statement; + end P; + +begin + null; +end Test; diff --git a/testsuite/tests/name_resolution/ud_indexing_6/test.out b/testsuite/tests/name_resolution/ud_indexing_6/test.out new file mode 100644 index 000000000..1be80e335 --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_6/test.out @@ -0,0 +1,197 @@ +Analyzing test.adb +################## + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: None + type: + expected type: +Expr: + references: + type: + expected type: + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: None + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: None + type: + expected type: + + +Done. diff --git a/testsuite/tests/name_resolution/ud_indexing_6/test.yaml b/testsuite/tests/name_resolution/ud_indexing_6/test.yaml new file mode 100644 index 000000000..173e325ff --- /dev/null +++ b/testsuite/tests/name_resolution/ud_indexing_6/test.yaml @@ -0,0 +1,2 @@ +driver: name-resolution +input_sources: [test.adb]