Data Decomposition: fix handling of subtype decls as tagged type base

AdaCore · Dec 19, 2024 · 87d11c2 · 87d11c2
1 parent b822c08
commit 87d11c2
Show file tree

Hide file tree

Showing 6 changed files with 181 additions and 18 deletions.
diff --git a/extensions/src/libadalang-data_decomposition.adb b/extensions/src/libadalang-data_decomposition.adb
@@ -507,24 +507,31 @@ package body Libadalang.Data_Decomposition is
                                      Def  : Type_Def;
                                      Repr : Repinfo_Access))
    is
-      --  Get the full view for ``Self`` and ensure it is a record type, as
-      --  well as the type that ``Repr`` describes.
+      --  Get the full view of ``Decl``'s canonical type and ensure it is a
+      --  record type, as well as the type that ``Repr`` describes.
 
-      CTD : constant Concrete_Type_Decl :=
-        Decl.P_Full_View.As_Concrete_Type_Decl;
-      Def : constant Type_Def := CTD.F_Type_Def;
+      TD  : constant Base_Type_Decl := Decl.P_Canonical_Type.P_Full_View;
+      CTD : Concrete_Type_Decl;
+      Def : Type_Def;
    begin
-      if not CTD.P_Is_Record_Type then
+      if TD.Kind /= Ada_Concrete_Type_Decl then
          raise Type_Mismatch_Error with
-           "record type expected, got " & CTD.Image;
+           "record type declaration expected, got " & TD.Image;
       elsif Repr.Kind /= Record_Type then
          raise Type_Mismatch_Error with
            "record type repinfo expected, got " & Repr.Kind'Image;
       end if;
 
+      CTD := TD.As_Concrete_Type_Decl;
+      if not CTD.P_Is_Record_Type then
+         raise Type_Mismatch_Error with
+           "record type expected, got " & TD.Image;
+      end if;
+
       --  If this is a derived type, first iterate on the type that is derived
       --  (the base type).
 
+      Def := CTD.F_Type_Def;
       if Def.Kind = Ada_Derived_Type_Def then
          declare
             --  Start resolving the base type

diff --git a/testsuite/tests/dda/tagged/p1.ads b/testsuite/tests/dda/tagged/p1.ads
@@ -24,6 +24,8 @@ package P1 is
 
    type R6_Parent is private;
 
+   subtype R8_Parent is R3_Parent (2);
+
 private
 
    type R5_Parent is tagged record

diff --git a/testsuite/tests/dda/tagged/p1.ads.json b/testsuite/tests/dda/tagged/p1.ads.json
@@ -129,9 +129,48 @@
   "Scalar_Storage_Order": "System.Low_Order_First"
 }
 ,
