Merge branch 'topic/48' into 'master'

Handle SubtypeDecl nodes in controlled_type_declarations rule.

Closes #48

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

Author: Roldak

lkql_checker/share/lkql/controlled_type_declarations.lkql

@@ -8,19 +8,14 @@
 #   declared in `Ada.Finalization' but has a controlled component is not
 #   checked.
 
+import stdlib
+
 fun canonical_fully_qualified_name(t) =
     t.f_name?.p_basic_decl()?.p_canonical_fully_qualified_name()
 
-selector complete_super_types
-    | b@BaseTypeDecl when b.p_is_private() =>
-        rec(*this.p_next_part()?.p_base_types?())
-    | BaseTypeDecl =>
-        rec(*this.p_base_types())
-    | * => ()
-
 @check(message="declaration of controlled type", category="Feature")
 fun controlled_type_declarations(node) =
-    node is BaseTypeDecl (
-        any complete_super_types: b
+    node is TypeDecl (
+        any stdlib.complete_super_types: b
         when canonical_fully_qualified_name(b) == "ada.finalization.controlled"
     )

lkql_checker/share/lkql/stdlib.lkql

@@ -5,10 +5,29 @@
 |" library.
 
 selector super_types
-    |" Yields the chain of super types for the given type
+    |" Yields the chain of super types of the given type, as viewed from that
+    |" type. Hence, for a type T which public view derives from a type A but
+    |" private view derives from a type B (which itself derives from A),
+    |" invoking this selector on the public view of T will yield A.
     | BaseTypeDecl => rec(*this.p_base_types())
     | * => ()
 
+selector complete_super_types
+    |" Yields the chain of super types of the given type in their most complete
+    |" view. Hence, for a type T which public view derives from a type A but
+    |" private view derives from a type B (which itself derives from A),
+    |" invoking this selector on the public view of T will yield B and then A.
+    | b@BaseTypeDecl when b.p_is_private() => {
+        # We go through `p_base_subtype` to correctly handle SubtypeDecl nodes:
+        # while they themselves don't have a next part, their base type may.
+        val np = this.p_base_subtype().p_next_part();
+        val typ = if np == null then this else np;
+        rec(*typ.p_base_types())
+    }
+    | BaseTypeDecl =>
+        rec(*this.p_base_types())
+    | * => ()
+
 selector semantic_parent
     |" Return all semantic parent nodes starting from a given node.
     | null     => ()

testsuite/tests/checks/controlled_type_declarations/controlled_type_declarations.ads

@@ -1,6 +1,10 @@
 with Ada.Finalization;
 package Foo is
    type Resource is new Ada.Finalization.Controlled with private;  --  FLAG
+
+   subtype Sub_Resource is Resource;  -- NOFLAG
+
+   type New_Resource is new Sub_Resource;  --  FLAG
 private
    type Resource is new Ada.Finalization.Controlled with null record; --  FLAG
    type Ressource_Array is new Array (Positive range <>)

testsuite/tests/checks/controlled_type_declarations/test.out

@@ -2,7 +2,11 @@ controlled_type_declarations.ads:3:9: rule violation: declaration of controlled
 3 |    type Resource is new Ada.Finalization.Controlled with private;  --  FLAG
   |         ^^^^^^^^
 
-controlled_type_declarations.ads:5:9: rule violation: declaration of controlled type
-5 |    type Resource is new Ada.Finalization.Controlled with null record; --  FLAG
+controlled_type_declarations.ads:7:9: rule violation: declaration of controlled type
+7 |    type New_Resource is new Sub_Resource;  --  FLAG
+  |         ^^^^^^^^^^^^
+
+controlled_type_declarations.ads:9:9: rule violation: declaration of controlled type
+9 |    type Resource is new Ada.Finalization.Controlled with null record; --  FLAG
   |         ^^^^^^^^