[COMMITTED] pkl: gen: introduce a writer for union types

[Jose E. Marchesi]

The regular struct writer was not able to handle union values
properly.  This commit adds code generation for dedicated writers for
union types, along with some tests.

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

        * libpoke/pkl-gen.pks (union_writer): New function.
        * libpoke/pkl-gen.c (pkl_gen_pr_decl): Compile an union writer for
        unions.
        (pkl_gen_pr_type_struct): Likewise.
        (LMAP): Likewise.
        * testsuite/poke.map/write-unions-1.pk: New test.
        * testsuite/poke.map/write-unions-2.pk: Likewise.
        * testsuite/poke.map/write-unions-3.pk: Likewise.
        * testsuite/poke.map/ass-map-23.pk: Likewise.
        * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
---
 ChangeLog                            | 13 ++++++
 libpoke/pkl-gen.c                    | 17 ++++++--
 libpoke/pkl-gen.pks                  | 82 +++++++++++++++++++++++++++++++++++-
 testsuite/Makefile.am                |  4 ++
 testsuite/poke.map/ass-map-23.pk     | 11 +++++
 testsuite/poke.map/write-unions-1.pk | 10 +++++
 testsuite/poke.map/write-unions-2.pk | 19 +++++++++
 testsuite/poke.map/write-unions-3.pk | 25 +++++++++++
 8 files changed, 176 insertions(+), 5 deletions(-)
 create mode 100644 testsuite/poke.map/ass-map-23.pk
 create mode 100644 testsuite/poke.map/write-unions-1.pk
 create mode 100644 testsuite/poke.map/write-unions-2.pk
 create mode 100644 testsuite/poke.map/write-unions-3.pk

diff --git a/ChangeLog b/ChangeLog
index 3b163850..ab294d54 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,18 @@
 2022-01-04  Jose E. Marchesi  <jemarch@gnu.org>
 
+       * libpoke/pkl-gen.pks (union_writer): New function.
+       * libpoke/pkl-gen.c (pkl_gen_pr_decl): Compile an union writer for
+       unions.
+       (pkl_gen_pr_type_struct): Likewise.
+       (LMAP): Likewise.
+       * testsuite/poke.map/write-unions-1.pk: New test.
+       * testsuite/poke.map/write-unions-2.pk: Likewise.
+       * testsuite/poke.map/write-unions-3.pk: Likewise.
+       * testsuite/poke.map/ass-map-23.pk: Likewise.
+       * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
+
+2022-01-04  Jose E. Marchesi  <jemarch@gnu.org>
+
        * libpoke/pkl-gen.pks (struct_field_mapper): Fix backing up of GEN
        endianness.
        (struct_field_writer): Likewise.
diff --git a/libpoke/pkl-gen.c b/libpoke/pkl-gen.c
index 7fdc4949..bdb9e230 100644
--- a/libpoke/pkl-gen.c
+++ b/libpoke/pkl-gen.c
@@ -211,7 +211,10 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_decl)
               {
                 PKL_GEN_PUSH_SET_CONTEXT (PKL_GEN_CTX_IN_WRITER);
                 {
-                  RAS_FUNCTION_STRUCT_WRITER (writer_closure, type_struct);
+                  if (PKL_AST_TYPE_S_UNION_P (type_struct))
+                    RAS_FUNCTION_UNION_WRITER (writer_closure, type_struct);
+                  else
+                    RAS_FUNCTION_STRUCT_WRITER (writer_closure, type_struct);
                   pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, writer_closure); 
/* CLS */
                   pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PEC);                  
/* CLS */
                   pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DROP);                 
/* _ */
@@ -820,6 +823,8 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_ass_stmt)
               {                                                         \
                 if (lvalue_type_code == PKL_TYPE_ARRAY)                 \
                   RAS_FUNCTION_ARRAY_WRITER (writer, (TYPE));           \
+                else if (PKL_AST_TYPE_S_UNION_P ((TYPE)))               \
+                  RAS_FUNCTION_UNION_WRITER (writer, (TYPE));           \
                 else                                                    \
                   RAS_FUNCTION_STRUCT_WRITER (writer, (TYPE));          \
                 pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, writer); /* CLS */ \
@@ -3498,7 +3503,10 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_type_struct)
           pvm_val writer_closure;
 
           PKL_GEN_PUSH_SET_CONTEXT (PKL_GEN_CTX_IN_WRITER);
