fortran: allow character in conditional expression

This patch allows the use of character types in conditional expressions.

gcc/fortran/ChangeLog:

	* resolve.cc (resolve_conditional): Allow character in cond-expr.
	* trans-const.cc (gfc_conv_constant): Handle want_pointer.
	* trans-expr.cc (gfc_conv_conditional_expr): Fill se->string_length.
	(gfc_conv_string_parameter): Handle COND_EXPR tree code.

gcc/testsuite/ChangeLog:

	* gfortran.dg/conditional_1.f90: Test character type.
	* gfortran.dg/conditional_2.f90: Test print constants.
	* gfortran.dg/conditional_4.f90: Test diagnostic message.
	* gfortran.dg/conditional_6.f90: Test character cond-arg.

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f419f5c7559f0d2facab8e7a329cf6745e5be096..1c49ccf47111e4f82b9e734a06f5e8e4eeb8f341 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5060,14 +5060,17 @@ resolve_conditional (gfc_expr *expr)
 
   /* 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)
+      && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX
+      && true_expr->ts.type != BT_CHARACTER)
     {
-      gfc_error ("Sorry, only integer, logical, real and complex types "
-                "are currently supported for conditional expressions at %L",
-                &expr->where);
+      gfc_error (
+       "Sorry, only integer, logical, real, complex and character types are "
+       "currently supported for conditional expressions at %L",
+       &expr->where);
       return false;
     }
 
+  /* TODO: support arrays in conditional expressions  */
   if (true_expr->rank > 0)
     {
       gfc_error ("Sorry, array is currently unsupported for conditional "

diff --git a/gcc/fortran/trans-const.cc b/gcc/fortran/trans-const.cc
index ea1501a4d540b5ebe96625bcfa49b52b300cc9da..f70f36284a383eeab0ff61ea00bd2d110b6dcaa6 100644 (file)
--- a/gcc/fortran/trans-const.cc
+++ b/gcc/fortran/trans-const.cc
@@ -438,4 +438,12 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr)
      structure, too.  */
   if (expr->ts.type == BT_CHARACTER)
     se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
+
+  if (se->want_pointer)
+    {
+      if (expr->ts.type == BT_CHARACTER)
+       gfc_conv_string_parameter (se);
+      else
+       se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+    }
 }

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 271d2633dfba9e130d02ec2b82d6afcdeab54035..21f256b280f4088b47b3585466606ea028d9a0cc 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4418,6 +4418,11 @@ gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
 
   se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
                              true_val, false_val);
+  if (expr->ts.type == BT_CHARACTER)
+    se->string_length
+      = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
+                        condition, true_se.string_length,
+                        false_se.string_length);
 }
 
 /* If a string's length is one, we convert it to a single character.  */
@@ -11546,6 +11551,29 @@ gfc_conv_string_parameter (gfc_se * se)
       return;
     }
 
+  if (TREE_CODE (se->expr) == COND_EXPR)
+    {
+      tree cond = TREE_OPERAND (se->expr, 0);
+      tree lhs = TREE_OPERAND (se->expr, 1);
+      tree rhs = TREE_OPERAND (se->expr, 2);
+
+      gfc_se lse, rse;
+      gfc_init_se (&lse, NULL);
+      gfc_init_se (&rse, NULL);
+
+      lse.expr = lhs;
+      lse.string_length = se->string_length;
+      gfc_conv_string_parameter (&lse);
+
+      rse.expr = rhs;
+      rse.string_length = se->string_length;
+      gfc_conv_string_parameter (&rse);
+
+      se->expr
+       = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
+                          cond, lse.expr, rse.expr);
+    }
+
   if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
        || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
       && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))

diff --git a/gcc/testsuite/gfortran.dg/conditional_1.f90 b/gcc/testsuite/gfortran.dg/conditional_1.f90
index ca7d21db1a7da90a0fca8739611e0bfe2ff9b974..9fd442a73cc6ea3949390aed4dd5ee3afafc5bc1 100644 (file)
--- a/gcc/testsuite/gfortran.dg/conditional_1.f90
+++ b/gcc/testsuite/gfortran.dg/conditional_1.f90
@@ -6,6 +6,8 @@ program conditional_simple
   logical :: l = .true.
   real(4) :: r1 = 1.e-4, r2 = 1.e-5
   complex :: z = (3.0, 4.0)
