[COMMITTED] pkl: keep data integrity when assigning to struct fields

[Jose E. Marchesi]

Setting the value of a struct field may break the data integrity
defined by field constraints and other considerations, such as an
union for which no valid alternatives are found.

This patch makes poke to detect such cases and to not perform the
operation if the data integrity would be endangered.  Example:

  (poke) type Foo = struct { int i : i != 20; }
  (poke) var f = Foo {}
  (poke) f.i = 20
  unhandled constraint violation exception
  (poke) f.i = 21
  (poke) f
  Foo {
    i=21
  }

The same applies to mapped values:

  (poke) var g = Foo @ 0#B
  (poke) g
  Foo {
    i=0xa
  }
  (poke) g.i = 20
  unhandled constraint violation exception
  (poke) g
  Foo {
    i=0xa
  }

Note how the IO space is not modified in case the constraint violation
exception is raised, which is definitely the right thing to do!

2020-11-14  Jose E. Marchesi  <jemarch@gnu.org>

        * libpoke/pkl-insn.def: Define PKL_INSN_SSETI.
        * libpoke/pkl-asm.c (pkl_asm_insn): Handle the SSETI
        macro-instruction.
        (pkl_asm_insn_sseti): New function.
        * libpoke/pkl-asm.pks (sseti): New macro.
        * libpoke/pkl-gen.c (pkl_gen_pr_ass_stmt): Use sseti.
        (pkl_gen_pr_type_struct): Make constructors install constructors
        for their contained anonymous structs.
        * testsuite/poke.pkl/ass-struct-int-1.pk: New test.
        * testsuite/poke.pkl/ass-struct-int-2.pk: Likewise.
        * testsuite/poke.map/ass-map-struct-int-1.pk: Likewise.
        * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
---
 ChangeLog                                  | 15 ++++++
 libpoke/pkl-asm.c                          | 26 ++++++++++
 libpoke/pkl-asm.pks                        | 55 ++++++++++++++++++++++
 libpoke/pkl-gen.c                          | 27 ++++++++---
 libpoke/pkl-insn.def                       |  4 ++
 testsuite/Makefile.am                      |  3 ++
 testsuite/poke.map/ass-map-struct-int-1.pk | 15 ++++++
 testsuite/poke.pkl/ass-struct-int-1.pk     | 12 +++++
 testsuite/poke.pkl/ass-struct-int-2.pk     | 14 ++++++
 9 files changed, 164 insertions(+), 7 deletions(-)
 create mode 100644 testsuite/poke.map/ass-map-struct-int-1.pk
 create mode 100644 testsuite/poke.pkl/ass-struct-int-1.pk
 create mode 100644 testsuite/poke.pkl/ass-struct-int-2.pk

diff --git a/ChangeLog b/ChangeLog
index 7c83a9e6..7e066183 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2020-11-14  Jose E. Marchesi  <jemarch@gnu.org>
+
+       * libpoke/pkl-insn.def: Define PKL_INSN_SSETI.
+       * libpoke/pkl-asm.c (pkl_asm_insn): Handle the SSETI
+       macro-instruction.
+       (pkl_asm_insn_sseti): New function.
+       * libpoke/pkl-asm.pks (sseti): New macro.
+       * libpoke/pkl-gen.c (pkl_gen_pr_ass_stmt): Use sseti.
+       (pkl_gen_pr_type_struct): Make constructors install constructors
+       for their contained anonymous structs.
+       * testsuite/poke.pkl/ass-struct-int-1.pk: New test.
+       * testsuite/poke.pkl/ass-struct-int-2.pk: Likewise.
+       * testsuite/poke.map/ass-map-struct-int-1.pk: Likewise.
+       * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
+
 2020-11-14  Jose E. Marchesi  <jemarch@gnu.org>
 
        * etc/poke.rec: Renamed from POKE.
diff --git a/libpoke/pkl-asm.c b/libpoke/pkl-asm.c
index 5d30c14e..e4033777 100644
--- a/libpoke/pkl-asm.c
+++ b/libpoke/pkl-asm.c
@@ -895,6 +895,21 @@ pkl_asm_insn_cmp (pkl_asm pasm,
     assert (0);
 }
 