-          RAS_FUNCTION_STRUCT_WRITER (writer_closure, type_struct);
+          if (PKL_AST_TYPE_S_UNION_P (type_struct))
+            RAS_FUNCTION_UNION_WRITER (writer_closure, type_struct);
+          else
+            RAS_FUNCTION_STRUCT_WRITER (writer_closure, type_struct);
           PKL_GEN_POP_CONTEXT;
 
           pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, writer_closure); /* VAL 
CLS */
@@ -3571,7 +3579,10 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_type_struct)
 
           PKL_GEN_PUSH_SET_CONTEXT (PKL_GEN_CTX_IN_WRITER);
           {
-            RAS_FUNCTION_STRUCT_WRITER (type_struct_writer, type_struct);
+            if (PKL_AST_TYPE_S_UNION_P (type_struct))
+              RAS_FUNCTION_UNION_WRITER (type_struct_writer, type_struct);
+            else
+              RAS_FUNCTION_STRUCT_WRITER (type_struct_writer, type_struct);
             pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, type_struct_writer); /* 
CLS */
             pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PEC);                      /* 
CLS */
             pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DROP);                     /* 
_ */
diff --git a/libpoke/pkl-gen.pks b/libpoke/pkl-gen.pks
index 92042dd5..e1c198b3 100644
--- a/libpoke/pkl-gen.pks
+++ b/libpoke/pkl-gen.pks
@@ -473,11 +473,11 @@
 ;;; @field is a pkl_ast_node with the struct field.
 
         .macro field_location_str @struct_type @field
- .c pkl_ast_node field_name = PKL_AST_STRUCT_TYPE_FIELD_NAME (@field);        
+ .c pkl_ast_node field_name = PKL_AST_STRUCT_TYPE_FIELD_NAME (@field);
  .c if (field_name)
  .c {
         .let #field_name_str = pvm_make_string (PKL_AST_IDENTIFIER_POINTER 
(field_name))
- .c   pkl_ast_node struct_type_name = PKL_AST_TYPE_NAME (@struct_type);        
+ .c   pkl_ast_node struct_type_name = PKL_AST_TYPE_NAME (@struct_type);
  .c   if (struct_type_name)
  .c   {
         .let #type_name = pvm_make_string (PKL_AST_IDENTIFIER_POINTER 
(struct_type_name))
@@ -1687,6 +1687,84 @@
         return
         .end
 
+;;; RAS_FUNCTION_UNION_WRITER @type_struct
+;;; ( VAL -- )
+;;;
+;;; Assemble a function that pokes a mapped union value.
+;;;
+;;; @type_struct is a pkl_ast_node with the union type being
+;;; processed.
+
+        .function union_writer @type_struct
+        prolog
+        ;; This code relies on the following facts:
+        ;;
+        ;; 1. The struct value in the stack is of an union type.  This
+        ;;    means it only has one field member.
+        ;; 2. This member is not anonymous, as anonymous fields are not
+        ;;    allowed in unions.  The compiler guarantees this.
+        ;;
+        ;; The strategy is to iterate over all possible union type
+        ;; alternatives, trying to get them from the union value, by name.
+        ;; For non-taken alternatives this will result on an E_elem
+        ;; exception.
+        ;;
+        ;; The first alternative whose value is successfully retrieved
+        ;; from the struct value is the one we need to write out.  Then
+        ;; we are done.
+        .let @field
+ .c for (@field = PKL_AST_TYPE_S_ELEMS (@type_struct);
+ .c      @field;
+ .c      @field = PKL_AST_CHAIN (@field))
+ .c {
+ .c     if (PKL_AST_CODE (@field) != PKL_AST_STRUCT_TYPE_FIELD)
+ .c       continue;
+        .label .next_alternative
+        .let @field_type = PKL_AST_STRUCT_TYPE_FIELD_TYPE (@field)
+        .let @field_name = PKL_AST_STRUCT_TYPE_FIELD_NAME (@field)
+        .let #field_name_str = pvm_make_string (PKL_AST_IDENTIFIER_POINTER 
(@field_name))
+        ;; Attempt to get this field and write out.
+        push PVM_E_ELEM
+        pushe .next_alternative
+        push #field_name_str
+        sref                    ; SCT STR VAL
+        tor                     ; SCT STR [VAL]
+        srefo                   ; SCT STR BOFF [VAL]
+        tor                     ; SCT STR [VAL BOFF]
+        drop                    ; SCT [VAL BOFF]
+        mgetios                 ; SCT IOS [VAL BOFF]
+        fromr                   ; SCT IOS BOFF [VAL]
+        fromr                   ; SCT IOS BOFF VAL
+        pope
+        .c { int endian = PKL_AST_STRUCT_TYPE_FIELD_ENDIAN (@field);
+        .c PKL_GEN_PAYLOAD->endian = PKL_AST_STRUCT_TYPE_FIELD_ENDIAN (@field);
+        .c PKL_GEN_PUSH_SET_CONTEXT (PKL_GEN_CTX_IN_WRITER);
+        .c PKL_PASS_SUBPASS (@field_type);
+        .c PKL_GEN_POP_CONTEXT;
+        .c PKL_GEN_PAYLOAD->endian = endian;
+        .c }
+        ba .done
+.next_alternative:
+        ;; Re-raise the exception if this was the last field.  This means
+        ;; we couldn't find a field to write, which is unexpected.
+ .c   if (PKL_AST_CHAIN (@field) == NULL)
+ .c   {
+        push "msg"
+        push "poke internal error in union_writer, please report this"
+        sset
+        raise
+ .c   }
+ .c   else
+ .c   {
+        drop                    ; The exception.
+ .c   }
+ .c }
+.done:
+        drop                    ; _
+        push null
+        return
+        .end
+
 ;;; RAS_FUNCTION_STRUCT_INTEGRATOR @type_struct
 ;;; ( VAL -- IVAL )
 ;;;
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index a6d2dde4..049f483d 100644
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -134,6 +134,7 @@ EXTRA_DIST = \
   poke.map/ass-map-20.pk \
   poke.map/ass-map-21.pk \
   poke.map/ass-map-22.pk \
