diff --git a/ada/ast.py b/ada/ast.py index 437fd7c38..491e4a058 100644 --- a/ada/ast.py +++ b/ada/ast.py @@ -20977,27 +20977,22 @@ def general_xref_equation(root=(T.Name, No(T.Name))): @langkit_property(return_type=Equation) def xref_equation(): - typ = Var(Entity.prefix.designated_type_impl) - return ( - Entity.suffix.sub_equation - & Bind(Self.prefix.ref_var, typ) - & Bind(Self.suffix.expected_type_var, typ) + Entity.prefix.xref_type_equation + & Entity.suffix.sub_equation + & Bind(Self.suffix.expected_type_var, Self.prefix.ref_var) & Entity.suffix.matches_expected_type - & Bind( - Self.type_var, - If( - # A qualified expression that appears as a statement - # denotes a machine code insertion, in GNAT, it is parsed - # as a parameterless procedure call. In that case, - # Self.type_var shouldn't denote any type. Note that we are - # more flexible than Ada since we allow any type to be code - # statements whereas Ada restricts that to types defined in - # package `System.Machine_Code` (see :rmlink:`13.8`). - Entity.parent.is_a(T.CallStmt), - No(AdaNode.entity), - typ - ) + & If( + # A qualified expression that appears as a statement + # denotes a machine code insertion, in GNAT, it is parsed + # as a parameterless procedure call. In that case, + # Self.type_var shouldn't denote any type. Note that we are + # more flexible than Ada since we allow any type to be code + # statements whereas Ada restricts that to types defined in + # package `System.Machine_Code` (see :rmlink:`13.8`). + Entity.parent.is_a(T.CallStmt), + LogicTrue(), + Bind(Self.type_var, Self.prefix.ref_var) ) ) diff --git a/testsuite/tests/name_resolution/qual_expr_prefix/test.adb b/testsuite/tests/name_resolution/qual_expr_prefix/test.adb new file mode 100644 index 000000000..0ec6d131c --- /dev/null +++ b/testsuite/tests/name_resolution/qual_expr_prefix/test.adb @@ -0,0 +1,18 @@ +procedure P (N : Natural) is + type Root is tagged record + My_Val : Natural := 0; + end record; + + type Any_Root_Access is access Root'Class; + + Obj : Root; + + Param : Root'Class := Root'Class (Obj); + + X : Any_Root_Access; +begin + -- All the names in the expression below must be resolved + + X := new P.Root'Class'(Param); + pragma Test_Statement; +end; diff --git a/testsuite/tests/name_resolution/qual_expr_prefix/test.out b/testsuite/tests/name_resolution/qual_expr_prefix/test.out new file mode 100644 index 000000000..99675b150 --- /dev/null +++ b/testsuite/tests/name_resolution/qual_expr_prefix/test.out @@ -0,0 +1,47 @@ +Analyzing test.adb +################## + +Resolving xrefs for node +********************************************************* + +Expr: + references: + type: + expected type: None +Expr: + type: + expected type: +Expr: + references: + type: + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: None + type: None + expected type: None +Expr: + type: + expected type: +Expr: + references: + type: + expected type: + + +Done. diff --git a/testsuite/tests/name_resolution/qual_expr_prefix/test.yaml b/testsuite/tests/name_resolution/qual_expr_prefix/test.yaml new file mode 100644 index 000000000..173e325ff --- /dev/null +++ b/testsuite/tests/name_resolution/qual_expr_prefix/test.yaml @@ -0,0 +1,2 @@ +driver: name-resolution +input_sources: [test.adb]