Hi Paul,
On 7/31/2025 6:02 AM, Paul Richard Thomas wrote:
That's exactly how I had a mind to do it. You beat me to it :-(
Just get on, polish the patch and add more tests.
I've updated the patch with improvements to both the functionality and
test cases. It should now work well for simple scalar types.
However, I've found that the issue is more complex than I initially
thought. The current implementation causes an ICE with character and
array types. It seems that we need to handle EXPR_CONDITIONAL every time
we switch against an expr's type, and a quick search shows that there
are many instances of this.
I'm wondering if we could create separate, incremental patches for this.
For example, in this patch, we could deny other complex types in the
resolution process and gradually relax that constraint in future patches.
I also look forward to your comments on the patch itself.
Best regards,
Yuao
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 3cd2eeef11a..eda0659d6e2 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -767,6 +767,16 @@ show_expr (gfc_expr *p)
break;
+ case EXPR_CONDITIONAL:
+ fputc ('(', dumpfile);
+ show_expr (p->value.conditional.condition);
+ fputs (" ? ", dumpfile);
+ show_expr (p->value.conditional.true_expr);
+ fputs (" : ", dumpfile);
+ show_expr (p->value.conditional.false_expr);
+ fputc (')', dumpfile);
+ break;
+
case EXPR_COMPCALL:
show_compcall (p);
break;
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index b8d04ff6f36..ed6d9adf5a6 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -116,6 +116,25 @@ gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
return e;
}
+/* Get a new expression node that is an conditional expression node. */
+
+gfc_expr *
+gfc_get_conditional_expr (locus *where, gfc_expr *condition,
+ gfc_expr *true_expr, gfc_expr *false_expr)
+{
+ gfc_expr *e;
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_CONDITIONAL;
+ e->value.conditional.condition = condition;
+ e->value.conditional.true_expr = true_expr;
+ e->value.conditional.false_expr = false_expr;
+
+ if (where)
+ e->where = *where;
+
+ return e;
+}
/* Get a new expression node that is an structure constructor
of given type and kind. */
@@ -393,6 +412,15 @@ gfc_copy_expr (gfc_expr *p)
break;
+ case EXPR_CONDITIONAL:
+ q->value.conditional.condition
+ = gfc_copy_expr (p->value.conditional.condition);
+ q->value.conditional.true_expr
+ = gfc_copy_expr (p->value.conditional.true_expr);
+ q->value.conditional.false_expr
+ = gfc_copy_expr (p->value.conditional.false_expr);
+ break;
+
case EXPR_FUNCTION:
q->value.function.actual =
gfc_copy_actual_arglist (p->value.function.actual);
@@ -502,6 +530,12 @@ free_expr0 (gfc_expr *e)
gfc_free_expr (e->value.op.op2);
break;
+ case EXPR_CONDITIONAL:
+ gfc_free_expr (e->value.conditional.condition);
+ gfc_free_expr (e->value.conditional.true_expr);
+ gfc_free_expr (e->value.conditional.false_expr);
+ break;
+
case EXPR_FUNCTION:
gfc_free_actual_arglist (e->value.function.actual);
break;
@@ -1083,6 +1117,11 @@ gfc_is_constant_expr (gfc_expr *e)
&& (e->value.op.op2 == NULL
|| gfc_is_constant_expr (e->value.op.op2)));
+ case EXPR_CONDITIONAL:
+ return gfc_is_constant_expr (e->value.conditional.condition)
+ && gfc_is_constant_expr (e->value.conditional.true_expr)
+ && gfc_is_constant_expr (e->value.conditional.false_expr);
+
case EXPR_VARIABLE:
/* The only context in which this can occur is in a parameterized
derived type declaration, so returning true is OK. */
@@ -1354,6 +1393,36 @@ simplify_intrinsic_op (gfc_expr *p, int type)
return true;
}
+/* Try to collapse conditional expressions. */
+
+static bool
+simplify_conditional (gfc_expr *p, int type)
+{
+ gfc_expr *condition, *true_expr, *false_expr;
+
+ condition = p->value.conditional.condition;
+ true_expr = p->value.conditional.true_expr;
+ false_expr = p->value.conditional.false_expr;
+
+ if (!gfc_simplify_expr (condition, type)
+ || !gfc_simplify_expr (true_expr, type)
+ || !gfc_simplify_expr (false_expr, type))
+ return false;
+
+ if (!gfc_is_constant_expr (condition))
+ return true;
+
+ p->value.conditional.condition = NULL;
+ p->value.conditional.true_expr = NULL;
+ p->value.conditional.false_expr = NULL;
+
+ if (condition->value.logical)
+ gfc_replace_expr (p, true_expr);
+ else
+ gfc_replace_expr (p, false_expr);
+
+ return true;
+}
/* Subroutine to simplify constructor expressions. Mutually recursive
with gfc_simplify_expr(). */
@@ -2459,6 +2528,11 @@ gfc_simplify_expr (gfc_expr *p, int type)
return false;
break;
+ case EXPR_CONDITIONAL:
+ if (!simplify_conditional (p, type))
+ return false;
+ break;
+
case EXPR_VARIABLE:
/* Only substitute array parameter variables if we are in an
initialization expression, or we want a subsection. */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d9dcd1b504f..dde892d235a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -176,8 +176,19 @@ enum gfc_source_form
/* Expression node types. */
enum expr_t
- { EXPR_UNKNOWN = 0, EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE,
- EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL,
EXPR_PPC
+{
+ EXPR_UNKNOWN = 0,
+ EXPR_OP = 1,
+ EXPR_FUNCTION,
+ EXPR_CONSTANT,
+ EXPR_VARIABLE,
+ EXPR_SUBSTRING,
+ EXPR_STRUCTURE,
+ EXPR_ARRAY,
+ EXPR_NULL,
+ EXPR_COMPCALL,
+ EXPR_PPC,
+ EXPR_CONDITIONAL,
};
/* Array types. */
@@ -2808,8 +2819,14 @@ typedef struct gfc_expr
character;
gfc_constructor_base constructor;
- }
- value;
+
+ struct
+ {
+ struct gfc_expr *condition;
+ struct gfc_expr *true_expr;
+ struct gfc_expr *false_expr;
+ } conditional;
+ } value;
/* Used to store PDT expression lists associated with expressions. */
gfc_actual_arglist *param_list;
@@ -3924,7 +3941,10 @@ bool gfc_is_ptr_fcn (gfc_expr *);
gfc_expr *gfc_get_expr (void);
gfc_expr *gfc_get_array_expr (bt type, int kind, locus *);
gfc_expr *gfc_get_null_expr (locus *);
-gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *,
gfc_expr *);
+gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op, gfc_expr *,
+ gfc_expr *);
+gfc_expr *gfc_get_conditional_expr (locus *, gfc_expr *, gfc_expr *,
+ gfc_expr *);
gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *);
gfc_expr *gfc_get_constant_expr (bt, int, locus *);
gfc_expr *gfc_get_character_expr (int, locus *, const char *, gfc_charlen_t
len);
diff --git a/gcc/fortran/matchexp.cc b/gcc/fortran/matchexp.cc
index 9b66243b4fa..6e32463984c 100644
--- a/gcc/fortran/matchexp.cc
+++ b/gcc/fortran/matchexp.cc
@@ -856,12 +856,11 @@ match_level_5 (gfc_expr **result)
return MATCH_YES;
}
-
-/* Match an expression. At this level, we are stringing together
+/* Match a binary expression. At this level, we are stringing together
level 5 expressions separated by binary operators. */
-match
-gfc_match_expr (gfc_expr **result)
+static match
+match_binary (gfc_expr **result)
{
gfc_expr *all, *e;
gfc_user_op *uop;
@@ -902,3 +901,53 @@ gfc_match_expr (gfc_expr **result)
*result = all;
return MATCH_YES;
}
+
+/* Match an expression. */
+
+match
+gfc_match_expr (gfc_expr **result)
+{
+ gfc_expr *condition, *true_expr, *false_expr;
+ locus where;
+ match m;
+
+ where = gfc_current_locus;
+
+ m = match_binary (&condition);
+ if (m != MATCH_YES)
+ return m;
+
+ m = gfc_match_char ('?');
+ if (m != MATCH_YES)
+ {
+ *result = condition;
+ return MATCH_YES;
+ }
+
+ m = match_binary (&true_expr);
+ if (m != MATCH_YES)
+ {
+ gfc_free_expr (condition);
+ return m;
+ }
+
+ m = gfc_match_char (':');
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Expected ':' in conditional expression at %C");
+ gfc_free_expr (condition);
+ gfc_free_expr (true_expr);
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_expr (&false_expr);
+ if (m != MATCH_YES)
+ {
+ gfc_free_expr (condition);
+ gfc_free_expr (true_expr);
+ return m;
+ }
+
+ *result = gfc_get_conditional_expr (&where, condition, true_expr,
false_expr);
+ return MATCH_YES;
+}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c33bd17da2d..a6f2b296c32 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -4989,6 +4989,61 @@ simplify_op:
return t;
}
+static bool
+resolve_conditional (gfc_expr *expr)
+{
+ gfc_expr *condition, *true_expr, *false_expr;
+
+ condition = expr->value.conditional.condition;
+ true_expr = expr->value.conditional.true_expr;
+ false_expr = expr->value.conditional.false_expr;
+
+ if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr)
+ || !gfc_resolve_expr (false_expr))
+ return false;
+
+ if (condition->ts.type != BT_LOGICAL)
+ {
+ gfc_error ("Condition in conditional expression must be logical at %L",
+ &condition->where);
+ return false;
+ }
+
+ if (condition->ts.type != BT_LOGICAL)
+ {
+ gfc_error ("Condition in conditional expression must be logical at %L",
+ &condition->where);
+ return false;
+ }
+
+ if (true_expr->ts.type != false_expr->ts.type)
+ {
+ gfc_error ("True and false expressions in conditional expression "
+ "must have the same declared type at %L",
+ &expr->where);
+ return false;
+ }
+
+ if (true_expr->ts.kind != false_expr->ts.kind)
+ {
+ gfc_error ("True and false expressions in conditional expression "
+ "must have the same kind parameter at %L",
+ &expr->where);
+ return false;
+ }
+
+ if (true_expr->rank != false_expr->rank)
+ {
+ gfc_error ("True and false expressions in conditional expression "
+ "must have the same rank at %L",
+ &expr->where);
+ return false;
+ }
+
+ expr->ts = true_expr->ts;
+ expr->rank = true_expr->rank;
+ return true;
+}
/************** Array resolution subroutines **************/
@@ -7980,6 +8035,10 @@ gfc_resolve_expr (gfc_expr *e)
t = resolve_operator (e);
break;
+ case EXPR_CONDITIONAL:
+ t = resolve_conditional (e);
+ break;
+
case EXPR_FUNCTION:
case EXPR_VARIABLE:
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ec240844a5e..fe31c055ab9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4369,6 +4369,37 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->post, &lse.post);
}
+static void
+gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
+{
+ gfc_se cond_se, true_se, false_se;
+ tree condition, true_val, false_val;
+ tree type;
+
+ gfc_init_se (&cond_se, se);
+ gfc_init_se (&true_se, se);
+ gfc_init_se (&false_se, se);
+
+ gfc_conv_expr (&cond_se, expr->value.conditional.condition);
+ gfc_add_block_to_block (&se->pre, &cond_se.pre);
+ condition = gfc_evaluate_now (cond_se.expr, &se->pre);
+
+ gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
+ gfc_add_block_to_block (&se->pre, &true_se.pre);
+ true_val = true_se.expr;
+
+ gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
+ gfc_add_block_to_block (&se->pre, &false_se.pre);
+ false_val = false_se.expr;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ true_val = fold_convert (type, true_val);
+ false_val = fold_convert (type, false_val);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
+ true_val, false_val);
+}
+
/* If a string's length is one, we convert it to a single character. */
tree
@@ -10418,6 +10449,10 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
gfc_conv_expr_op (se, expr);
break;
+ case EXPR_CONDITIONAL:
+ gfc_conv_conditional_expr (se, expr);
+ break;
+
case EXPR_FUNCTION:
gfc_conv_function_expr (se, expr);
break;
diff --git a/gcc/testsuite/gfortran.dg/conditional_1.f90
b/gcc/testsuite/gfortran.dg/conditional_1.f90
new file mode 100644
index 00000000000..f21697237dc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/conditional_1.f90
@@ -0,0 +1,12 @@
+! { dg-do run }
+program conditional_simple
+ implicit none
+ integer :: i = 42
+
+ i = i > 0 ? 1 : -1
+ if (i /= 1) stop 1
+
+ i = 0
+ i = i > 0 ? 1 : i < 0 ? -1 : 0
+ if (i /= 0) stop 2
+end program conditional_simple
diff --git a/gcc/testsuite/gfortran.dg/conditional_2.f90
b/gcc/testsuite/gfortran.dg/conditional_2.f90
new file mode 100644
index 00000000000..c3bb78e452f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/conditional_2.f90
@@ -0,0 +1,12 @@
+! { dg-do run }
+program conditional_constant
+ implicit none
+ integer :: i = 42
+
+ i = .true. ? 1 : -1
+ if (i /= 1) stop 1
+
+ i = 0
+ i = i > 0 ? 1 : .false. ? -1 : 0
+ if (i /= 0) stop 2
+end program conditional_constant
diff --git a/gcc/testsuite/gfortran.dg/conditional_3.f90
b/gcc/testsuite/gfortran.dg/conditional_3.f90
new file mode 100644
index 00000000000..748a578e1fb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/conditional_3.f90
@@ -0,0 +1,7 @@
+! { dg-do compile }
+program conditional_without_colon
+ implicit none
+ integer :: i = 42
+
+ i = i > 0 ? 1 -1 ! { dg-error "Expected ':' in conditional expression" }
+end program conditional_without_colon
diff --git a/gcc/testsuite/gfortran.dg/conditional_4.f90
b/gcc/testsuite/gfortran.dg/conditional_4.f90
new file mode 100644
index 00000000000..32f3d4829e4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/conditional_4.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+program conditional_resolve
+ implicit none
+ integer :: i = 42
+ integer, parameter :: ucs4 = selected_char_kind('ISO_10646')
+ character(kind=1) :: k1 = "k1"
+ character(kind=ucs4) :: k4 = "k4"
+ integer, dimension(1) :: a_1d
+ integer, dimension(1, 1) :: a_2d
+
+ i = i ? 1 : -1 ! { dg-error "Condition in conditional expression must be
logical" }
+ i = i /= 0 ? 1 : "oh no" ! { dg-error "must have the same declared type" }
+ i = i /= 0 ? k1 : k4 ! { dg-error "must have the same kind parameter" }
+ i = i /= 0 ? a_1d : a_2d ! { dg-error "must have the same rank" }
+end program conditional_resolve
