Support for unions has just landed

[Jose E. Marchesi]

Hi people!

I just installed the patch below, which adds support for Poke unions.
Example session:

(poke) defvar n = 10
(poke) deftype Foo = union { byte b : n < 10; int c; }
(poke) Foo  @ 0#B
Foo {c=0x20202020}
(poke) n = 5
(poke) Foo  @ 0#B
Foo {b=0x20UB}

(poke) n = 10
(poke) defvar f= Foo @ 0#B
(poke) f.b
unhandled invalid element exception
(poke) f.c
0x20202020

I will write an article in Applied Pokology on using unions to implement
conditional decoding, and about how the next step is to implement struct
flattening in order to achieve a smoother experience.

Happy poking! :)

diff --git a/ChangeLog b/ChangeLog
index d14906c..2c3044b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,44 @@
 2019-10-15  Jose E. Marchesi  <address@hidden>
 
+       * src/pkl-gen.pks (struct_mapper): Support unions in the mapping
+       algorithm.
+       * testsuite/poke.map/maps-unions-1.pk: New file.
+       * testsuite/poke.map/maps-unions-2.pk: Likewise.
+       * testsuite/poke.map/maps-unions-3.pk: Likewise.
+       * testsuite/poke.map/maps-unions-4.pk: Likewise.
+
+2019-10-15  Jose E. Marchesi  <address@hidden>
+
+       * testsuite/poke.pkl/union-1.pk: Test fixed.
+
+2019-10-15  Jose E. Marchesi  <address@hidden>
+
+       * src/pkl-anal.c (pkl_anal2_ps_type_struct): Pass an AST argument
+       to pkl_warning.
+
+2019-10-15  Jose E. Marchesi  <address@hidden>
+
+       * src/pkl-anal.c (pkl_anal2_ps_type_struct): New handler.
+       (pkl_phase_anal2): Register pkl_anal2_ps_type_struct.
+       * testsuite/poke.pkl/union-diag-1.pk: New file.
+       * testsuite/poke.pkl/union-diag-2.pk: Likewise.
+       * testsuite/poke.pkl/union-diag-3.pk: Likewise.
+
+2019-10-15  Jose E. Marchesi  <address@hidden>
+
+       * src/pkl-ast.h (struct pkl_ast_type): New field union_p for
+       struct types.
+       (PKL_AST_TYPE_S_UNION): Define.
+       (pkl_ast_make_struct_type): Get an union_p argument.
+       * src/pkl-ast.c (pkl_ast_make_struct_type): Initialize union_p.
+       (pkl_ast_dup_type): Handle union_p.
+       (pkl_ast_print_1): Likewise.
+       * src/pkl-tab.y (struct_type_specifier): Pass union_p to
+       pkl_ast_make_struct_type.
+       * src/pkl-typify.c (pkl_typify1_ps_struct): Likewise.
+
+2019-10-15  Jose E. Marchesi  <address@hidden>
+
        * src/pkl-lex.l: Support for token union.
        * src/pkl-tab.y (UNION): New token.
        (struct_or_union): New rule.
diff --git a/src/pkl-anal.c b/src/pkl-anal.c
index fce4784..b50db2d 100644
--- a/src/pkl-anal.c
+++ b/src/pkl-anal.c
@@ -427,6 +427,52 @@ PKL_PHASE_BEGIN_HANDLER (pkl_anal2_ps_funcall)
 }
 PKL_PHASE_END_HANDLER
 