+/* Macro-instruction: SSETI struct_type
+   ( SCT STR VAL -- SCT )
+
+   Given a struct, a string containing the name of a struct element,
+   and a value, set the value to the referred element.  If setting the
+   element causes a problem with the integrity of the data stored in
+   the struct (for example, a constraint expresssion fails) then the
+   operation is aborted and PVM_E_CONSTRAINT is raised.  */
+
+static void
+pkl_asm_insn_sseti (pkl_asm pasm, pkl_ast_node struct_type)
+{
+  RAS_MACRO_SSETI (struct_type);
+}
+
 /* Macro-instruction: ACONC array_elem_type
    ( ARR ARR -- ARR ARR ARR )
 
@@ -1518,6 +1533,17 @@ pkl_asm_insn (pkl_asm pasm, enum pkl_asm_insn insn, ...)
         case PKL_INSN_ACONC:
           pkl_asm_insn_aconc (pasm);
           break;
+        case PKL_INSN_SSETI:
+          {
+            pkl_ast_node struct_type;
+
+            va_start (valist, insn);
+            struct_type = va_arg (valist, pkl_ast_node);
+            va_end (valist);
+
+            pkl_asm_insn_sseti (pasm, struct_type);
+            break;
+          }
         case PKL_INSN_MACRO:
         default:
           assert (0);
diff --git a/libpoke/pkl-asm.pks b/libpoke/pkl-asm.pks
index 88b4f8ca..b697d77e 100644
--- a/libpoke/pkl-asm.pks
+++ b/libpoke/pkl-asm.pks
@@ -324,6 +324,61 @@
         popf 1
         .end
 
+;;; SSETI
+;;; ( SCT STR VAL -- SCT )
+;;;
+;;; SSET with data integrity.
+;;;
+;;; Given a struct, a string containing the name of a struct element,
+;;; and a value, set the value to the referred element.
+;;;
+;;; If setting the element causes a problem with the integrity of the
+;;; data stored in the struct (for example, a constraint expresssion
+;;; fails) then the operation is aborted and PVM_E_CONSTRAINT is raised.
+
+        .macro sseti @struct_type
+        ;; First, save the previous value of the referred field
+        ;; and also the field name.
+        nrot                    ; VAL SCT STR
+        dup                     ; VAL SCT STR STR
+        tor                     ; VAL SCT STR [STR]
+        sref                    ; VAL SCT STR OVAL
+        tor                     ; VAL SCT STR [STR OVAL]
+        rot                     ; SCT STR VAL [STR OVAL]
+        ;; Now the set new value.
+        sset                    ; SCT [STR OVAL]
+        fromr                   ; SCT OVAL [STR]
+        fromr                   ; SCT OVAL STR
+        rot                     ; OVAL STR SCT
+        ;; Invoke the constructor of the struct in itself.  If it
+        ;; raises E_constraint, then restore the original value
+        ;; and re-raise the exception.
+        .let #constructor = PKL_AST_TYPE_S_CONSTRUCTOR (@struct_type)
+        push PVM_E_CONSTRAINT
+        pushe .integrity_fucked
+        dup                     ; OVAL STR SCT SCT CLS
+        push #constructor       ; OVAL STR SCT SCT CLS
+        call                    ; OVAL STR SCT SCT
+        pope
+        drop                    ; OVAL STR SCT
+        nip2                    ; SCT
+        ba .integrity_ok
+.integrity_fucked:
+        ;; The constructor says this modification violates the
+        ;; integrity of the data as defined by the struct type.
+        ;; Restore the old value in the struct and re-raise the
+        ;; exception.
+        tor                     ; OVAL STR SCT [EXCEPTION]
+        quake                   ; STR OVAL SCT [EXCEPTION]
+        nrot                    ; SCT STR OVAL [EXCEPTION]
+        sset                    ; SCT [EXCEPTION]
+        fromr                   ; SCT EXCEPTION
+        raise
+.integrity_ok:
+        ;; Everything went ok.  The struct with the new value
+        ;; is on the stack.
+        .end
+
 ;;; ACONC array_type
 ;;; ( ARR ARR -- ARR ARR ARR )
 ;;;
diff --git a/libpoke/pkl-gen.c b/libpoke/pkl-gen.c
index 9836a053..f3d20d0a 100644
--- a/libpoke/pkl-gen.c
+++ b/libpoke/pkl-gen.c
@@ -738,13 +738,21 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_ass_stmt)
         break;
       }
     case PKL_AST_STRUCT_REF:
-      /* Stack: VAL SCT ID */
-      pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_ROT);
-      pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SSET);
-      pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_WRITE);
-      pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DROP); /* The struct
-                                                    value.  */
-      break;
+      {
+        /* Stack: VAL SCT ID */
+
+        pkl_ast_node sct = PKL_AST_INDEXER_ENTITY (lvalue);
+        pkl_ast_node struct_type = PKL_AST_TYPE (sct);
+
+        assert (PKL_AST_TYPE_S_CONSTRUCTOR (struct_type) != PVM_NULL);
+
+        pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_ROT);
+        pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_SSETI, struct_type);
+        pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_WRITE);
+        pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_DROP); /* The struct
+                                                      value.  */
+        break;
+      }
     case PKL_AST_MAP:
       {
         /* Stack: VAL IOS OFF */
@@ -2728,6 +2736,11 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_type_struct)
           RAS_FUNCTION_STRUCT_CONSTRUCTOR (constructor_closure, type_struct);
           pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PUSH, constructor_closure);
           pkl_asm_insn (PKL_GEN_ASM, PKL_INSN_PEC); /* SCT CLS */
