[COMMITTED] pkl, testsuite: support for the EXCOND ?! operator

[Jose E. Marchesi]

This operator has two forms:

  EXPRESSION ?! EXCEPTION

and

  COMP_STMT ?! EXCEPTION

i.e. as the first operator it can get an arbitrary expression or a
compound statement.

In both cases, the ?! operator always evaluates to a boolean value.  If
the execution of the expression or statement raises EXCEPTION, the
result of the operation is 0 (false).  Otherwise it is 1 (true).  The
value to which EXPRESSION evaluates is discarded.

Simple example:

 if (1/zero ?! E_div_by_zero)
   print "division by zero\n";

A motivation for this feature is, given an union, an easy way to
determine whether a given alternative is the chosen one without having
to resort to a clumsy try-catch:

  union
  {
    int alt1 : ... ;
    int alt2;

    method _print =
    {
      if (alt1 ?! E_elem)
        pretty_print_alt1;
      else
        pretty_print_alt2;
    }
  }

An example with a statement:

  if ({ do_whatever_io_operation; } ?! E_eof)
    printf "EOF happened\n";

Using the operator in a statement-expression is also useful.  Consider
this idiom we use in pkl-rt-1.pk and other places:

  /* Add the directories in POKE_LOAD_PATH, if defined.  */
  try load_path = getenv ("POKE_LOAD_PATH") + ":" + load_path;
  catch if E_inval { }

This can now be rewritten as:

  /* Add the directories in POKE_LOAD_PATH, if defined.  */
  { load_path = getenv ("POKE_LOAD_PATH") + ":" + load_path } ?! E_inval