+/* In unions, alternatives appearing after an alternative with no
+   constraint expression, or a constant expression known to be true,
+   are unreachable.  Also, if an union alternative has a constraint
+   known to be false, it is never taken.  Warning about these two
+   situations.  */
+
+PKL_PHASE_BEGIN_HANDLER (pkl_anal2_ps_type_struct)
+{
+  pkl_ast_node struct_type = PKL_PASS_NODE;
+  pkl_ast_node struct_type_elems
+    = PKL_AST_TYPE_S_ELEMS (struct_type);
+  pkl_ast_node t;
+  pkl_ast_node last_unconditional_alternative = NULL;
+
+  if (!PKL_AST_TYPE_S_UNION (struct_type))
+    PKL_PASS_DONE;
+
+  for (t = struct_type_elems; t; t = PKL_AST_CHAIN (t))
+    {
+      pkl_ast_node constraint
+        = PKL_AST_STRUCT_FIELD_TYPE_CONSTRAINT (t);
+
+      if (last_unconditional_alternative)
+        {
+          pkl_warning (PKL_PASS_AST, PKL_AST_LOC (t),
+                       "unreachable alternative in union");
+          break;
+        }
+
+      if (!constraint
+          || (PKL_AST_CODE (constraint) == PKL_AST_INTEGER
+              && PKL_AST_INTEGER_VALUE (constraint) != 0))
+        last_unconditional_alternative = t;
+
+      if (constraint
+          && PKL_AST_CODE (constraint) == PKL_AST_INTEGER
+          && PKL_AST_INTEGER_VALUE (constraint) == 0)
+        {
+          pkl_warning (PKL_PASS_AST, PKL_AST_LOC (t),
+                       "unreachable alternative in union");
+          break;
+        }
+    }
+}
+PKL_PHASE_END_HANDLER
+
 struct pkl_phase pkl_phase_anal2 =
   {
    PKL_PHASE_PR_HANDLER (PKL_AST_PROGRAM, pkl_anal_pr_program),
@@ -436,6 +482,7 @@ struct pkl_phase pkl_phase_anal2 =
    PKL_PHASE_PS_HANDLER (PKL_AST_OFFSET, pkl_anal2_ps_offset),
    PKL_PHASE_PS_HANDLER (PKL_AST_RETURN_STMT, pkl_anal2_ps_return_stmt),
    PKL_PHASE_PS_HANDLER (PKL_AST_FUNCALL, pkl_anal2_ps_funcall),
+   PKL_PHASE_PS_TYPE_HANDLER (PKL_TYPE_STRUCT, pkl_anal2_ps_type_struct),
    PKL_PHASE_PS_DEFAULT_HANDLER (pkl_anal_ps_default),
   };
 
diff --git a/src/pkl-ast.c b/src/pkl-ast.c
index 30aa804..a5d3d2c 100644
--- a/src/pkl-ast.c
+++ b/src/pkl-ast.c
@@ -422,7 +422,7 @@ pkl_ast_node
 pkl_ast_make_struct_type (pkl_ast ast,
                           size_t nelem,
                           pkl_ast_node struct_type_elems,
-                          int pinned)
+                          int pinned, int union_p)
 {
   pkl_ast_node type = pkl_ast_make_type (ast);
 
@@ -431,6 +431,7 @@ pkl_ast_make_struct_type (pkl_ast ast,
   if (struct_type_elems)
     PKL_AST_TYPE_S_ELEMS (type) = ASTREF (struct_type_elems);
   PKL_AST_TYPE_S_PINNED (type) = pinned;
+  PKL_AST_TYPE_S_UNION (type) = union_p;
   PKL_AST_TYPE_S_MAPPER (type) = PVM_NULL;
   PKL_AST_TYPE_S_WRITER (type) = PVM_NULL;
   PKL_AST_TYPE_S_CONSTRUCTOR (type) = PVM_NULL;
@@ -564,6 +565,7 @@ pkl_ast_dup_type (pkl_ast_node type)
                                struct_type_elem);
           PKL_AST_TYPE_S_ELEMS (new) = ASTREF (PKL_AST_TYPE_S_ELEMS (type));
           PKL_AST_TYPE_S_PINNED (new) = PKL_AST_TYPE_S_PINNED (type);
+          PKL_AST_TYPE_S_UNION (new) = PKL_AST_TYPE_S_UNION (type);
         }
       break;
     case PKL_TYPE_FUNCTION:
