Merge branch 'topic/1399' into 'master'

Rework QualExpr xref equation

Closes #1399

See merge request eng/libadalang/libadalang!1675

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)
             )
         )
 

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;

testsuite/tests/name_resolution/qual_expr_prefix/test.out

@@ -0,0 +1,47 @@
+Analyzing test.adb
+##################
+
+Resolving xrefs for node <AssignStmt test.adb:16:4-16:34>
+*********************************************************
+
+Expr: <Id "X" test.adb:16:4-16:5>
+  references:    <DefiningName "X" test.adb:12:4-12:5>
+  type:          <ConcreteTypeDecl ["Any_Root_Access"] test.adb:6:4-6:46>
+  expected type: None
+Expr: <Allocator test.adb:16:9-16:33>
+  type:          <ConcreteTypeDecl ["Any_Root_Access"] test.adb:6:4-6:46>
+  expected type: <ConcreteTypeDecl ["Any_Root_Access"] test.adb:6:4-6:46>
+Expr: <QualExpr test.adb:16:13-16:33>
+  references:    <DefiningName "Root" test.adb:2:9-2:13>
+  type:          <ClasswideTypeDecl ["Root"] test.adb:2:4-4:15>
+  expected type: None
+Expr: <AttributeRef test.adb:16:13-16:25>
+  references:    <DefiningName "Root" test.adb:2:9-2:13>
+  type:          None
+  expected type: None
+Expr: <DottedName test.adb:16:13-16:19>
+  references:    <DefiningName "Root" test.adb:2:9-2:13>
+  type:          None
+  expected type: None
+Expr: <Id "P" test.adb:16:13-16:14>
+  references:    <DefiningName "P" test.adb:1:11-1:12>
+  type:          None
+  expected type: None
+Expr: <Id "Root" test.adb:16:15-16:19>
+  references:    <DefiningName "Root" test.adb:2:9-2:13>
+  type:          None
+  expected type: None
+Expr: <Id "Class" test.adb:16:20-16:25>
+  references:    None
+  type:          None
+  expected type: None
+Expr: <ParenExpr test.adb:16:26-16:33>
+  type:          <ClasswideTypeDecl ["Root"] test.adb:2:4-4:15>
+  expected type: <ClasswideTypeDecl ["Root"] test.adb:2:4-4:15>
+Expr: <Id "Param" test.adb:16:27-16:32>
+  references:    <DefiningName "Param" test.adb:10:4-10:9>
+  type:          <ClasswideTypeDecl ["Root"] test.adb:2:4-4:15>
+  expected type: <ClasswideTypeDecl ["Root"] test.adb:2:4-4:15>
+
+
+Done.

testsuite/tests/name_resolution/qual_expr_prefix/test.yaml

@@ -0,0 +1,2 @@
+driver: name-resolution
+input_sources: [test.adb]