[COMMITTED] libpoke: report run-time errors in pk_call separately

[Jose E. Marchesi]

This patch changes the pk_call in order to get an argument where an
exit exception is stored, if the execution of the function raises an
unhandled exception.

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

        * libpoke/libpoke.c (pk_call): Expose exit_exception in the
        interface.
        * libpoke/libpoke.h: Change prototype accordingly.
        * poke/pk-cmd-help.c (pk_cmd_help): Adapt accordingly.
        * poke/pk-cmd-set.c (pk_cmd_set_dump): Likewise.
        (pk_cmd_set): Likewise.
        (pk_cmd_set): Likewise.
        * poke/pk-hserver.c (pk_hserver_get_token): Likewise.
        (pk_hserver_token_p): Likewise.
        (pk_hserver_cmd): Likewise.
        (read_from_client): Likewise.
        (pk_hserver_make_hyperlink): Likewise.
        * poke/poke.c (poke_handle_exception): Likewise.
        * poked/poked.c (poked_buf_send): Likewise.
        (main): Likewise.
        (poked_free): Likewise.
---
 ChangeLog          | 19 +++++++++++++++++++
 libpoke/libpoke.c  |  9 ++++-----
 libpoke/libpoke.h  |  6 +++++-
 libpoke/pvm.c      |  3 ++-
 libpoke/pvm.h      |  8 ++++----
 poke/pk-cmd-help.c |  6 ++++--
 poke/pk-cmd-set.c  | 20 ++++++++++++--------
 poke/pk-hserver.c  | 42 +++++++++++++++++++++++-------------------
 poke/poke.c        |  3 ++-
 poked/poked.c      | 10 +++++-----
 10 files changed, 80 insertions(+), 46 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 8d56ee11..65a520a9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,24 @@
 2022-03-08  Jose E. Marchesi  <jemarch@gnu.org>
 
+       * libpoke/libpoke.c (pk_call): Expose exit_exception in the
+       interface.
+       * libpoke/libpoke.h: Change prototype accordingly.
+       * poke/pk-cmd-help.c (pk_cmd_help): Adapt accordingly.
+       * poke/pk-cmd-set.c (pk_cmd_set_dump): Likewise.
+       (pk_cmd_set): Likewise.
+       (pk_cmd_set): Likewise.
+       * poke/pk-hserver.c (pk_hserver_get_token): Likewise.
+       (pk_hserver_token_p): Likewise.
+       (pk_hserver_cmd): Likewise.
+       (read_from_client): Likewise.
+       (pk_hserver_make_hyperlink): Likewise.
+       * poke/poke.c (poke_handle_exception): Likewise.
+       * poked/poked.c (poked_buf_send): Likewise.
+       (main): Likewise.
+       (poked_free): Likewise.
+
+2022-03-08  Jose E. Marchesi  <jemarch@gnu.org>
+
        * pickles/leb128.pk (LEB128.value): Really allow up to 64-bit
        integers and fix calculation of the return value.
        (ULEB128.value): Likewise.
diff --git a/libpoke/libpoke.c b/libpoke/libpoke.c
index bc39652b..e3c1e764 100644
--- a/libpoke/libpoke.c
+++ b/libpoke/libpoke.c
@@ -785,12 +785,12 @@ pk_defvar (pk_compiler pkc, const char *varname, pk_val 
val)
 }
 
 int
-pk_call (pk_compiler pkc, pk_val cls, pk_val *ret, int narg, ...)
+pk_call (pk_compiler pkc, pk_val cls, pk_val *ret,
+         pk_val *exit_exception, int narg, ...)
 {
   pvm_program program;
   va_list ap;
   enum pvm_exit_code rret;
-  pvm_val exit_exception;
 
   /* Compile a program that calls the function.  */
   va_start (ap, narg);
@@ -801,11 +801,10 @@ pk_call (pk_compiler pkc, pk_val cls, pk_val *ret, int 
narg, ...)
 
   /* Run the program in the poke VM.  */
   pvm_program_make_executable (program);
-  rret = pvm_run (pkc->vm, program, ret, &exit_exception);
+  rret = pvm_run (pkc->vm, program, ret, exit_exception);
 
   pvm_destroy_program (program);
-  PK_RETURN (rret == PVM_EXIT_OK && exit_exception == PVM_NULL
-             ? PK_OK : PK_ERROR);
+  PK_RETURN (rret == PVM_EXIT_OK ? PK_OK : PK_ERROR);
 }
 
 int
diff --git a/libpoke/libpoke.h b/libpoke/libpoke.h
index 899412ad..f21c51af 100644
--- a/libpoke/libpoke.h
+++ b/libpoke/libpoke.h
@@ -505,6 +505,10 @@ int pk_defvar (pk_compiler pkc, const char *varname, 
pk_val val) LIBPOKE_API;
    RET is set to the value returned by the function, or to NULL if
    it is a void function.
 
