[COMMITTED] gen: emit explicative messages when union constraints fail

[Jose E. Marchesi]

2022-05-05  Jose E. Marchesi  <jemarch@gnu.org>

        * libpoke/pkl-gen.pks (struct_mapper): Add an explicative message
        for union alternative constraint exceptions.
        (struct_constructor): Likewise.
        * testsuite/poke.pkl/union-constraint-1.pk: New test.
        * testsuite/poke.pkl/union-constraint-2.pk: Likewise.
        * testsuite/poke.pkl/union-constraint-3.pk: Likewise.
        * testsuite/poke.pkl/union-constraint-4.pk: Likewise.
        * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
---
 ChangeLog                                | 11 +++++++++++
 libpoke/pkl-gen.pks                      | 30 ++++++++++++++++++++++++++++++
 testsuite/Makefile.am                    |  4 ++++
 testsuite/poke.pkl/union-constraint-1.pk |  6 ++++++
 testsuite/poke.pkl/union-constraint-2.pk |  7 +++++++
 testsuite/poke.pkl/union-constraint-3.pk |  6 ++++++
 testsuite/poke.pkl/union-constraint-4.pk |  7 +++++++
 7 files changed, 71 insertions(+)
 create mode 100644 testsuite/poke.pkl/union-constraint-1.pk
 create mode 100644 testsuite/poke.pkl/union-constraint-2.pk
 create mode 100644 testsuite/poke.pkl/union-constraint-3.pk
 create mode 100644 testsuite/poke.pkl/union-constraint-4.pk

diff --git a/ChangeLog b/ChangeLog
index 30c49201..345e71d3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2022-05-05  Jose E. Marchesi  <jemarch@gnu.org>
+
+       * libpoke/pkl-gen.pks (struct_mapper): Add an explicative message
+       for union alternative constraint exceptions.
+       (struct_constructor): Likewise.
+       * testsuite/poke.pkl/union-constraint-1.pk: New test.
+       * testsuite/poke.pkl/union-constraint-2.pk: Likewise.
+       * testsuite/poke.pkl/union-constraint-3.pk: Likewise.
+       * testsuite/poke.pkl/union-constraint-4.pk: Likewise.
+       * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
+
 2022-04-14  Jose E. Marchesi  <jemarch@gnu.org>
 
        * libpoke/std.pk (Pk_With_Ios_Fn): New type.
diff --git a/libpoke/pkl-gen.pks b/libpoke/pkl-gen.pks
index 7405e82d..717cdea8 100644
--- a/libpoke/pkl-gen.pks
+++ b/libpoke/pkl-gen.pks
@@ -1149,6 +1149,21 @@
  .c {
         ;; No valid alternative found in union.
         push PVM_E_CONSTRAINT
+        push "msg"
+ .c pkl_ast_node struct_type_name = PKL_AST_TYPE_NAME (@type_struct);
+ .c if (struct_type_name)
+ .c {
+        .let #type_name = pvm_make_string (PKL_AST_IDENTIFIER_POINTER 
(struct_type_name))
+        push "no valid alternative found for union "
+        push #type_name
+        sconc
+        nip2
+ .c }
+ .c else
+ .c {
+        push "no valid alternative in union"
+ .c }
+        sset
         raise
  .c }
 .union_fields_done:
@@ -1656,6 +1671,21 @@
  .c {
         ;; No valid alternative found in union.
         push PVM_E_CONSTRAINT
+        push "msg"
+ .c pkl_ast_node struct_type_name = PKL_AST_TYPE_NAME (@type_struct);
+ .c if (struct_type_name)
+ .c {
+        .let #type_name = pvm_make_string (PKL_AST_IDENTIFIER_POINTER 
(struct_type_name))
+        push "no valid alternative found for union "
+        push #type_name
+        sconc
+        nip2
+ .c }
+ .c else
+ .c {
+        push "no valid alternative in union"
+ .c }
+        sset
         raise
  .c }
 .union_fields_done:
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index e24f6702..d0d4c8f7 100644
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -2267,6 +2267,10 @@ EXTRA_DIST = \
   poke.pkl/typeof-struct-3.pk \
   poke.pkl/typeof-struct-4.pk \
   poke.pkl/union-1.pk \
+  poke.pkl/union-constraint-1.pk \
+  poke.pkl/union-constraint-2.pk \
+  poke.pkl/union-constraint-3.pk \
+  poke.pkl/union-constraint-4.pk \
   poke.pkl/union-diag-1.pk \
   poke.pkl/union-diag-2.pk \
   poke.pkl/union-diag-3.pk \
diff --git a/testsuite/poke.pkl/union-constraint-1.pk 
b/testsuite/poke.pkl/union-constraint-1.pk
new file mode 100644
index 00000000..d3aec8e1
--- /dev/null
+++ b/testsuite/poke.pkl/union-constraint-1.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+type Foo = union { int a : a == 10; int b : b == 20; };
+
+/* { dg-command { try Foo {}; catch (Exception e) { if (e.code == 
EC_constraint) print e.msg + "\n"; } } } */
+/* { dg-output "no valid alternative found for union Foo" } */
diff --git a/testsuite/poke.pkl/union-constraint-2.pk 
b/testsuite/poke.pkl/union-constraint-2.pk
new file mode 100644
index 00000000..c3a5749b
--- /dev/null
+++ b/testsuite/poke.pkl/union-constraint-2.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x10 0x20 0x30 0x40  0x50 0x60 0x70 0x80   0x90 0xa0 0xb0 
0xc0} } */
+
+type Foo = union { int a : a == 10; int b : b == 20; };
+
+/* { dg-command { try Foo @ 1#B; catch (Exception e) { if (e.code == 
EC_constraint) print e.msg + "\n"; } } } */
+/* { dg-output "no valid alternative found for union Foo" } */
diff --git a/testsuite/poke.pkl/union-constraint-3.pk 
b/testsuite/poke.pkl/union-constraint-3.pk
new file mode 100644
index 00000000..4055a5da
--- /dev/null
+++ b/testsuite/poke.pkl/union-constraint-3.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+type Foo = struct { union { int a : a == 10; } u;  int b : b == 20; };
+
+/* { dg-command { try Foo {}; catch (Exception e) { if (e.code == 
EC_constraint) print e.msg + "\n"; } } } */
+/* { dg-output "no valid alternative in union" } */
diff --git a/testsuite/poke.pkl/union-constraint-4.pk 
b/testsuite/poke.pkl/union-constraint-4.pk
new file mode 100644
index 00000000..fffa4f8e
--- /dev/null
+++ b/testsuite/poke.pkl/union-constraint-4.pk
@@ -0,0 +1,7 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x10 0x20 0x30 0x40  0x50 0x60 0x70 0x80   0x90 0xa0 0xb0 
0xc0} } */
+
+type Foo = struct { union { int a : a == 10; } u;  int b : b == 20; };
+
+/* { dg-command { try Foo @ 1#B; catch (Exception e) { if (e.code == 
EC_constraint) print e.msg + "\n"; } } } */
+/* { dg-output "no valid alternative in union" } */
-- 
2.11.0