@@ -2386,6 +2388,7 @@ pkl_ast_print_1 (FILE *fd, pkl_ast_node ast, int indent)
               break;
             case PKL_TYPE_STRUCT:
               PRINT_AST_IMM (pinned, TYPE_S_PINNED, "%d");
+              PRINT_AST_IMM (union_p, TYPE_S_UNION, "%d");
               PRINT_AST_IMM (nelem, TYPE_S_NELEM, "%zu");
               IPRINTF ("elems:\n");
               PRINT_AST_SUBAST_CHAIN (TYPE_S_ELEMS);
diff --git a/src/pkl-ast.h b/src/pkl-ast.h
index 3aa323b..624b8fe 100644
--- a/src/pkl-ast.h
+++ b/src/pkl-ast.h
@@ -819,6 +819,7 @@ pkl_ast_node pkl_ast_make_func_type_arg (pkl_ast ast,
 #define PKL_AST_TYPE_S_NELEM(AST) ((AST)->type.val.sct.nelem)
 #define PKL_AST_TYPE_S_ELEMS(AST) ((AST)->type.val.sct.elems)
 #define PKL_AST_TYPE_S_PINNED(AST) ((AST)->type.val.sct.pinned)
+#define PKL_AST_TYPE_S_UNION(AST) ((AST)->type.val.sct.union_p)
 #define PKL_AST_TYPE_S_MAPPER(AST) ((AST)->type.val.sct.mapper)
 #define PKL_AST_TYPE_S_WRITER(AST) ((AST)->type.val.sct.writer)
 #define PKL_AST_TYPE_S_CONSTRUCTOR(AST) ((AST)->type.val.sct.constructor)
@@ -864,6 +865,7 @@ struct pkl_ast_type
       size_t nelem;
       union pkl_ast_node *elems;
       int pinned;
+      int union_p;
       pvm_val mapper;
       pvm_val writer;
       pvm_val constructor;
@@ -893,7 +895,7 @@ pkl_ast_node pkl_ast_make_void_type (pkl_ast ast);
 pkl_ast_node pkl_ast_make_string_type (pkl_ast ast);
 pkl_ast_node pkl_ast_make_array_type (pkl_ast ast, pkl_ast_node etype, 
pkl_ast_node bound);
 pkl_ast_node pkl_ast_make_struct_type (pkl_ast ast, size_t nelem, pkl_ast_node 
elems,
-                                       int pinned);
+                                       int pinned, int union_p);
 pkl_ast_node pkl_ast_make_offset_type (pkl_ast ast, pkl_ast_node base_type, 
pkl_ast_node unit);
 pkl_ast_node pkl_ast_make_function_type (pkl_ast ast, pkl_ast_node rtype,
                                          size_t narg, pkl_ast_node args);
