Merge branch 'topic/1316' into 'master'

Implement TypeExpr.subtype_constraint property.

Closes #1317 and #1316

See merge request eng/libadalang/libadalang!1573

ada/ast.py

@@ -9327,6 +9327,38 @@ def xref_equation():
             )
         )
 
+    @langkit_property(public=True, return_type=T.ParamActual.array)
+    def discriminant_params():
+        """
+        Returns an array of pairs, associating each discriminant to its
+        actual or default expression.
+        """
+        # Build a discriminants list with their default expressions
+        discrs = Var(
+            Entity.subtype.discriminants_list.mapcat(
+                lambda d: Let(
+                    lambda ds=d.cast(DiscriminantSpec):
+                    ds.ids.map(
+                        lambda i: ParamActual.new(
+                            param=i,
+                            actual=ds.default_expr
+                        )
+                    )
+                )
+            )
+        )
+
+        # Update the constraints expressions if some are provided
+        return Entity.constraints.then(
+            lambda c: discrs.map(
+                lambda i, dp: ParamActual.new(
+                    param=dp.param,
+                    actual=c.actual_for_param_at(dp.param, i, dp.actual)
+                )
+            ),
+            default_val=discrs
+        )
+
 
 @abstract
 @has_abstract_list
@@ -10431,6 +10463,30 @@ def element_type():
     def canonical_type():
         return Entity.designated_type._.canonical_type
 
+    @langkit_property(return_type=T.Constraint.entity, public=True,
+                      dynamic_vars=[default_origin()])
+    def subtype_constraint():
+        """
+        Return the constraint that this type expression defines on its
+        designated subtype, if any.
+        """
+        return Entity.cast(SubtypeIndication)._.constraint._or(
+            Entity.designated_type.cast(SubtypeDecl).then(
+                lambda st: st.subtype.subtype_constraint
+            )
+        )
+
+    @langkit_property(return_type=T.ParamActual.array, public=True)
+    def discriminant_constraints():
+        """
+        If this type expression designates a constrained discriminated type,
+        return an array of pairs, associating each discriminant to its actual
+        or default expression.
+        """
+        return Entity.subtype_constraint.cast(CompositeConstraint).then(
+            lambda cc: cc.discriminant_params
+        )
+
 
 @synthetic
 class EnumLitSynthTypeExpr(TypeExpr):
@@ -10537,41 +10593,6 @@ def complete_items():
             )
         )
 
-    @langkit_property(public=True, return_type=ParamActual.array)
-    def subtype_constraints():
-        """
-        Returns an array of pairs, associating formal parameters to actual or
-        default expressions.
-        """
-        constraints = Var(
-            Entity.constraint._.cast(CompositeConstraint).constraints
-        )
-        # Build a discriminants list with their default expressions
-        discrs = Var(
-            Entity.designated_type_decl._.discriminants_list.mapcat(
-                lambda d: Let(
-                    lambda ds=d.cast(DiscriminantSpec):
-                    ds.ids.map(
-                        lambda i: ParamActual.new(
-                            param=i,
-                            actual=ds.default_expr
-                        )
-                    )
-                )
-            )
-        )
-
-        # Update the constraints expressions if some are provided
-        return constraints.then(
-            lambda c: discrs.map(
-                lambda i, dp: ParamActual.new(
-                    param=dp.param,
-                    actual=c.actual_for_param_at(dp.param, i, dp.actual)
-                )
-            ),
-            default_val=discrs
-        )
-
     @langkit_property()
     def xref_equation():
         # Called by allocator.xref_equation, since the suffix can be either a

testsuite/tests/properties/subtype_constraints/discr.adb → testsuite/tests/properties/discriminant_constraints/discr.adb

@@ -13,19 +13,19 @@ procedure Discr is
             when others =>
                Cylinder   : Cylinder_Index;
                Track1     : Track_Number := Trk1;
-               --% node.f_component_def.f_type_expr.p_subtype_constraints
+               --% node.p_type_expression.p_discriminant_constraints
                Track2     : Track_Number := Trk2;
          end case;
       end record;
 
    P1 : Peripheral;
-   --% node.f_type_expr.p_subtype_constraints
+   --% node.f_type_expr.p_discriminant_constraints
    P2 : Peripheral (Unit => Printer, Trk1 => 2, Trk2 => 1);
-   --% node.f_type_expr.p_subtype_constraints
+   --% node.f_type_expr.p_discriminant_constraints
    P3 : Peripheral (Printer, 3, 4);
-   --% node.f_type_expr.p_subtype_constraints
+   --% node.f_type_expr.p_discriminant_constraints
    P4 : Peripheral (Trk1|Trk2 => 2, Unit => Printer);
-   --% node.f_type_expr.p_subtype_constraints
+   --% node.f_type_expr.p_discriminant_constraints
 
 begin
    null;

testsuite/tests/properties/subtype_constraints/test.out → testsuite/tests/properties/discriminant_constraints/test.out

@@ -1,37 +1,35 @@
 Working on node <ComponentDecl ["Track1"] discr.adb:15:16-15:50>
 ================================================================
 
-Eval 'node.f_component_def.f_type_expr.p_subtype_constraints'
+Eval 'node.p_type_expression.p_discriminant_constraints'
 Result: []
 
 Working on node <ObjectDecl ["P1"] discr.adb:21:4-21:20>
 ========================================================
 
-Eval 'node.f_type_expr.p_subtype_constraints'
-Result: [<ParamActual param=<DefiningName "Unit" discr.adb:7:20-7:24> actual=<Id "Disk" discr.adb:7:37-7:41>>,
-         <ParamActual param=<DefiningName "Trk1" discr.adb:7:43-7:47> actual=<Int discr.adb:7:72-7:73>>,
-         <ParamActual param=<DefiningName "Trk2" discr.adb:7:49-7:53> actual=<Int discr.adb:7:72-7:73>>]
+Eval 'node.f_type_expr.p_discriminant_constraints'
+Result: []
 
 Working on node <ObjectDecl ["P2"] discr.adb:23:4-23:60>
 ========================================================
 