+  character(kind=1, len=5) :: c1 = "hello", c2 = "world"
+  character(len=:), allocatable :: c3
 
   i = (i > 0 ? 1 : -1)
   if (i /= 1) stop 1
@@ -29,4 +31,16 @@ program conditional_simple
   i = 0
   z = (i /= 0 ? z : (-3.0, -4.0))
   if (z /= (-3.0, -4.0)) stop 6
+
+  i = 0
+  c1 = (i /= 0 ? c1 : c2)
+  if (c1 /= "world") stop 7
+
+  i = 0
+  c1 = (i /= 0 ? "abcde" : "bcdef")
+  if (c1 /= "bcdef") stop 8
+
+  i = 0
+  c3 = (i /= 0 ? "abcde" : c2(1:3))
+  if (c3 /= "wor") stop 9
 end program conditional_simple

diff --git a/gcc/testsuite/gfortran.dg/conditional_2.f90 b/gcc/testsuite/gfortran.dg/conditional_2.f90
index e78cd084154345cd0fd6a9f9ff4d409b733a235d..c45b06521436b034f6d9a95e32aa5e99c1d3e0ce 100644 (file)
--- a/gcc/testsuite/gfortran.dg/conditional_2.f90
+++ b/gcc/testsuite/gfortran.dg/conditional_2.f90
@@ -4,6 +4,8 @@ program conditional_constant
   implicit none
   integer :: i = 42
 
+  print *, (.true. ? 1 : -1)
+  print *, (.false. ? "hello" : "world")
   i = (.true. ? 1 : -1)
   if (i /= 1) stop 1
 

diff --git a/gcc/testsuite/gfortran.dg/conditional_4.f90 b/gcc/testsuite/gfortran.dg/conditional_4.f90
index 38033b9ec1dee89ee597e488448fa84568198973..5ecf9e0633aa9639651a1cfa27e1e2a0f79469c9 100644 (file)
--- a/gcc/testsuite/gfortran.dg/conditional_4.f90
+++ b/gcc/testsuite/gfortran.dg/conditional_4.f90
@@ -10,12 +10,16 @@ program conditional_resolve
   integer, dimension(1, 1) :: a_2d
   logical :: l1(2)
   integer :: i1(2)
+  type :: Point
+    real :: x = 0.0
+  end type Point
+  type(Point) :: p1, p2
 
   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" }
+  p1 = (i /= 0 ? p1 : p2) ! { dg-error "Sorry, only integer, logical, real, complex and character 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

diff --git a/gcc/testsuite/gfortran.dg/conditional_6.f90 b/gcc/testsuite/gfortran.dg/conditional_6.f90
index c9ac7132c45f80346b34c87c5d499c6c8940b962..931f11c645973e2c403650fb528b0d3ddea40bcf 100644 (file)
--- a/gcc/testsuite/gfortran.dg/conditional_6.f90
+++ b/gcc/testsuite/gfortran.dg/conditional_6.f90
@@ -4,8 +4,19 @@ program conditional_arg
   implicit none
   integer :: a = 4
   integer :: b = 5
+  character(kind=1, len=4) :: c4 = "abcd"
+  character(kind=1, len=5) :: c5 = "bcdef"
+
   call five((a < 5 ? a : b))
   if (a /= 5) stop 1
+
+  if (my_trim_len((b == 5 ? c4 : c5)) /= 4) stop 2
+  if (my_trim_len((b == 5 ? "abcd" : "abcde")) /= 4) stop 3
+  if (my_trim_len((b /= 5 ? c4 : c5)) /= 5) stop 4
+  if (my_trim_len((b /= 5 ? "abcd" : "abcde")) /= 5) stop 5
+
+  call five_c((b == 5 ? c4 : c5))
+  if (c4 /= "bcde") stop 6
 contains
   subroutine five(x)
     integer, optional :: x
@@ -13,4 +24,16 @@ contains
       x = 5
     end if
   end subroutine five
+
+  integer function my_trim_len(s)
+    character(len=*), intent(in) :: s
+    my_trim_len = len_trim(s)
+  end function my_trim_len
+
+  subroutine five_c(x)
+    character(len=*), optional :: x
+    if (present(x)) then
+      x = c5
+    end if
+  end subroutine five_c
 end program conditional_arg