diff --git a/src/pkl-gen.pks b/src/pkl-gen.pks
index b7d7878..0dce4e9 100644
--- a/src/pkl-gen.pks
+++ b/src/pkl-gen.pks
@@ -705,8 +705,25 @@
         ;; Iterate over the fields of the struct type.
  .c for (field = type_struct_fields; field; field = PKL_AST_CHAIN (field))
  .c {
+   .c jitter_label alternative_failed = pkl_asm_fresh_label (RAS_ASM);
+        ;; If this is an union, install an exception handler for
+        ;; E_constraint.  If the exception is raised it means this union
+        ;; alternative didn't work, and another should be tried next.
+        ;;
+        ;; Note how we cannot use normal RAS labels here, since we
+        ;; are in a meta-loop.  XXX this should be improved by
+        ;; supporting auto-increased labels in RAS.
+   .c if (PKL_AST_TYPE_S_UNION (type_struct))
+   .c {
+        push PVM_E_CONSTRAINT
+   .c   pkl_asm_insn (RAS_ASM, PKL_INSN_PUSHE, alternative_failed);
+   .c }
         pushvar $off             ; ...[EOFF ENAME EVAL] NEOFF OFF
         .e struct_field_mapper   ; ...[EOFF ENAME EVAL] NEOFF
+   .c if (PKL_AST_TYPE_S_UNION (type_struct))
+   .c {
+        pope
+   .c }
         ;; If the struct is pinned, replace NEOFF with OFF
    .c if (PKL_AST_TYPE_S_PINNED (type_struct))
    .c {
@@ -719,7 +736,17 @@
         addl
         nip2                    ; ...[EOFF ENAME EVAL] NEOFF (NFIELD+1UL)
         popvar $nfield          ; ...[EOFF ENAME EVAL] NEOFF
+   .c if (PKL_AST_TYPE_S_UNION (type_struct))
+   .c {
+        ;; An union field was decoded without raising any exception.
+        ;; We are done.
+        ba .fields_done
+   .c pkl_asm_label (RAS_ASM, alternative_failed);
+        ;; Drop the exception number.
+        drop
+   .c }
  .c }
+.fields_done:
         drop                   ; ...[EOFF ENAME EVAL]
         ;; Ok, at this point all the struct field triplets are
         ;; in the stack.  Push the number of fields, create
diff --git a/src/pkl-tab.y b/src/pkl-tab.y
index 89f7567..9305b06 100644
--- a/src/pkl-tab.y
+++ b/src/pkl-tab.y
@@ -1055,7 +1055,7 @@ struct_type_specifier:
                     $$ = pkl_ast_make_struct_type (pkl_parser->ast,
                                                    0 /* nelem */,
                                                    NULL /* elems */,
-                                                   $2);
+                                                   $2, $3);
                     PKL_AST_LOC ($$) = @$;
 
                     /* The pushlevel in this rule and the subsequent
@@ -1075,7 +1075,7 @@ struct_type_specifier:
                     $$ = pkl_ast_make_struct_type (pkl_parser->ast,
                                                    0 /* nelem */,
                                                    $6,
-                                                   $2);
+                                                   $2, $3);
                     PKL_AST_LOC ($$) = @$;
 
                     /* Pop the frame pushed in the `pushlevel' above.  */
diff --git a/src/pkl-typify.c b/src/pkl-typify.c
index 7b22edc..ec457e4 100644
--- a/src/pkl-typify.c
+++ b/src/pkl-typify.c
@@ -846,7 +846,8 @@ PKL_PHASE_BEGIN_HANDLER (pkl_typify1_ps_struct)
   type = pkl_ast_make_struct_type (PKL_PASS_AST,
                                    PKL_AST_STRUCT_NELEM (node),
                                    struct_field_types,
-                                   0 /* pinned */);
+                                   0 /* pinned */,
+                                   0 /* union */);
   PKL_AST_LOC (type) = PKL_AST_LOC (node);
   PKL_AST_TYPE (node) = ASTREF (type);
   PKL_PASS_RESTART = 1;