+   EXIT_EXCEPTION, if not NULL, is a pointer to a pk_val variable that
+   is set to an Exception value if the function call results in an
+   unhandled exception, PK_NULL otherwise.
+
    NARG is the number of arguments that follow and that are passed in
    the function call.  Note that PK_NULL values should be added for
    "not specified" actuals for formals that have default values.
@@ -519,7 +523,7 @@ int pk_defvar (pk_compiler pkc, const char *varname, pk_val 
val) LIBPOKE_API;
    holding the method to be passed as the _last_ argument in the
    pk_call.  */
 
-int pk_call (pk_compiler pkc, pk_val cls, pk_val *ret,
+int pk_call (pk_compiler pkc, pk_val cls, pk_val *ret, pk_val *exit_exception,
              int narg, ...) LIBPOKE_API;
 
 /* Get and set properties of the incremental compiler.  */
diff --git a/libpoke/pvm.c b/libpoke/pvm.c
index b5235533..5aa3f5bf 100644
--- a/libpoke/pvm.c
+++ b/libpoke/pvm.c
@@ -172,7 +172,8 @@ pvm_run (pvm apvm, pvm_program program, pvm_val *res, 
pvm_val *exc)
 
   if (res != NULL)
     *res = PVM_STATE_RESULT_VALUE (apvm);
-  *exc = PVM_STATE_EXIT_EXCEPTION_VALUE (apvm);
+  if (exc != NULL)
+    *exc = PVM_STATE_EXIT_EXCEPTION_VALUE (apvm);
 
   return PVM_STATE_EXIT_CODE (apvm);
 }
diff --git a/libpoke/pvm.h b/libpoke/pvm.h
index 13a80ad9..1ca3d241 100644
--- a/libpoke/pvm.h
+++ b/libpoke/pvm.h
@@ -615,11 +615,11 @@ void pvm_reset_profile (pvm pvm);
 /* Run a PVM program in a virtual machine.
 
    If the execution of PROGRAM generates a result value, it is put in
-   RES.
+   RES if the argument is not NULL.
 
-   *EXIT_EXCEPTION is set to an exception value if the execution of
-   the program gets interrupted by an unhandled exception.  Otherwise
-   *EXIT_EXCEPTION is set to PK_NULL.
+   If not NULL, *EXIT_EXCEPTION is set to an exception value if the
+   execution of the program gets interrupted by an unhandled
+   exception.  Otherwise *EXIT_EXCEPTION is set to PK_NULL.
 
    This function returns an exit code, indicating whether the
    execution was successful or not.  */
diff --git a/poke/pk-cmd-help.c b/poke/pk-cmd-help.c
index f1a03447..d2b653b2 100644
--- a/poke/pk-cmd-help.c
+++ b/poke/pk-cmd-help.c
@@ -29,6 +29,7 @@ pk_cmd_help (int argc, struct pk_cmd_arg argv[], uint64_t 
uflags)
   pk_val ret;
   pk_val topic;
   pk_val pk_help;
+  pk_val exit_exception;
   assert (argc == 2);
 
   assert (PK_CMD_ARG_TYPE (argv[1]) == PK_CMD_ARG_STR);
@@ -36,8 +37,9 @@ pk_cmd_help (int argc, struct pk_cmd_arg argv[], uint64_t 
uflags)
 
   pk_help = pk_decl_val (poke_compiler, "pk_help");
   assert (pk_help != PK_NULL);
-  if (pk_call (poke_compiler, pk_help, &ret, 1 /* narg */, topic)
-      == PK_ERROR)
+  if (pk_call (poke_compiler, pk_help, &ret, &exit_exception,
+               1 /* narg */, topic) == PK_ERROR
+      || exit_exception != PK_NULL)
     assert (0);
 
   return 1;