+  poke.map/ass-map-23.pk \
   poke.map/ass-map-struct-int-1.pk \
   poke.map/func-map-1.pk \
   poke.map/func-map-2.pk \
@@ -524,6 +525,9 @@ EXTRA_DIST = \
   poke.map/valmap-struct-2.pk \
   poke.map/valmap-struct-3.pk \
   poke.map/valmap-struct-4.pk \
+  poke.map/write-unions-1.pk \
+  poke.map/write-unions-2.pk \
+  poke.map/write-unions-3.pk \
   poke.pickles/pickles.exp \
   poke.pickles/argp-test.pk \
   poke.pickles/color-test.pk \
diff --git a/testsuite/poke.map/ass-map-23.pk b/testsuite/poke.map/ass-map-23.pk
new file mode 100644
index 00000000..7ab402e4
--- /dev/null
+++ b/testsuite/poke.map/ass-map-23.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x00 0x00 0x00 0x00  0x00 0x00 0x00 0x00   0x00 0x00 0x00 
0x00} } */
+
+var x = 10;
+type Foo = union { byte a : x == 0; int b; };
+
+/* { dg-command {.set endian big} } */
+/* { dg-command {.set obase 16} } */
+/* { dg-command {Foo @ 0x4#B = Foo { b = 0xdeadbeef } } } */
+/* { dg-command {int @ 0x4#B } } */
+/* { dg-output "0xdeadbeef" } */
diff --git a/testsuite/poke.map/write-unions-1.pk 
b/testsuite/poke.map/write-unions-1.pk
new file mode 100644
index 00000000..97979969
--- /dev/null
+++ b/testsuite/poke.map/write-unions-1.pk
@@ -0,0 +1,10 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x00 0x00 0x00 0x00  0x00 0x00 0x00 0x00   0x00 0x00 0x00 
0x00} } */
+
+type Packet = struct { union {byte x : x != 0; byte a = 0x69;} s; byte b; };
+
+/* { dg-command {.set endian big} } */
+/* { dg-command {.set obase 16} } */
+/* { dg-command {Packet @ 0x1#B = Packet { b = 0xab } } } */
+/* { dg-command {Packet @ 0x1#B } } */
+/* { dg-output {Packet {s=struct {x=0x69UB},b=0xabUB}} } */
diff --git a/testsuite/poke.map/write-unions-2.pk 
b/testsuite/poke.map/write-unions-2.pk
new file mode 100644
index 00000000..4c3bd33b
--- /dev/null
+++ b/testsuite/poke.map/write-unions-2.pk
@@ -0,0 +1,19 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x00 0x00 0x00 0x00  0x00 0x00 0x00 0x00   0x00 0x00 0x00 
0x00} } */
+
+var x = 10;
+
+type Foo =
+  union
+  {
+    byte a : x == 0;
+    uint<16> b;
+    byte c : x == 60;
+  };
+
+/* { dg-command {.set endian big} } */
+/* { dg-command {.set obase 16} } */
+/* { dg-command {var f = Foo @ 4#B;} } */
+/* { dg-command {f.b = 0xff;} } */
+/* { dg-command {uint<16> @ 4#B} } */
+/* { dg-output "0xffUH" } */
diff --git a/testsuite/poke.map/write-unions-3.pk 
b/testsuite/poke.map/write-unions-3.pk
new file mode 100644
index 00000000..8c57f6b0
--- /dev/null
+++ b/testsuite/poke.map/write-unions-3.pk
@@ -0,0 +1,25 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x00 0x00 0x00 0x00  0x00 0x00 0x00 0x00   0x00 0x00 0x00 
0x00} } */
+
+var x = 10;
+
+type Bar =
+  union
+  {
+    uint<16> d;
+  };
+
+type Foo =
+  union
+  {
+    byte a : x == 0;
+    Bar b;
+    byte c : x == 60;
+  };
+
+/* { dg-command {.set endian big} } */
+/* { dg-command {.set obase 16} } */
+/* { dg-command {var f = Foo @ 4#B;} } */
+/* { dg-command {f.b.d = 0xff;} } */
+/* { dg-command {uint<16> @ 4#B} } */
+/* { dg-output "0xffUH" } */
-- 
2.11.0