diff --git a/testsuite/poke.map/maps-unions-1.pk 
b/testsuite/poke.map/maps-unions-1.pk
new file mode 100644
index 0000000..e49df40
--- /dev/null
+++ b/testsuite/poke.map/maps-unions-1.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x10 0x20 0x30 0x40  0x50 0x60 0x70 0x80   0x90 0xa0 0xb0 
0xc0} } */
+
+/* { dg-command { .set endian big } } */
+/* { dg-command { .set obase 16 } } */
+
+defvar n = 10;
+deftype Foo = union { byte b : n < 10; int c; };
+
+/* { dg-command { Foo @ 0#B } } */
+/* { dg-output "Foo \\{c=0x10203040\\}" } */
diff --git a/testsuite/poke.map/maps-unions-2.pk 
b/testsuite/poke.map/maps-unions-2.pk
new file mode 100644
index 0000000..16a24b6
--- /dev/null
+++ b/testsuite/poke.map/maps-unions-2.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x10 0x20 0x30 0x40  0x50 0x60 0x70 0x80   0x90 0xa0 0xb0 
0xc0} } */
+
+/* { dg-command { .set endian big } } */
+/* { dg-command { .set obase 16 } } */
+
+defvar n = 5;
+deftype Foo = union { byte b : n < 10; int c; };
+
+/* { dg-command { Foo @ 0#B } } */
+/* { dg-output "Foo \\{b=0x10UB\\}" } */
diff --git a/testsuite/poke.map/maps-unions-3.pk 
b/testsuite/poke.map/maps-unions-3.pk
new file mode 100644
index 0000000..4fa8c78
--- /dev/null
+++ b/testsuite/poke.map/maps-unions-3.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x10 0x20 0x30 0x40  0x50 0x60 0x70 0x80   0x90 0xa0 0xb0 
0xc0} } */
+
+/* { dg-command { .set endian big } } */
+/* { dg-command { .set obase 16 } } */
+
+defvar n = 10;
+deftype Foo = union { byte b : n < 10; int c : n > 15; };
+
+/* { dg-command { Foo @ 0#B } } */
+/* { dg-output "Foo \\{\\}" } */
diff --git a/testsuite/poke.map/maps-unions-4.pk 
b/testsuite/poke.map/maps-unions-4.pk
new file mode 100644
index 0000000..9d7780c
--- /dev/null
+++ b/testsuite/poke.map/maps-unions-4.pk
@@ -0,0 +1,11 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x10 0x20 0x30 0x40  0x50 0x60 0x70 0x80   0x90 0xa0 0xb0 
0xc0} } */
+
+/* { dg-command { .set endian big } } */
+/* { dg-command { .set obase 16 } } */
+
+defvar n = 8;
+deftype Foo = union { byte b : n < 10; int c : n < 20; };
+
+/* { dg-command { Foo @ 0#B } } */
+/* { dg-output "Foo \\{b=0x10UB\\}" } */
diff --git a/testsuite/poke.pkl/union-1.pk b/testsuite/poke.pkl/union-1.pk
new file mode 100644
index 0000000..0720a4c
--- /dev/null
+++ b/testsuite/poke.pkl/union-1.pk
@@ -0,0 +1,9 @@
+/* { dg-do compile } */
+
+defvar jorl = 0;
+
+deftype Foo = union
+ {
+   int foo : jorl != 0;
+   int bar;
+ };
diff --git a/testsuite/poke.pkl/union-diag-1.pk 
b/testsuite/poke.pkl/union-diag-1.pk
new file mode 100644
index 0000000..92cf51a
--- /dev/null
+++ b/testsuite/poke.pkl/union-diag-1.pk
@@ -0,0 +1,12 @@
+/* { dg-do compile } */
+
+/* Check for unreachable alternatives in unions.  */
+
+defvar a = 10;
+
+deftype Foo = union
+ {
+   int foo : a < 20;
+   int quux;
+   int bar; /* { dg-warning "" } */
+ };
diff --git a/testsuite/poke.pkl/union-diag-2.pk 
b/testsuite/poke.pkl/union-diag-2.pk
new file mode 100644
index 0000000..821041b
--- /dev/null
+++ b/testsuite/poke.pkl/union-diag-2.pk
@@ -0,0 +1,10 @@
+/* { dg-do compile } */
+
+/* Check for unreachable alternatives in unions.  Constant constraint
+   expression.  */
+
+deftype Foo = union
+ {
+   int foo : 1 + 2;
+   int bar; /* { dg-warning "" } */
+ };
diff --git a/testsuite/poke.pkl/union-diag-3.pk 
b/testsuite/poke.pkl/union-diag-3.pk
new file mode 100644
index 0000000..876ef49
--- /dev/null
+++ b/testsuite/poke.pkl/union-diag-3.pk
@@ -0,0 +1,10 @@
+/* { dg-do compile } */
+
+/* Check for unreachable alternatives in unions.  Constant constraint
+   expression that evaluates to false.  */
+
+deftype Foo = union
+ {
+   int bar;
+   int foo : 2 - 2; /* { dg-warning "" } */
+ };