diff --git a/poke/pk-cmd-set.c b/poke/pk-cmd-set.c
index a3363ede..d6abd654 100644
--- a/poke/pk-cmd-set.c
+++ b/poke/pk-cmd-set.c
@@ -31,12 +31,14 @@
 static int
 pk_cmd_set_dump (int argc, struct pk_cmd_arg argv[], uint64_t uflags)
 {
-  pk_val registry_printer, retval;
+  pk_val registry_printer, retval, exit_exception;
 
   registry_printer = pk_decl_val (poke_compiler, "pk_settings_dump");
   assert (registry_printer != PK_NULL);
 
-  if (pk_call (poke_compiler, registry_printer, &retval, 0) == PK_ERROR)
+  if (pk_call (poke_compiler, registry_printer, &retval, &exit_exception,
+               0) == PK_ERROR
+      || exit_exception != PK_NULL)
     assert (0); /* This shouldn't happen.  */
 
 #if HAVE_HSERVER
@@ -72,14 +74,15 @@ pk_cmd_set (int int_p,
 
   if (PK_CMD_ARG_TYPE (argv[1]) == PK_CMD_ARG_NULL)
     {
-      pk_val registry_get;
+      pk_val registry_get, exit_exception;
 
       registry_get = pk_struct_ref_field_value (registry, "get");
       assert (registry_get != PK_NULL);
 
-      if (pk_call (poke_compiler, registry_get, &retval,
+      if (pk_call (poke_compiler, registry_get, &retval, &exit_exception,
                    2, pk_make_string (setting_name), registry)
-          == PK_ERROR)
+          == PK_ERROR
+          || exit_exception != PK_NULL)
         /* This shouldn't happen.  */
         assert (0);
 
@@ -90,7 +93,7 @@ pk_cmd_set (int int_p,
     }
   else
     {
-      pk_val registry_set;
+      pk_val registry_set, exit_exception;
       pk_val val;
       const char *retmsg;
 
@@ -102,9 +105,10 @@ pk_cmd_set (int int_p,
       registry_set = pk_struct_ref_field_value (registry, "set");
       assert (registry_set != PK_NULL);
 
-      if (pk_call (poke_compiler, registry_set, &retval,
+      if (pk_call (poke_compiler, registry_set, &retval, &exit_exception,
                    3, pk_make_string (setting_name), val, registry)
-          == PK_ERROR)
+          == PK_ERROR
+          || exit_exception != PK_NULL)
         /* This shouldn't happen, since we know `newval' is of the
            right type.  */
         assert (0);
diff --git a/poke/pk-hserver.c b/poke/pk-hserver.c
index 14b4c5e3..b372d768 100644
--- a/poke/pk-hserver.c
+++ b/poke/pk-hserver.c
@@ -76,12 +76,12 @@ unsigned int
 pk_hserver_get_token (void)
 {
   pk_val cls = pk_decl_val (poke_compiler, "hserver_get_token");
-  pk_val token;
+  pk_val token, exit_exception;
   int ret;
 
   assert (cls != PK_NULL);
-  ret = pk_call (poke_compiler, cls, &token, 0 /* narg */);
-  assert (ret == PK_OK);
+  ret = pk_call (poke_compiler, cls, &token, &exit_exception, 0 /* narg */);
+  assert (ret == PK_OK && exit_exception == PK_NULL);
 
   return pk_uint_value (token);
 }
@@ -91,12 +91,13 @@ pk_hserver_token_p (int token)
 {
   pk_val cls = pk_decl_val (poke_compiler, "hserver_token_p");
   pk_val token_val = pk_make_int (token, 32);
-  pk_val token_p;
+  pk_val token_p, exit_exception;
   int ret;
 
   assert (cls != PK_NULL);
-  ret = pk_call (poke_compiler, cls, &token_p, 1 /* narg */, token_val);
-  assert (ret == PK_OK);
+  ret = pk_call (poke_compiler, cls, &token_p, &exit_exception,
+                 1 /* narg */, token_val);
+  assert (ret == PK_OK && exit_exception == PK_NULL);
 
   return pk_int_value (token_p);
 }
@@ -106,12 +107,13 @@ pk_hserver_token_kind (int token)
 {
   pk_val cls = pk_decl_val (poke_compiler, "hserver_token_kind");
   pk_val token_val = pk_make_int (token, 32);
-  pk_val token_kind;
+  pk_val token_kind, exit_exception;
   int ret;
 
   assert (cls != PK_NULL);
-  ret = pk_call (poke_compiler, cls, &token_kind, 1 /* narg */, token_val);
-  assert (ret == PK_OK);
+  ret = pk_call (poke_compiler, cls, &token_kind, &exit_exception,
+                 1 /* narg */, token_val);
+  assert (ret == PK_OK && exit_exception == PK_NULL);
 
   return pk_uint_value (token_kind);
 }
@@ -121,12 +123,13 @@ pk_hserver_cmd (int token)
 {
   pk_val cls = pk_decl_val (poke_compiler, "hserver_token_cmd");
   pk_val token_val = pk_make_int (token, 32);
-  pk_val cmd;
+  pk_val cmd, exit_exception;
   int ret;
 
   assert (cls != PK_NULL);
-  ret = pk_call (poke_compiler, cls, &cmd, 1 /* narg */, token_val);
-  assert (ret == PK_OK);
+  ret = pk_call (poke_compiler, cls, &cmd, &exit_exception,
+                 1 /* narg */, token_val);
+  assert (ret == PK_OK && exit_exception == PK_NULL);
 
   return pk_string_str (cmd);
 }
@@ -136,12 +139,13 @@ pk_hserver_function (int token)
 {
   pk_val cls = pk_decl_val (poke_compiler, "hserver_token_function");
   pk_val token_val = pk_make_int (token, 32);
-  pk_val function;
+  pk_val function, exit_exception;
   int ret;
 
   assert (cls != PK_NULL);
-  ret = pk_call (poke_compiler, cls, &function, 1 /* narg */, token_val);
-  assert (ret == PK_OK);
+  ret = pk_call (poke_compiler, cls, &function, &exit_exception,
+                 1 /* narg */, token_val);
+  assert (ret == PK_OK && exit_exception == PK_NULL);
 
   return function;
 }
@@ -260,7 +264,7 @@ read_from_client (int filedes)
           pk_puts (cmd);
           pk_puts ("\n");
           /* Note we just ignore raised exceptions.  */
-          pk_call (poke_compiler, cls, NULL, 0);
+          pk_call (poke_compiler, cls, NULL, NULL, 0);
           pk_repl_display_end ();
           pthread_mutex_unlock (&hserver_mutex);
           break;
@@ -431,16 +435,16 @@ pk_hserver_make_hyperlink (char type,
                            pk_val function)
 {
   pk_val cls = pk_decl_val (poke_compiler, "hserver_make_hyperlink");
-  pk_val hyperlink, kind_val, cmd_val;
+  pk_val hyperlink, kind_val, cmd_val, exit_exception;
   int ret;
 
   kind_val = pk_make_uint (type, 8);
   cmd_val = pk_make_string (cmd);
 
   assert (cls != PK_NULL);
-  ret = pk_call (poke_compiler, cls, &hyperlink,
+  ret = pk_call (poke_compiler, cls, &hyperlink, &exit_exception,
                  3 /* narg */, kind_val, cmd_val, PK_NULL);
-  assert (ret == PK_OK);
+  assert (ret == PK_OK && exit_exception == PK_NULL);
 
   return xstrdup (pk_string_str (hyperlink));
 }
diff --git a/poke/poke.c b/poke/poke.c
index 5eb3e3b1..09850d28 100644
--- a/poke/poke.c
+++ b/poke/poke.c
@@ -778,7 +778,8 @@ poke_handle_exception (pk_val exception)
   pk_val handler = pk_decl_val (poke_compiler, "pk_exception_handler");
 
   assert (handler != PK_NULL);
-  if (pk_call (poke_compiler, handler, NULL, 1, exception) == PK_ERROR)
+  if (pk_call (poke_compiler, handler, NULL, NULL, 1, exception)
+      == PK_ERROR)
     assert (0);
 }
 
diff --git a/poked/poked.c b/poked/poked.c
index 4c04a91b..182f0340 100644
--- a/poked/poked.c
+++ b/poked/poked.c
@@ -81,7 +81,7 @@ poked_buf_send (void)
   usock_out (srv, /*no kind*/ 0, chan, mem, memlen);
   free (mem);
 
-  (void)pk_call (pkc, pk_decl_val (pkc, "__chan_send_reset"), NULL, 0);
+  (void)pk_call (pkc, pk_decl_val (pkc, "__chan_send_reset"), NULL, NULL, 0);
 }
 
 int
@@ -151,7 +151,7 @@ main ()
                   {
                     if (exc != PK_NULL)
                       (void)pk_call (pkc, pk_decl_val (pkc, "poked_ehandler"),
-                                     NULL, 1, exc);
+                                     NULL, NULL, 1, exc);
                     else
                       ok = 1;
                   }
@@ -165,7 +165,7 @@ main ()
                   {
                     if (exc != PK_NULL)
                       (void)pk_call (pkc, pk_decl_val (pkc, "poked_ehandler"),
-                                     NULL, 1, exc);
+                                     NULL, NULL, 1, exc);
                     else if (val != PK_NULL)
                       {
                         ok = 1;
@@ -195,7 +195,7 @@ main ()
               usock_out (srv, VUKIND_CLEAR, USOCK_CHAN_OUT_VU, "", 1);
               out_chan = USOCK_CHAN_OUT_VU;
               out_kind = VUKIND_APPEND;
-              (void)pk_call (pkc, pk_decl_val (pkc, "__vu_dump"), NULL, 0);
+              (void)pk_call (pkc, pk_decl_val (pkc, "__vu_dump"), NULL, NULL, 
0);
               out_chan = USOCK_CHAN_OUT_OUT;
               out_kind = OUTKIND_TXT;
             }
@@ -528,7 +528,7 @@ static void
 poked_free (void)
 {
   if (pkc)
-    (void)pk_call (pkc, pk_decl_val (pkc, "poked_defer"), NULL, 0);
+    (void)pk_call (pkc, pk_decl_val (pkc, "poked_defer"), NULL, NULL, 0);
   pk_compiler_free (pkc);
   pkc = NULL;
 }
-- 
2.11.0