-Eval 'node.f_type_expr.p_subtype_constraints'
+Eval 'node.f_type_expr.p_discriminant_constraints'
 Result: [<ParamActual param=<DefiningName "Unit" discr.adb:7:20-7:24> actual=<Id "Printer" discr.adb:23:29-23:36>>,
          <ParamActual param=<DefiningName "Trk1" discr.adb:7:43-7:47> actual=<Int discr.adb:23:46-23:47>>,
          <ParamActual param=<DefiningName "Trk2" discr.adb:7:49-7:53> actual=<Int discr.adb:23:57-23:58>>]
 
 Working on node <ObjectDecl ["P3"] discr.adb:25:4-25:36>
 ========================================================
 
-Eval 'node.f_type_expr.p_subtype_constraints'
+Eval 'node.f_type_expr.p_discriminant_constraints'
 Result: [<ParamActual param=<DefiningName "Unit" discr.adb:7:20-7:24> actual=<Id "Printer" discr.adb:25:21-25:28>>,
          <ParamActual param=<DefiningName "Trk1" discr.adb:7:43-7:47> actual=<Int discr.adb:25:30-25:31>>,
          <ParamActual param=<DefiningName "Trk2" discr.adb:7:49-7:53> actual=<Int discr.adb:25:33-25:34>>]
 
 Working on node <ObjectDecl ["P4"] discr.adb:27:4-27:54>
 ========================================================
 
-Eval 'node.f_type_expr.p_subtype_constraints'
+Eval 'node.f_type_expr.p_discriminant_constraints'
 Result: [<ParamActual param=<DefiningName "Unit" discr.adb:7:20-7:24> actual=<Id "Printer" discr.adb:27:45-27:52>>,
          <ParamActual param=<DefiningName "Trk1" discr.adb:7:43-7:47> actual=<Int discr.adb:27:34-27:35>>,
          <ParamActual param=<DefiningName "Trk2" discr.adb:7:49-7:53> actual=<Int discr.adb:27:34-27:35>>]

testsuite/tests/properties/subtype_constraint/test.adb

@@ -0,0 +1,61 @@
+procedure Test is
+   subtype My_Nat is Integer range 0 .. 100;
+
+   type Arr is array (Integer range <>) of Integer;
+
+   subtype Sub_Arr is Arr;
+   subtype Nat_Arr is Sub_Arr (Natural);
+   subtype Sub_Nat_Arr is Nat_Arr;
+
+   type New_Nat_Arr is new Sub_Arr (Natural);
+
+   type New_Arr is new Sub_Arr;
+
+   subtype Nat_New_Arr is New_Arr (Natural);
+
+   type Mat is array (Integer range <>, Integer range <>) of Integer;
+
+   subtype Nat_Mat is Mat (Natural, Natural);
+
+   type Vec_3 is array (1 .. 3) of Integer;
+
+   type Discr_Rec (X, Y : Natural) is record
+      K : Integer;
+   end record;
+
+   subtype Sub_Rec is Discr_Rec (X => 1, Y => 2);
+
+   type Der_Rec is new Discr_Rec (X => 1, Y => 3);
+
+   A : My_Nat;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   B : Sub_Nat_Arr;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   C : New_Nat_Arr;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   D : Nat_New_Arr;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   E : Nat_Mat;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   F : Vec_3;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   G : Sub_Rec;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   H : My_Nat range 1 .. 10;
+   --% node.f_type_expr.p_subtype_constraint()
+
+   I : Sub_Arr (1 .. 3);
+   --% node.f_type_expr.p_subtype_constraint()
+
+   J : Discr_Rec (X => 1, Y => 4);
+   --% node.f_type_expr.p_subtype_constraint()
+begin
+   null;
+end Test;

testsuite/tests/properties/subtype_constraint/test.out

@@ -0,0 +1,59 @@
+Working on node <ObjectDecl ["A"] test.adb:30:4-30:15>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <RangeConstraint test.adb:2:30-2:44>
+
+Working on node <ObjectDecl ["B"] test.adb:33:4-33:20>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <CompositeConstraint test.adb:7:31-7:40>
+
+Working on node <ObjectDecl ["C"] test.adb:36:4-36:20>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: None
+
+Working on node <ObjectDecl ["D"] test.adb:39:4-39:20>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <CompositeConstraint test.adb:14:35-14:44>
+
+Working on node <ObjectDecl ["E"] test.adb:42:4-42:16>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <CompositeConstraint test.adb:18:27-18:45>
+
+Working on node <ObjectDecl ["F"] test.adb:45:4-45:14>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: None
+
+Working on node <ObjectDecl ["G"] test.adb:48:4-48:16>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <CompositeConstraint test.adb:26:33-26:49>
+
+Working on node <ObjectDecl ["H"] test.adb:51:4-51:29>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <RangeConstraint test.adb:51:15-51:28>
+
+Working on node <ObjectDecl ["I"] test.adb:54:4-54:25>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <CompositeConstraint test.adb:54:16-54:24>
+
+Working on node <ObjectDecl ["J"] test.adb:57:4-57:35>
+======================================================
+
+Eval 'node.f_type_expr.p_subtype_constraint()'
+Result: <CompositeConstraint test.adb:57:18-57:34>

testsuite/tests/properties/subtype_constraint/test.yaml

@@ -0,0 +1,2 @@
+driver: inline-playground
+input_sources: [test.adb]