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;
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. */
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);
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;
&& (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. */
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);
+ gfc_free_expr (false_expr);
+ }
+ else
+ {
+ gfc_replace_expr (p, false_expr);
+ gfc_free_expr (true_expr);
+ }
+ gfc_free_expr (condition);
+
+ return true;
+}
/* Subroutine to simplify constructor expressions. Mutually recursive
with gfc_simplify_expr(). */
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. */
break;
+ case EXPR_CONDITIONAL:
+ t = gfc_check_init_expr (e->value.conditional.condition);
+ if (!t)
+ break;
+ t = gfc_check_init_expr (e->value.conditional.true_expr);
+ if (!t)
+ break;
+ t = gfc_check_init_expr (e->value.conditional.false_expr);
+ if (t)
+ t = gfc_simplify_expr (e, 0);
+ else
+ t = false;
+ break;
+
case EXPR_FUNCTION:
t = false;
break;
+ case EXPR_CONDITIONAL:
+ t = check_restricted (e->value.conditional.condition);
+ if (!t)
+ break;
+ t = check_restricted (e->value.conditional.true_expr);
+ if (!t)
+ break;
+ t = check_restricted (e->value.conditional.false_expr);
+ if (t)
+ t = gfc_simplify_expr (e, 0);
+ else
+ t = false;
+ break;
+
case EXPR_FUNCTION:
if (e->value.function.esym)
{
return true;
break;
+ case EXPR_CONDITIONAL:
+ if (gfc_traverse_expr (expr->value.conditional.condition, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (expr->value.conditional.true_expr, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (expr->value.conditional.false_expr, sym, func, f))
+ return true;
+ break;
+
default:
gcc_unreachable ();
break;
for (a = (*e)->value.function.actual; a; a = a->next)
WALK_SUBEXPR (a->expr);
break;
+ case EXPR_CONDITIONAL:
+ WALK_SUBEXPR ((*e)->value.conditional.condition);
+ WALK_SUBEXPR ((*e)->value.conditional.true_expr);
+ WALK_SUBEXPR ((*e)->value.conditional.false_expr);
+ break;
case EXPR_COMPCALL:
case EXPR_PPC:
WALK_SUBEXPR ((*e)->value.compcall.base_object);
/* 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. */
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;
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);
return e2;
}
+/* Match a conditional expression. */
+
+static match
+match_conditional (gfc_expr **result)
+{
+ gfc_expr *condition, *true_expr, *false_expr;
+ locus where;
+ match m;
+
+ where = gfc_current_locus;
+
+ m = gfc_match_expr (&condition);
+ if (m != MATCH_YES)
+ {
+ gfc_error (expression_syntax);
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_char ('?');
+ if (m != MATCH_YES)
+ {
+ *result = condition;
+ return MATCH_YES;
+ }
+ else if (!gfc_notify_std (GFC_STD_F2023, "Conditional expression at %L",
+ &where))
+ {
+ gfc_free_expr (condition);
+ return MATCH_ERROR;
+ }
+
+ gfc_gobble_whitespace ();
+ m = gfc_match_expr (&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 = match_conditional (&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;
+}
/* Match a primary expression. */
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
- m = gfc_match_expr (&e);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
+ m = match_conditional (&e);
+ if (m != MATCH_YES)
return m;
m = gfc_match_char (')');
if (m == MATCH_NO)
gfc_error ("Expected a right parenthesis in expression at %C");
- /* Now we have the expression inside the parentheses, build the
- expression pointing to it. By 7.1.7.2, any expression in
- parentheses shall be treated as a data entity. */
- *result = gfc_get_parentheses (e);
+ /* Now we have the expression inside the parentheses, build the expression
+ pointing to it. By 7.1.7.2, any expression in parentheses shall be treated
+ as a data entity.
+ Note that if the expression is a conditional expression, we will omit the
+ extra parentheses. */
+ *result = e->expr_type == EXPR_CONDITIONAL ? e : gfc_get_parentheses (e);
if (m != MATCH_YES)
{
}
return MATCH_YES;
-
-syntax:
- gfc_error (expression_syntax);
- return MATCH_ERROR;
}
minit ("ARRAY", EXPR_ARRAY),
minit ("NULL", EXPR_NULL),
minit ("COMPCALL", EXPR_COMPCALL),
- minit (NULL, -1)
+ minit ("PPC", EXPR_PPC),
+ minit ("CONDITIONAL", EXPR_CONDITIONAL),
+ minit (NULL, -1),
};
/* INTRINSIC_ASSIGN is missing because it is used as an index for
break;
+ case EXPR_CONDITIONAL:
+ mio_expr (&e->value.conditional.condition);
+ mio_expr (&e->value.conditional.true_expr);
+ mio_expr (&e->value.conditional.false_expr);
+ break;
+
case EXPR_FUNCTION:
mio_symtree_ref (&e->symtree);
mio_actual_arglist (&e->value.function.actual, false);
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 || condition->rank != 0)
+ {
+ gfc_error (
+ "Condition in conditional expression must be a scalar logical at %L",
+ &condition->where);
+ return false;
+ }
+
+ if (true_expr->ts.type != false_expr->ts.type)
+ {
+ gfc_error ("expr at %L and expr at %L in conditional expression "
+ "must have the same declared type",
+ &true_expr->where, &false_expr->where);
+ return false;
+ }
+
+ if (true_expr->ts.kind != false_expr->ts.kind)
+ {
+ gfc_error ("expr at %L and expr at %L in conditional expression "
+ "must have the same kind parameter",
+ &true_expr->where, &false_expr->where);
+ return false;
+ }
+
+ if (true_expr->rank != false_expr->rank)
+ {
+ gfc_error ("expr at %L and expr at %L in conditional expression "
+ "must have the same rank",
+ &true_expr->where, &false_expr->where);
+ return false;
+ }
+
+ /* TODO: support more data types for conditional expressions */
+ if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL
+ && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX)
+ {
+ gfc_error ("Sorry, only integer, logical, real and complex types "
+ "are currently supported for conditional expressions at %L",
+ &expr->where);
+ return false;
+ }
+
+ if (true_expr->rank > 0)
+ {
+ gfc_error ("Sorry, array is currently unsupported for conditional "
+ "expressions at %L",
+ &expr->where);
+ return false;
+ }
+
+ expr->ts = true_expr->ts;
+ expr->rank = true_expr->rank;
+ return true;
+}
/************** Array resolution subroutines **************/
t = resolve_operator (e);
break;
+ case EXPR_CONDITIONAL:
+ t = resolve_conditional (e);
+ break;
+
case EXPR_FUNCTION:
case EXPR_VARIABLE:
return head2;
}
+static gfc_ss *
+gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr)
+{
+ gfc_ss *head;
+
+ head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr);
+ head = gfc_walk_subexpr (head, expr->value.conditional.false_expr);
+ return head;
+}
/* Reverse a SS chain. */
head = gfc_walk_op_expr (ss, expr);
return head;
+ case EXPR_CONDITIONAL:
+ head = gfc_walk_conditional_expr (ss, expr);
+ return head;
+
case EXPR_FUNCTION:
head = gfc_walk_function_expr (ss, expr);
return head;
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);
+
+ true_se.want_pointer = se->want_pointer;
+ gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
+ true_val = true_se.expr;
+ false_se.want_pointer = se->want_pointer;
+ gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
+ false_val = false_se.expr;
+
+ if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
+ gfc_add_expr_to_block (
+ &se->pre,
+ fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
+ true_se.pre.head != NULL_TREE
+ ? gfc_finish_block (&true_se.pre)
+ : build_empty_stmt (input_location),
+ false_se.pre.head != NULL_TREE
+ ? gfc_finish_block (&false_se.pre)
+ : build_empty_stmt (input_location)));
+
+ if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
+ gfc_add_expr_to_block (
+ &se->post,
+ fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
+ true_se.post.head != NULL_TREE
+ ? gfc_finish_block (&true_se.post)
+ : build_empty_stmt (input_location),
+ false_se.post.head != NULL_TREE
+ ? gfc_finish_block (&false_se.post)
+ : build_empty_stmt (input_location)));
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ if (se->want_pointer)
+ type = build_pointer_type (type);
+
+ 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
gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
break;
+ case EXPR_CONDITIONAL:
+ gfc_apply_interface_mapping_to_expr (mapping,
+ expr->value.conditional.true_expr);
+ gfc_apply_interface_mapping_to_expr (mapping,
+ expr->value.conditional.false_expr);
+ break;
+
case EXPR_FUNCTION:
for (actual = expr->value.function.actual; actual; actual = actual->next)
gfc_apply_interface_mapping_to_expr (mapping, actual->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;
return;
}
+ if (expr->expr_type == EXPR_CONDITIONAL)
+ {
+ se->want_pointer = 1;
+ gfc_conv_expr (se, expr);
+ return;
+ }
+
if (expr->expr_type == EXPR_FUNCTION
&& ((expr->value.function.esym
&& expr->value.function.esym->result
--- /dev/null
+! { dg-do run }
+! { dg-options "-std=f2023" }
+program conditional_simple
+ implicit none
+ integer :: i = 42
+ logical :: l = .true.
+ real(4) :: r1 = 1.e-4, r2 = 1.e-5
+ complex :: z = (3.0, 4.0)
+
+ 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
+
+ i = 0
+ i = (i > 0 ? 1 : (i < 0 ? -1 : 0))
+ if (i /= 0) stop 3
+
+ i = 0
+ i = (l .eqv. .false. ? 1 : 0)
+ if (i /= 0) stop 4
+
+ i = 0
+ i = (r1 /= r2 ? 0 : 1)
+ if (i /= 0) stop 5
+
+ i = 0
+ z = (i /= 0 ? z : (-3.0, -4.0))
+ if (z /= (-3.0, -4.0)) stop 6
+end program conditional_simple
--- /dev/null
+! { dg-do run }
+! { dg-options "-std=f2023" }
+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
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2023" }
+program conditional_syntax
+ implicit none
+ integer :: i = 42
+
+ i = i > 0 ? 1 : -1 ! { dg-error "Unclassifiable statement at" }
+ i = (i > 0 ? 1 -1) ! { dg-error "Expected ':' in conditional expression" }
+end program conditional_syntax
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2023" }
+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
+ logical :: l1(2)
+ integer :: i1(2)
+
+ i = (l1 ? 1 : -1) ! { dg-error "Condition in conditional expression must be a scalar logical" }
+ i = (i ? 1 : -1) ! { dg-error "Condition in conditional expression must be a scalar 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" }
+ k1 = (i /= 0 ? k1 : k1) ! { dg-error "Sorry, only integer, logical, real and complex types are currently supported for conditional expressions" }
+ i1 = (i /= 0 ? i1 : i1 + 1) ! { dg-error "Sorry, array is currently unsupported for conditional expressions" }
+end program conditional_resolve
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2018" }
+program conditional_std
+ implicit none
+ integer :: i = 42
+ i = (i > 0 ? 1 : -1) ! { dg-error "Fortran 2023: Conditional expression at" }
+end program conditional_std
--- /dev/null
+! { dg-do run }
+! { dg-options "-std=f2023" }
+program conditional_arg
+ implicit none
+ integer :: a = 4
+ integer :: b = 5
+ call five((a < 5 ? a : b))
+ if (a /= 5) stop 1
+contains
+ subroutine five(x)
+ integer, optional :: x
+ if (present(x)) then
+ x = 5
+ end if
+ end subroutine five
+end program conditional_arg
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2023" }
+module m
+ contains
+ function f(n) result(str)
+ integer, value :: n
+ character(len=(n > 5 ? n : 5)) :: str
+ str = ""
+ str(1:5) = "abcde"
+ end
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-std=f2023" }
+implicit none
+integer :: aa(2)
+aa = [1, 2]
+
+print *, (aa(1) > 0 ? aa(2) : g())
+contains
+integer function g()
+ allocatable :: g
+ error stop "should not be called"
+ g = 3
+end
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2023" }
+implicit none
+integer :: i, j
+do concurrent (i=(j > 1 ? 0 : 1) : 5) local(j) ! { dg-error "must not appear in LOCAL locality-spec at" }
+end do
+do concurrent (i=(.true. ? j : 1) : 5) local(j) ! { dg-error "must not appear in LOCAL locality-spec at" }
+end do
+do concurrent (i=(.false. ? 1 : j) : 5) local(j) ! { dg-error "must not appear in LOCAL locality-spec at" }
+end do
+end
projects / thirdparty / gcc.git / commitdiff