+{
+  "name": "P1.R8_Parent",
+  "location": "p1.ads:27:12",
+  "Size": 128,
+  "Alignment": 8,
+  "record": [
+    {
+      "name": "N",
+      "discriminant": 1,
+      "Position":  8,
+      "First_Bit": 0,
+      "Size": 32
+    },
+    {
+      "name": "_Tag",
+      "Position":  0,
+      "First_Bit": 0,
+      "Size": 64
+    },
+    {
+      "name": "X1",
+      "Position": 12,
+      "First_Bit": 0,
+      "Size": 16
+    }
+  ],
+  "Bit_Order": "System.Low_Order_First",
+  "Scalar_Storage_Order": "System.Low_Order_First"
+}
+,
+{
+  "name": "P1.R8_Parent.T3s",
+  "location": "p1.ads:27:4",
+  "Size": 16,
+  "Alignment": 1,
+  "Component_Size": 8,
+  "Scalar_Storage_Order": "System.Low_Order_First"
+}
+,
 {
   "name": "P1.R5_Parent",
-  "location": "p1.ads:29:9",
+  "location": "p1.ads:31:9",
   "Size": 128,
   "Alignment": 8,
   "record": [
@@ -154,7 +193,7 @@
 ,
 {
   "name": "P1.R6_Parent",
-  "location": "p1.ads:33:9",
+  "location": "p1.ads:35:9",
   "Size": 128,
   "Alignment": 8,
   "record": [

diff --git a/testsuite/tests/dda/tagged/p2.ads b/testsuite/tests/dda/tagged/p2.ads
@@ -36,4 +36,8 @@ package P2 is
       X2 : Integer;
    end record;
 
+   type R8_Child is new R8_Parent with record
+      X2 : Integer;
+   end record;
+
 end P2;
diff --git a/testsuite/tests/dda/tagged/p2.ads.json b/testsuite/tests/dda/tagged/p2.ads.json
@@ -192,4 +192,96 @@
   "Bit_Order": "System.Low_Order_First",
   "Scalar_Storage_Order": "System.Low_Order_First"
 }
+,
+{
+  "name": "P2.R8_Child",
+  "location": "p2.ads:39:9",
+  "Size": 192,
+  "Alignment": 8,
+  "record": [
+    {
+      "name": "N",
+      "discriminant": 1,
+      "Position":  8,
+      "First_Bit": 0,
+      "Size": 32
+    },
+    {
+      "name": "_Tag",
+      "Position":  0,
+      "First_Bit": 0,
+      "Size": 64
+    },
+    {
+      "name": "X1",
+      "Position": 12,
+      "First_Bit": 0,
+      "Size": 16
+    },
+    {
+      "name": "X2",
+      "Position": 16,
+      "First_Bit": 0,
+      "Size": 32
+    }
+  ],
+  "Bit_Order": "System.Low_Order_First",
+  "Scalar_Storage_Order": "System.Low_Order_First"
+}
+,
+{
+  "name": "P2.R8_Child.T8s",
+  "location": "p2.ads:39:4",
+  "Size": 16,
+  "Alignment": 1,
+  "Component_Size": 8,
+  "Scalar_Storage_Order": "System.Low_Order_First"
+}
+,
+{
+  "name": "P2.Tr8_Childb",
+  "location": "p2.ads:39:4",
+  "Object_Size": 17179869376,
+  "Value_Size": { "code": "&", "operands": [ { "code": "+", "operands": [ { "code": "*", "operands": [ { "code": "+", "operands": [ { "code": "&", "operands": [ { "code": "+", "operands": [ { "code": "#", "operands": [ 1 ] }, 19 ] }, { "code": "-", "operands": [ 8 ] } ] }, 4 ] }, 8 ] }, 63 ] }, { "code": "-", "operands": [ 64 ] } ] },
+  "Alignment": 8,
+  "record": [
+    {
+      "name": "N",
+      "discriminant": 1,
+      "Position":  8,
+      "First_Bit": 0,
+      "Size": 32
+    },
+    {
+      "name": "_Tag",
+      "Position":  0,
+      "First_Bit": 0,
+      "Size": 64
+    },
+    {
+      "name": "X1",
+      "Position": 12,
+      "First_Bit": 0,
+      "Size": { "code": "*", "operands": [ { "code": "#", "operands": [ 1 ] }, 8 ] }
+    },
+    {
+      "name": "X2",
+      "Position": { "code": "&", "operands": [ { "code": "+", "operands": [ { "code": "#", "operands": [ 1 ] }, 19 ] }, { "code": "-", "operands": [ 8 ] } ] },
+      "First_Bit": 0,
+      "Size": 32
+    }
+  ],
+  "Bit_Order": "System.Low_Order_First",
+  "Scalar_Storage_Order": "System.Low_Order_First"
+}
+,
+{
+  "name": "P2.Tr8_Childb.T5s",
+  "location": "p2.ads:39:4",
+  "Object_Size": 17179869176,
+  "Value_Size": { "code": "*", "operands": [ { "code": "#", "operands": [ 1 ] }, 8 ] },
+  "Alignment": 1,
+  "Component_Size": 8,
+  "Scalar_Storage_Order": "System.Low_Order_First"
+}
 ]
diff --git a/testsuite/tests/dda/tagged/test.out b/testsuite/tests/dda/tagged/test.out
@@ -43,33 +43,42 @@ Alignment: 8
 Object_Size | Value_Size: 128 | 128
 Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
 * Artificial component "_tag" at 0, size: 64
-* <DefiningName "X1" p1.ads:30:7-30:9> at 8, size: 32
+* <DefiningName "X1" p1.ads:32:7-32:9> at 8, size: 32
 
 Representation information for <ConcreteTypeDecl ["R6_Parent"] p1.ads:25:4-25:30>:
 Kind: RECORD_TYPE
 Alignment: 8
 Object_Size | Value_Size: 128 | 128
 Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
 * Artificial component "_tag" at 0, size: 64
-* <DefiningName "X1" p1.ads:34:7-34:9> at 8, size: 8
-* <DefiningName "X2" p1.ads:34:11-34:13> at 9, size: 8
+* <DefiningName "X1" p1.ads:36:7-36:9> at 8, size: 8
+* <DefiningName "X2" p1.ads:36:11-36:13> at 9, size: 8
 
-Representation information for <ConcreteTypeDecl ["R5_Parent"] p1.ads:29:4-31:15>:
+Representation information for <SubtypeDecl ["R8_Parent"] p1.ads:27:4-27:39>:
+Kind: RECORD_TYPE
+Alignment: 8
+Object_Size | Value_Size: 128 | 128
+Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
+* <DefiningName "N" p1.ads:10:20-10:21> (discriminant 1) at 8, size: 32
+* Artificial component "_tag" at 0, size: 64
+* <DefiningName "X1" p1.ads:11:7-11:9> at 12, size: 16
+
+Representation information for <ConcreteTypeDecl ["R5_Parent"] p1.ads:31:4-33:15>:
 Kind: RECORD_TYPE
 Alignment: 8
 Object_Size | Value_Size: 128 | 128
 Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
 * Artificial component "_tag" at 0, size: 64
-* <DefiningName "X1" p1.ads:30:7-30:9> at 8, size: 32
+* <DefiningName "X1" p1.ads:32:7-32:9> at 8, size: 32
 
-Representation information for <ConcreteTypeDecl ["R6_Parent"] p1.ads:33:4-35:15>:
+Representation information for <ConcreteTypeDecl ["R6_Parent"] p1.ads:35:4-37:15>:
 Kind: RECORD_TYPE
 Alignment: 8
 Object_Size | Value_Size: 128 | 128
 Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
 * Artificial component "_tag" at 0, size: 64
-* <DefiningName "X1" p1.ads:34:7-34:9> at 8, size: 8
-* <DefiningName "X2" p1.ads:34:11-34:13> at 9, size: 8
+* <DefiningName "X1" p1.ads:36:7-36:9> at 8, size: 8
+* <DefiningName "X2" p1.ads:36:11-36:13> at 9, size: 8
 
 Analyzing p2.ads
 ################
@@ -196,7 +205,7 @@ Alignment: 8
 Object_Size | Value_Size: 192 | 192
 Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
 * Artificial component "_tag" at 0, size: 64
-* <DefiningName "X1" p1.ads:30:7-30:9> at 8, size: 32
+* <DefiningName "X1" p1.ads:32:7-32:9> at 8, size: 32
 * <DefiningName "X1" p2.ads:30:7-30:9> at 16, size: 32
 
 No representation information for <ConcreteTypeDecl ["R6_Child"] p2.ads:33:4-33:35>
@@ -209,4 +218,14 @@ Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
 * Artificial component "_tag" at 0, size: 64
 * <DefiningName "X2" p2.ads:36:7-36:9> at 16, size: 32
 
+Representation information for <ConcreteTypeDecl ["R8_Child"] p2.ads:39:4-41:15>:
+Kind: RECORD_TYPE
+Alignment: 8
+Object_Size | Value_Size: 192 | 192
+Bit_Order | Scalar_Storage_Order: LOW_ORDER_FIRST | LOW_ORDER_FIRST
+* <DefiningName "N" p1.ads:10:20-10:21> (discriminant 1) at 8, size: 32
+* Artificial component "_tag" at 0, size: 64
+* <DefiningName "X1" p1.ads:11:7-11:9> at 12, size: 16
+* <DefiningName "X2" p2.ads:40:7-40:9> at 16, size: 32
+
 Done.
-Original file line number
+Diff line change
@@ Expand Up / @@ -24,6 +24,8 @@ package P1 is @@
        type R6_Parent is private;
+       subtype R8_Parent is R3_Parent (2);
     private
        type R5_Parent is tagged record
@@ Expand Down @@