[PATCH] pkl: fix `flush'

[Mohammad-Reza Nabipoor]

2023-06-26  Mohammad-Reza Nabipoor  <mnabipoor@gnu.org>

        * libpoke/ios-dev-stream.c (ios_dev_stream_flush): Fix flushing logic
        for `<stdout>' and `<stderr>'.
        * libpoke/pvm.jitter (flush): Push `PVM_NULL' when there's no error.
        * testsuite/poke.pkl/flush-2.pk: New test.
        * testsuite/poke.pkl/flush-3.pk: Likewise.
        * testsuite/poke.pkl/flush-4.pk: Likewise.
        * testsuite/poke.pkl/flush-5.pk: Likewise.
        * testsuite/Makefile.am (EXTRA_DIST): Update.
---
 ChangeLog                     | 11 +++++++++++
 libpoke/ios-dev-stream.c      |  7 ++-----
 libpoke/pvm.jitter            |  2 ++
 testsuite/Makefile.am         |  4 ++++
 testsuite/poke.pkl/flush-2.pk |  6 ++++++
 testsuite/poke.pkl/flush-3.pk |  6 ++++++
 testsuite/poke.pkl/flush-4.pk |  6 ++++++
 testsuite/poke.pkl/flush-5.pk |  6 ++++++
 8 files changed, 43 insertions(+), 5 deletions(-)
 create mode 100644 testsuite/poke.pkl/flush-2.pk
 create mode 100644 testsuite/poke.pkl/flush-3.pk
 create mode 100644 testsuite/poke.pkl/flush-4.pk
 create mode 100644 testsuite/poke.pkl/flush-5.pk

diff --git a/ChangeLog b/ChangeLog
index d6870084..fb0c251a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2023-06-26  Mohammad-Reza Nabipoor  <mnabipoor@gnu.org>
+
+       * libpoke/ios-dev-stream.c (ios_dev_stream_flush): Fix flushing logic
+       for `<stdout>' and `<stderr>'.
+       * libpoke/pvm.jitter (flush): Push `PVM_NULL' when there's no error.
+       * testsuite/poke.pkl/flush-2.pk: New test.
+       * testsuite/poke.pkl/flush-3.pk: Likewise.
+       * testsuite/poke.pkl/flush-4.pk: Likewise.
+       * testsuite/poke.pkl/flush-5.pk: Likewise.
+       * testsuite/Makefile.am (EXTRA_DIST): Update.
+
 2023-06-23  Jose E. Marchesi  <jemarch@gnu.org>
 
        * libpoke/pkl-gen.pks (struct_constructor): Re-raise an E_conv
diff --git a/libpoke/ios-dev-stream.c b/libpoke/ios-dev-stream.c
index 573d6124..20bef44e 100644
--- a/libpoke/ios-dev-stream.c
+++ b/libpoke/ios-dev-stream.c
@@ -255,11 +255,8 @@ ios_dev_stream_flush (void *iod, ios_dev_off offset)
       && offset > ios_buffer_get_begin_offset (sio->buffer)
       && offset <= ios_buffer_get_end_offset (sio->buffer))
     return ios_buffer_forget_till (sio->buffer, offset);
-  else
-    {
-      assert (sio->flags & IOS_F_WRITE);
-      fflush (sio->file);
-    }
+  else if (sio->flags & IOS_F_WRITE)
+    fflush (sio->file);
   return IOS_OK;
 }
 
diff --git a/libpoke/pvm.jitter b/libpoke/pvm.jitter
index 299f1b59..8d44872f 100644
--- a/libpoke/pvm.jitter
+++ b/libpoke/pvm.jitter
@@ -1587,6 +1587,8 @@ instruction flush ()
       JITTER_TOP_STACK () = PVM_MAKE_DFL_EXCEPTION (PVM_E_NO_IOS);
     else if (ios_flush (io, offset) != IOS_OK)
       JITTER_TOP_STACK () = PVM_MAKE_DFL_EXCEPTION (PVM_E_IO);
+    else
+      JITTER_TOP_STACK () = PVM_NULL;
   end
 end
 
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index acb0220b..f1eaf6ab 100644
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -1392,6 +1392,10 @@ EXTRA_DIST = \
   poke.pkl/field-init-diag-6.pk \
   poke.pkl/field-init-diag-7.pk \
   poke.pkl/flush-1.pk \
+  poke.pkl/flush-2.pk \
+  poke.pkl/flush-3.pk \
+  poke.pkl/flush-4.pk \
+  poke.pkl/flush-5.pk \
   poke.pkl/for-1.pk \
   poke.pkl/for-2.pk \
   poke.pkl/for-3.pk \
diff --git a/testsuite/poke.pkl/flush-2.pk b/testsuite/poke.pkl/flush-2.pk
new file mode 100644
index 00000000..1bfdf6d0
--- /dev/null
+++ b/testsuite/poke.pkl/flush-2.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+var stdout = open ("<stdout>");
+
+flush (stdout, 0#B);
+close (stdout);
diff --git a/testsuite/poke.pkl/flush-3.pk b/testsuite/poke.pkl/flush-3.pk
new file mode 100644
index 00000000..28c9fffc
--- /dev/null
+++ b/testsuite/poke.pkl/flush-3.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+var stdin = open ("<stdin>");
+
+flush (stdin, 0#B);
+close (stdin);
diff --git a/testsuite/poke.pkl/flush-4.pk b/testsuite/poke.pkl/flush-4.pk
new file mode 100644
index 00000000..e2c6dd8f
--- /dev/null
+++ b/testsuite/poke.pkl/flush-4.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+var stderr = open ("<stderr>");
+
+flush (stderr, 0#B);
+close (stderr);
diff --git a/testsuite/poke.pkl/flush-5.pk b/testsuite/poke.pkl/flush-5.pk
new file mode 100644
index 00000000..e2b63615
--- /dev/null
+++ b/testsuite/poke.pkl/flush-5.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+var mem = open ("*mem*");
+
+flush (mem, 0#B);
+close (mem);
-- 
2.41.0