+
+          /* Since this is an anonymous struct, install the
+             constructor in it.  This is needed by other operations
+             like sseti.  */
+          PKL_AST_TYPE_S_CONSTRUCTOR (type_struct) = constructor_closure;
         }
 
       /* Call the constructor to get a new struct.  */
diff --git a/libpoke/pkl-insn.def b/libpoke/pkl-insn.def
index 8a0c4e50..0736aa21 100644
--- a/libpoke/pkl-insn.def
+++ b/libpoke/pkl-insn.def
@@ -473,6 +473,10 @@ PKL_DEF_INSN(PKL_INSN_ATRIM, "a", "atrim")
 PKL_DEF_INSN(PKL_INSN_AIS, "", "ais")
 PKL_DEF_INSN(PKL_INSN_ACONC, "", "aconc")
 
+/* Struct macro-instructions.  */
+
+PKL_DEF_INSN(PKL_INSN_SSETI, "a", "sseti")
+
 /* Offset macro-instructions.  */
 
 PKL_DEF_INSN(PKL_INSN_ADDO, "a", "addo")
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index 06c0b52a..c4189081 100644
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -123,6 +123,7 @@ EXTRA_DIST = \
   poke.map/ass-map-15.pk \
   poke.map/ass-map-16.pk \
   poke.map/ass-map-17.pk \
+  poke.map/ass-map-struct-int-1.pk \
   poke.map/map-opcond-write-1.pk \
   poke.map/map-optcond-1.pk \
   poke.map/map-optcond-2.pk \
@@ -543,6 +544,8 @@ EXTRA_DIST = \
   poke.pkl/ass-diag-9.pk \
   poke.pkl/ass-function-1.pk \
   poke.pkl/ass-offset-1.pk \
+  poke.pkl/ass-struct-int-1.pk \
+  poke.pkl/ass-struct-int-2.pk \
   poke.pkl/attr-diag-1.pk \
   poke.pkl/attr-ios-1.pk \
   poke.pkl/attr-ios-2.pk \
diff --git a/testsuite/poke.map/ass-map-struct-int-1.pk 
b/testsuite/poke.map/ass-map-struct-int-1.pk
new file mode 100644
index 00000000..94b15c30
--- /dev/null
+++ b/testsuite/poke.map/ass-map-struct-int-1.pk
@@ -0,0 +1,15 @@
+/* { dg-do run } */
+/* { dg-data {c*} {0x00 0x00 0x00 0x40  0x50 0x60 0x70 0x80   0x90 0xa0 0xb0 
0xc0} } */
+
+type Foo = struct { int i : i != 0x20; };
+
+/* { dg-command {.set endian big} } */
+/* { dg-command {.set obase 16} } */
+/* { dg-command {var f = Foo  @ 0#B} } */
+/* { dg-command {try f.i = 0x20; catch if E_constraint { print "caught\n";}} } 
*/
+/* { dg-output "caught" } */
+/* { dg-command {f.i} } */
+/* { dg-output "\n0x40" } */
+/* { dg-command {f.i = 0x12} } */
+/* { dg-command {f.i} } */
+/* { dg-output "\n0x12" } */
diff --git a/testsuite/poke.pkl/ass-struct-int-1.pk 
b/testsuite/poke.pkl/ass-struct-int-1.pk
new file mode 100644
index 00000000..f70bd8bb
--- /dev/null
+++ b/testsuite/poke.pkl/ass-struct-int-1.pk
@@ -0,0 +1,12 @@
+/* { dg-do run } */
+
+type Foo = struct { int i : i != 20; };
+var f = Foo { i = 10 };
+
+/* { dg-command {try f.i = 20; catch if E_constraint { print "caught\n";}} } */
+/* { dg-output "caught" } */
+/* { dg-command {f.i} } */
+/* { dg-output "\n10" } */
+/* { dg-command {f.i = 12} } */
+/* { dg-command {f.i} } */
+/* { dg-output "\n12" } */
diff --git a/testsuite/poke.pkl/ass-struct-int-2.pk 
b/testsuite/poke.pkl/ass-struct-int-2.pk
new file mode 100644
index 00000000..2d9f0e28
--- /dev/null
+++ b/testsuite/poke.pkl/ass-struct-int-2.pk
@@ -0,0 +1,14 @@
+/* { dg-do run } */
+
+var N = 20;
+type Foo = struct { struct { int i : i != N; } s; };
+var f = Foo { };
+
+/* { dg-command {try f.s.i = 20; catch if E_constraint { print "caught\n";}} } 
*/
+/* { dg-output "caught" } */
+/* { dg-command {N = 30} } */
+/* { dg-command {try f.s.i = 30; catch if E_constraint { print "caught\n";}} } 
*/
+/* { dg-output "\ncaught" } */
+/* { dg-command {f.s.i = 20} } */
+/* { dg-command {f.s.i} } */
+/* { dg-output "\n20" } */
-- 
2.25.0.2.g232378479e