2021-12-26  Jose E. Marchesi  <jemarch@gnu.org>

        * libpoke/pkl-ops.def: Entry for PKL_AST_OP_EXCOND.
        * libpoke/pkl-lex.l: Recognize `?!' as EXCOND.
        * libpoke/pkl-tab.y (EXCOND): New token.
        (expression): Add rule for EXCOND.
        * libpoke/pkl-typify.c (pkl_phase_typify1): Install handler.
        (pkl_typify1_ps_op_excond): New handler.
        * libpoke/pkl-gen.c (pkl_gen_pr_op_excond): New handler.
        (pkl_phase_gen): Install handler.
        * testsuite/poke.pkl/excond-diag-1.pk: New test.
        * testsuite/poke.pkl/excond-1.pk: Likewise.
        * testsuite/poke.pkl/excond-2.pk: Likewise.
        * testsuite/poke.pkl/excond-3.pk: Likewise.
        * testsuite/poke.pkl/excond-4.pk: Likewise.
        * testsuite/poke.pkl/excond-5.pk: Likewise.
        * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
        * etc/poke.rec (Exception predicate operator !?): Remove as done.
        * doc/poke.texi (exception-predicate): New section.
---
 ChangeLog                           | 20 +++++++++++++
 doc/poke.texi                       | 60 +++++++++++++++++++++++++++++++++++++
 etc/poke.rec                        | 13 --------
 libpoke/pkl-gen.c                   | 48 +++++++++++++++++++++++++++++
 libpoke/pkl-lex.l                   |  8 ++---
 libpoke/pkl-ops.def                 |  1 +
 libpoke/pkl-tab.y                   | 14 +++++++++
 libpoke/pkl-typify.c                | 36 ++++++++++++++++++++++
 testsuite/Makefile.am               |  6 ++++
 testsuite/poke.pkl/excond-1.pk      |  4 +++
 testsuite/poke.pkl/excond-2.pk      |  6 ++++
 testsuite/poke.pkl/excond-3.pk      |  4 +++
 testsuite/poke.pkl/excond-4.pk      |  4 +++
 testsuite/poke.pkl/excond-5.pk      |  4 +++
 testsuite/poke.pkl/excond-diag-1.pk |  4 +++
 15 files changed, 215 insertions(+), 17 deletions(-)
 create mode 100644 testsuite/poke.pkl/excond-1.pk
 create mode 100644 testsuite/poke.pkl/excond-2.pk
 create mode 100644 testsuite/poke.pkl/excond-3.pk
 create mode 100644 testsuite/poke.pkl/excond-4.pk
 create mode 100644 testsuite/poke.pkl/excond-5.pk
 create mode 100644 testsuite/poke.pkl/excond-diag-1.pk

diff --git a/ChangeLog b/ChangeLog
index 88bebaeb..a1c9aa06 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,23 @@
+2021-12-26  Jose E. Marchesi  <jemarch@gnu.org>
+
+       * libpoke/pkl-ops.def: Entry for PKL_AST_OP_EXCOND.
+       * libpoke/pkl-lex.l: Recognize `?!' as EXCOND.
+       * libpoke/pkl-tab.y (EXCOND): New token.
+       (expression): Add rule for EXCOND.
+       * libpoke/pkl-typify.c (pkl_phase_typify1): Install handler.
+       (pkl_typify1_ps_op_excond): New handler.
+       * libpoke/pkl-gen.c (pkl_gen_pr_op_excond): New handler.
+       (pkl_phase_gen): Install handler.
+       * testsuite/poke.pkl/excond-diag-1.pk: New test.
+       * testsuite/poke.pkl/excond-1.pk: Likewise.
+       * testsuite/poke.pkl/excond-2.pk: Likewise.
+       * testsuite/poke.pkl/excond-3.pk: Likewise.
+       * testsuite/poke.pkl/excond-4.pk: Likewise.
+       * testsuite/poke.pkl/excond-5.pk: Likewise.
+       * testsuite/Makefile.am (EXTRA_DIST): Add new tests.
+       * etc/poke.rec (Exception predicate operator !?): Remove as done.
+       * doc/poke.texi (exception-predicate): New section.
+
 2021-12-24  Jose E. Marchesi  <jemarch@gnu.org>
 
        * libpoke/pvm.jitter: Fix docstring for the instruction `pushe'.
diff --git a/doc/poke.texi b/doc/poke.texi
index 9bf4b82b..f9ef3116 100644
--- a/doc/poke.texi
+++ b/doc/poke.texi
@@ -12409,6 +12409,7 @@ provides an exceptions mechanism to deal with these 
situations.
 * try-catch::          Catching exceptions in programs.
 * try-until::          Running code until some exception occurs.
 * raise::              Raising exceptions in programs.
+* exception-predicate:: Turning exceptions into booleans.
 * assert::             Asserting conditions in programs.
 @end menu
 
@@ -12605,6 +12606,65 @@ raise @var{exception};
 where @var{exception} is an integer.  This integer can be any number,
 but most often is one of the @code{E_*} codes defined in Poke.
 
+@node exception-predicate
+@subsection exception-predicate
+
+It is often needed to determine whether the execution of some given
+code raised some particular exception.  A possibility is to use a
+@code{try-catch} statement like in the following example, a
+pretty-printer in an union type:
+
+@example
+method _print = void:
+@{
+  try print "#<%u32d>", simple_value;
+  catch if E_elem @{ print "%v\n", complex_value; @}
+@}
+@end example
+
+This works as intended, but it is somewhat verbose and not that easy
+to read for anyone not accustomed to the idiom.  It is better to use
+the @dfn{exception predicate} operator, @code{?!}, that has two forms:
+
+@example
+@var{exp} ?! @var{exception}
+@{ [@var{statements}...] @} ?! @var{exception}
+@end example
+
+In the first form, the expression @var{exp} is executed.  If the
+execution raises the exception @var{exception} then the result of the
+predicate is @code{0} (false), otherwise it is @code{1} (true).  The
+value of the expression is discarded.
+
+In the second form, the compound statement passed as the first operand
+is executed.  If the exception @var{exception} is raised, then the
+result of the predicate is @code{0} (false), otherwise it is @code{1}
+(true).
+
+Using exception predicates the pretty-printer above can be written in
+a much more readable way:
+
+@example
+method _print = void:
+@{
+  if (simple_value ?! E_elem)
+    print "#<%u32d>", simple_value;
+  else
+    print "%v\n", complex_value;
+@}
+@end example
+
+@noindent
+Or, alternatively (and slightly more efficiently):
+
+@example
+method _print = void:
+@{
+  (@{ print "<%u32d>", simple_value; @} ?! E_elem)
+    || print "%v\n", complex_value;
+@}
+@end example
+
 @node assert
 @subsection @code{assert}
 @cindex @code{assert}
diff --git a/etc/poke.rec b/etc/poke.rec
index e1902fb8..760a3093 100644
--- a/etc/poke.rec
+++ b/etc/poke.rec
@@ -473,19 +473,6 @@ Description:
 RFC: yes
 Target: 2.0
 
-Summary: Exception predicate operator !?
-Component: Language
-Kind: ENH
-Priority: 3
-Description:
-+ expr !? Exception
-+ or
-+ expr ?! Exception
-+
-+ if (do_foo () !? E_constraint)
-+   ...;
-RFC: yes
-
 Summary: Introduce SELF in methods
 Component: Language
 Kind: ENH
diff --git a/libpoke/pkl-gen.c b/libpoke/pkl-gen.c
index bd5c1cf5..a334b88c 100644
--- a/libpoke/pkl-gen.c
+++ b/libpoke/pkl-gen.c
@@ -4037,6 +4037,53 @@ PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_op_impl)
 }
 PKL_PHASE_END_HANDLER
 
+/*
+ * EXCOND
+ * | EXP|STMT
+ * | EXCEPTION_ID
+ */
+
+PKL_PHASE_BEGIN_HANDLER (pkl_gen_pr_op_excond)
+{
+  pkl_asm pasm = PKL_GEN_ASM;
+
+  pkl_ast_node exp = PKL_PASS_NODE;
+  pkl_ast_node op1 = PKL_AST_EXP_OPERAND (exp, 0);
+  pkl_ast_node op2 = PKL_AST_EXP_OPERAND (exp, 1);
+
+  pvm_program_label exception_handler = pkl_asm_fresh_label (PKL_GEN_ASM);
+  pvm_program_label done = pkl_asm_fresh_label (PKL_GEN_ASM);
+
+  /* Push the provisional result of the operation, which is
+     `true'.  */
+  pkl_asm_insn (pasm, PKL_INSN_PUSH, pvm_make_int (1, 32));
+
+  /* Install a handler for the exception specified in the second
+     operand.  */
+  PKL_PASS_SUBPASS (op2);
+  pkl_asm_insn (pasm, PKL_INSN_PUSHE, exception_handler);
+
+  /* Execute the expression or statement in `op1'.  If it is an
+     expression, discard the result value.  */
+  PKL_PASS_SUBPASS (op1);
+  if (PKL_AST_IS_EXP (op1))
+    pkl_asm_insn (pasm, PKL_INSN_DROP);
+
+  pkl_asm_insn (pasm, PKL_INSN_BA, done);
+
+  /* The exception handler just drops the raised exception and the
+     provisional result `true' and pushes `false' to reflect the
+     exception was raised. */
+  pkl_asm_label (pasm, exception_handler);
+  pkl_asm_insn (pasm, PKL_INSN_DROP); /* The exception.  */
+  pkl_asm_insn (pasm, PKL_INSN_DROP); /* The provisional result.  */
+  pkl_asm_insn (pasm, PKL_INSN_PUSH, pvm_make_int (0, 32));
+
+  pkl_asm_label (pasm, done);
+  PKL_PASS_BREAK;
+}
+PKL_PHASE_END_HANDLER
+
 PKL_PHASE_BEGIN_HANDLER (pkl_gen_ps_op_rela)
 {
   pkl_asm pasm = PKL_GEN_ASM;
@@ -4437,6 +4484,7 @@ struct pkl_phase pkl_phase_gen =
    PKL_PHASE_PS_OP_HANDLER (PKL_AST_OP_BCONC, pkl_gen_ps_op_bconc),
    PKL_PHASE_PS_OP_HANDLER (PKL_AST_OP_UNMAP, pkl_gen_ps_op_unmap),
    PKL_PHASE_PS_OP_HANDLER (PKL_AST_OP_IN, pkl_gen_ps_op_in),
+   PKL_PHASE_PR_OP_HANDLER (PKL_AST_OP_EXCOND, pkl_gen_pr_op_excond),
    PKL_PHASE_PS_TYPE_HANDLER (PKL_TYPE_VOID, pkl_gen_ps_type_void),
    PKL_PHASE_PS_TYPE_HANDLER (PKL_TYPE_ANY, pkl_gen_ps_type_any),
    PKL_PHASE_PS_TYPE_HANDLER (PKL_TYPE_INTEGRAL, pkl_gen_ps_type_integral),
diff --git a/libpoke/pkl-lex.l b/libpoke/pkl-lex.l
index 38c3b38d..7da0fe55 100644
--- a/libpoke/pkl-lex.l
+++ b/libpoke/pkl-lex.l
@@ -320,13 +320,13 @@ S ::
 "%="                { return MODA; }
 "+="                { return ADDA; }
 "-="                { return SUBA; }
-"<<.="                { return SLA; }
-".>>="                { return SRA; }
+"<<.="              { return SLA; }
+".>>="              { return SRA; }
 "&="                { return BANDA; }
 "|="                { return IORA; }
 "^="                { return XORA; }
-":::"                { return BCONC; }
-
+":::"               { return BCONC; }
+"?!"                { return EXCOND; }
 "||"                { return OR; }
 "&&"                { return AND; }
 "=>"                { return IMPL; }
diff --git a/libpoke/pkl-ops.def b/libpoke/pkl-ops.def
index a3dbc680..0cde9719 100644
--- a/libpoke/pkl-ops.def
+++ b/libpoke/pkl-ops.def
@@ -47,6 +47,7 @@ PKL_DEF_OP (PKL_AST_OP_BCONC, "BCONC")
 PKL_DEF_OP (PKL_AST_OP_IN, "IN")
 PKL_DEF_OP (PKL_AST_OP_GCD, "GCD")
 PKL_DEF_OP (PKL_AST_OP_IMPL, "IMPL")
+PKL_DEF_OP (PKL_AST_OP_EXCOND, "EXCOND")
 
 /* Unary operators.  */
 PKL_DEF_OP (PKL_AST_OP_PREINC, "PREINC")
diff --git a/libpoke/pkl-tab.y b/libpoke/pkl-tab.y
index 8c1913b4..cf066a22 100644
--- a/libpoke/pkl-tab.y
+++ b/libpoke/pkl-tab.y
@@ -500,6 +500,7 @@ token <integer> UNION    _("keyword `union'")
 %token '.'              _("dot operator")
 %token <ast> ATTR       _("attribute")
 %token UNMAP            _("unmap operator")
+%token EXCOND           _("conditional on exception operator")
 
 %token BIG              _("keyword `big'")
 %token LITTLE           _("keyword `little'")
@@ -515,6 +516,7 @@ token <integer> UNION    _("keyword `union'")
 /* Operator tokens and their precedences, in ascending order.  */
 
 %right IMPL
+%left EXCOND
 %right '?' ':'
 %left OR
 %left AND
@@ -941,6 +943,18 @@ expression:
                                               $1, $3, $5);
                   PKL_AST_LOC ($$) = @$;
                 }
