Merge branch 'topic/dw_view_conv' into 'master'

Fix Downward_View_Conversions rule

Closes #131

See merge request eng/libadalang/langkit-query-language!114

lkql_checker/share/lkql/downward_view_conversions.lkql

@@ -1,23 +1,38 @@
 # Flag downward view conversions.
 
+fun is_downward_conv(expr_type, t) =
+    |" Whether converting from `expr_type` to `t` is a downward view conversion
+    |" of tagged types
+    expr_type is AdaNode
+    and t is AdaNode
+    and t.p_full_view() is target@BaseTypeDecl
+      # Compare specific types in case one or the other is the classwide
+      # version
+      when target.p_specific_type() != expr_type.p_specific_type()
+       and target.p_is_derived_type(expr_type)
+
+fun is_tagged(typ) =
+    |" Whether typ is tagged or an access to a tagged type
+    |" TODO: Maybe share in the stdlib?
+    typ.p_is_tagged_type()
+    or typ.p_accessed_type() is BaseTypeDecl(p_is_tagged_type() is true)
+
 @check(message="downward view conversion",
        category="Style", subcategory="Object Orientation")
 fun downward_view_conversions(node) =
 
     node is CallExpr(
         # Select type conversions
         p_referenced_decl() is BaseTypeDecl(
-            p_base_subtype() is t@BaseTypeDecl(p_is_tagged_type() is true)
+            p_base_subtype() is t@BaseTypeDecl when is_tagged (t)
         )
     )
 
     # Where the target type is derived from the type of the conversion argument,
     # taking full views into account.
     when node.f_suffix[1].f_r_expr?.p_expression_type().p_full_view()
         is expr_type@BaseTypeDecl
-
-     when t.p_full_view() is target@BaseTypeDecl
-      # Compare specific types in case one or the other is the classwide
-      # version
-      when target.p_specific_type() != expr_type.p_specific_type()
-       and target.p_is_derived_type(expr_type)
+           # Regular case
+           when is_downward_conv(expr_type, t)
+                # Downward view conversion case
+                or is_downward_conv (expr_type.p_accessed_type(), t.p_accessed_type())

testsuite/tests/checks/downward_view_conversions/test.out

@@ -1,8 +1,12 @@
-test_downwardconv.adb:20:22: rule violation: downward view conversion
-20 |          Var : T2 := T2 (X);                   --  FLAG
+test_downwardconv.adb:22:22: rule violation: downward view conversion
+22 |          Var : T2 := T2 (X);                          --  FLAG
    |                      ^^^^^^
 
-test_downwardconv.adb:22:17: rule violation: downward view conversion
-22 |          Proc2 (T2'Class (X));                 --  FLAG
+test_downwardconv.adb:24:31: rule violation: downward view conversion
+24 |          Var_2 : T2_Access := T2_Access (X_Acc);      -- FLAG
+   |                               ^^^^^^^^^^^^^^^^^
+
+test_downwardconv.adb:26:17: rule violation: downward view conversion
+26 |          Proc2 (T2'Class (X));                        --  FLAG
    |                 ^^^^^^^^^^^^
 

testsuite/tests/checks/downward_view_conversions/test_downwardconv.adb

@@ -1,9 +1,11 @@
 procedure Main is
    package Foo is
       type T1 is tagged private;
+      type T1_Access is access all T1'Class;
       procedure Proc1 (X : in out T1'Class);
 
       type T2 is new T1 with private;
+      type T2_Access is access all T2'Class;
       procedure Proc2 (X : in out T2'Class);
 
    private
@@ -17,9 +19,11 @@ procedure Main is
    package body Foo is
 
       procedure Proc1 (X : in out T1'Class) is
-         Var : T2 := T2 (X);                   --  FLAG
+         Var : T2 := T2 (X);                          --  FLAG
+         X_Acc : T1_Access := X'Unrestricted_Access;
+         Var_2 : T2_Access := T2_Access (X_Acc);      -- FLAG
       begin
-         Proc2 (T2'Class (X));                 --  FLAG
+         Proc2 (T2'Class (X));                        --  FLAG
 
          --  NOFLAG (W324-006, neither converting from or to classwide should
          --  trigger this check)