From db50f722ca619877451cde3371ec0db7f6f6026a Mon Sep 17 00:00:00 2001 From: Romain Beguet Date: Tue, 12 Mar 2024 15:19:27 +0100 Subject: [PATCH] Implement TypeExpr.subtype_constraint property. This also renames the subtype_constraints property to discriminant_constraints. --- ada/ast.py | 91 ++++++++++++------- .../discr.adb | 10 +- .../test.out | 14 ++- .../test.yaml | 0 .../properties/subtype_constraint/test.adb | 61 +++++++++++++ .../properties/subtype_constraint/test.out | 59 ++++++++++++ .../properties/subtype_constraint/test.yaml | 2 + 7 files changed, 189 insertions(+), 48 deletions(-) rename testsuite/tests/properties/{subtype_constraints => discriminant_constraints}/discr.adb (75%) rename testsuite/tests/properties/{subtype_constraints => discriminant_constraints}/test.out (73%) rename testsuite/tests/properties/{subtype_constraints => discriminant_constraints}/test.yaml (100%) create mode 100644 testsuite/tests/properties/subtype_constraint/test.adb create mode 100644 testsuite/tests/properties/subtype_constraint/test.out create mode 100644 testsuite/tests/properties/subtype_constraint/test.yaml diff --git a/ada/ast.py b/ada/ast.py index 751e27f91..d88115d4e 100644 --- a/ada/ast.py +++ b/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 diff --git a/testsuite/tests/properties/subtype_constraints/discr.adb b/testsuite/tests/properties/discriminant_constraints/discr.adb similarity index 75% rename from testsuite/tests/properties/subtype_constraints/discr.adb rename to testsuite/tests/properties/discriminant_constraints/discr.adb index 262024c9a..1056f6325 100644 --- a/testsuite/tests/properties/subtype_constraints/discr.adb +++ b/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; diff --git a/testsuite/tests/properties/subtype_constraints/test.out b/testsuite/tests/properties/discriminant_constraints/test.out similarity index 73% rename from testsuite/tests/properties/subtype_constraints/test.out rename to testsuite/tests/properties/discriminant_constraints/test.out index d41a9288b..0a73fc38f 100644 --- a/testsuite/tests/properties/subtype_constraints/test.out +++ b/testsuite/tests/properties/discriminant_constraints/test.out @@ -1,21 +1,19 @@ Working on node ================================================================ -Eval 'node.f_component_def.f_type_expr.p_subtype_constraints' +Eval 'node.p_type_expression.p_discriminant_constraints' Result: [] Working on node ======================================================== -Eval 'node.f_type_expr.p_subtype_constraints' -Result: [ actual=>, - actual=>, - actual=>] +Eval 'node.f_type_expr.p_discriminant_constraints' +Result: [] Working on node ======================================================== -Eval 'node.f_type_expr.p_subtype_constraints' +Eval 'node.f_type_expr.p_discriminant_constraints' Result: [ actual=>, actual=>, actual=>] @@ -23,7 +21,7 @@ Result: [ actual= ======================================================== -Eval 'node.f_type_expr.p_subtype_constraints' +Eval 'node.f_type_expr.p_discriminant_constraints' Result: [ actual=>, actual=>, actual=>] @@ -31,7 +29,7 @@ Result: [ actual= ======================================================== -Eval 'node.f_type_expr.p_subtype_constraints' +Eval 'node.f_type_expr.p_discriminant_constraints' Result: [ actual=>, actual=>, actual=>] diff --git a/testsuite/tests/properties/subtype_constraints/test.yaml b/testsuite/tests/properties/discriminant_constraints/test.yaml similarity index 100% rename from testsuite/tests/properties/subtype_constraints/test.yaml rename to testsuite/tests/properties/discriminant_constraints/test.yaml diff --git a/testsuite/tests/properties/subtype_constraint/test.adb b/testsuite/tests/properties/subtype_constraint/test.adb new file mode 100644 index 000000000..95b870b3b --- /dev/null +++ b/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; diff --git a/testsuite/tests/properties/subtype_constraint/test.out b/testsuite/tests/properties/subtype_constraint/test.out new file mode 100644 index 000000000..773d3f1b5 --- /dev/null +++ b/testsuite/tests/properties/subtype_constraint/test.out @@ -0,0 +1,59 @@ +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: None + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: None + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: + +Working on node +====================================================== + +Eval 'node.f_type_expr.p_subtype_constraint()' +Result: diff --git a/testsuite/tests/properties/subtype_constraint/test.yaml b/testsuite/tests/properties/subtype_constraint/test.yaml new file mode 100644 index 000000000..35ad4d5c4 --- /dev/null +++ b/testsuite/tests/properties/subtype_constraint/test.yaml @@ -0,0 +1,2 @@ +driver: inline-playground +input_sources: [test.adb]