+        | comp_stmt EXCOND expression
+                {
+                  $$ = pkl_ast_make_binary_exp (pkl_parser->ast, 
PKL_AST_OP_EXCOND,
+                                                $1, $3);
+                  PKL_AST_LOC ($$) = @$;
+                }
+        | expression EXCOND expression
+                {
+                  $$ = pkl_ast_make_binary_exp (pkl_parser->ast, 
PKL_AST_OP_EXCOND,
+                                                $1, $3);
+                  PKL_AST_LOC ($$) = @$;
+                }
         | cons_type_specifier '(' expression_list opt_comma ')'
                 {
                   /* This syntax is only used for array
diff --git a/libpoke/pkl-typify.c b/libpoke/pkl-typify.c
index 54ebbbb0..6b29b487 100644
--- a/libpoke/pkl-typify.c
+++ b/libpoke/pkl-typify.c
@@ -2856,6 +2856,41 @@ expected %s got %s",
 }
 PKL_PHASE_END_HANDLER
 
+/* The type of an EXCOND ?! operation is a boolean encoded in an
+   int<32>.
+
+   The first operand, when it is an expression, can be of any type.
+   The first operand, when it is a statement, has not type.
+
+   The second operand must be an Exception struct.  */
+
+PKL_PHASE_BEGIN_HANDLER (pkl_typify1_ps_op_excond)
+{
+  pkl_ast_node exp = PKL_PASS_NODE;
+  pkl_ast_node op2 = PKL_AST_EXP_OPERAND (exp, 1);
+  pkl_ast_node t2 = PKL_AST_TYPE (op2);
+
+  if (!pkl_ast_type_is_exception (t2))
+    {
+      char *t2_str = pkl_type_str (t2, 1);
+
+      PKL_ERROR (PKL_AST_LOC (op2), "operator has the wrong type\n\
+expected Exception, got %s", t2_str);
+      free (t2_str);
+
+      PKL_TYPIFY_PAYLOAD->errors++;
+      PKL_PASS_ERROR;
+    }
+  else
+    {
+      pkl_ast_node int32_type
+        = pkl_ast_make_integral_type (PKL_PASS_AST, 32, 1);
+
+      PKL_AST_TYPE (exp) = ASTREF (int32_type);
+    }
+}
+PKL_PHASE_END_HANDLER
+
 struct pkl_phase pkl_phase_typify1 =
   {
    PKL_PHASE_PS_HANDLER (PKL_AST_SRC, pkl_typify_ps_src),
@@ -2921,6 +2956,7 @@ struct pkl_phase pkl_phase_typify1 =
    PKL_PHASE_PS_OP_HANDLER (PKL_AST_OP_UNMAP, pkl_typify1_ps_op_unmap),
    PKL_PHASE_PS_OP_HANDLER (PKL_AST_OP_BCONC, pkl_typify1_ps_op_bconc),
    PKL_PHASE_PS_OP_HANDLER (PKL_AST_OP_IN, pkl_typify1_ps_op_in),
+   PKL_PHASE_PS_OP_HANDLER (PKL_AST_OP_EXCOND, pkl_typify1_ps_op_excond),
 
    PKL_PHASE_PS_TYPE_HANDLER (PKL_TYPE_INTEGRAL, pkl_typify1_ps_type_integral),
    PKL_PHASE_PS_TYPE_HANDLER (PKL_TYPE_ARRAY, pkl_typify1_ps_type_array),
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index e222e740..fee8c9e3 100644
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -993,6 +993,12 @@ EXTRA_DIST = \
   poke.pkl/eq-structs-11.pk \
   poke.pkl/eq-structs-12.pk \
   poke.pkl/eq-structs-diag-1.pk \
+  poke.pkl/excond-1.pk \
+  poke.pkl/excond-2.pk \
+  poke.pkl/excond-3.pk \
+  poke.pkl/excond-4.pk \
+  poke.pkl/excond-5.pk \
+  poke.pkl/excond-diag-1.pk \
   poke.pkl/field-init-1.pk \
   poke.pkl/field-init-2.pk \
   poke.pkl/field-init-3.pk \
diff --git a/testsuite/poke.pkl/excond-1.pk b/testsuite/poke.pkl/excond-1.pk
new file mode 100644
index 00000000..dea92b0d
--- /dev/null
+++ b/testsuite/poke.pkl/excond-1.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command { 2 ?! E_generic } } */
+/* { dg-output "1" } */
diff --git a/testsuite/poke.pkl/excond-2.pk b/testsuite/poke.pkl/excond-2.pk
new file mode 100644
index 00000000..662140d4
--- /dev/null
+++ b/testsuite/poke.pkl/excond-2.pk
@@ -0,0 +1,6 @@
+/* { dg-do run } */
+
+var zero = 0;
+
+/* { dg-command { 2/zero ?! E_div_by_zero } } */
+/* { dg-output "0" } */
diff --git a/testsuite/poke.pkl/excond-3.pk b/testsuite/poke.pkl/excond-3.pk
new file mode 100644
index 00000000..7289f5e8
--- /dev/null
+++ b/testsuite/poke.pkl/excond-3.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command { { print "lala\n"; raise E_generic; } ?! E_generic } } */
+/* { dg-output "lala\n0" } */
diff --git a/testsuite/poke.pkl/excond-4.pk b/testsuite/poke.pkl/excond-4.pk
new file mode 100644
index 00000000..7289f5e8
--- /dev/null
+++ b/testsuite/poke.pkl/excond-4.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command { { print "lala\n"; raise E_generic; } ?! E_generic } } */
+/* { dg-output "lala\n0" } */
diff --git a/testsuite/poke.pkl/excond-5.pk b/testsuite/poke.pkl/excond-5.pk
new file mode 100644
index 00000000..8d8787ea
--- /dev/null
+++ b/testsuite/poke.pkl/excond-5.pk
@@ -0,0 +1,4 @@
+/* { dg-do run } */
+
+/* { dg-command { try { print "lala\n"; raise E_elem; } ?! E_div_by_zero; 
catch if E_elem { printf "lele\n"; } } } */
+/* { dg-output "lala\nlele" } */
diff --git a/testsuite/poke.pkl/excond-diag-1.pk 
b/testsuite/poke.pkl/excond-diag-1.pk
new file mode 100644
index 00000000..5bc46cc9
--- /dev/null
+++ b/testsuite/poke.pkl/excond-diag-1.pk
@@ -0,0 +1,4 @@
+/* { dg-do compile } */
+
+var a
+  = 2 ?! "foo"; /* { dg-error "wrong type.*\n.*expected Exception" } */
-- 
2.11.0