PR fortran/31198

	* trans-intrinsic.c (trans-intrinsic.c): Handle optional
	arguments correctly for MIN and MAX intrinsics.

	* gfortran.dg/min_max_optional_1.f90: New test.
	* gfortran.dg/min_max_optional_2.f90: New test.
	* gfortran.dg/min_max_optional_3.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126307 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c128097..77ec511 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2007-07-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+       PR fortran/31198
+       * trans-intrinsic.c (trans-intrinsic.c): Handle optional
+       arguments correctly for MIN and MAX intrinsics.
+
 2007-07-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/32545

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 874b108..8856f19 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1381,12 +1381,51 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
   tree val;
   tree thencase;
   tree elsecase;
-  tree arg;
+  tree arg, arg1, arg2;
   tree type;
+  gfc_actual_arglist *argexpr;
+  unsigned int i;
 
   arg = gfc_conv_intrinsic_function_args (se, expr);
+  arg1 = TREE_VALUE (arg);
+  arg2 = TREE_VALUE (TREE_CHAIN (arg));
   type = gfc_typenode_for_spec (&expr->ts);
 
+  /* The first and second arguments should be present, if they are
+     optional dummy arguments.  */
+  argexpr = expr->value.function.actual;
+  if (argexpr->expr->expr_type == EXPR_VARIABLE
+      && argexpr->expr->symtree->n.sym->attr.optional
+      && TREE_CODE (arg1) == INDIRECT_REF)
+    {
+      /* Check the first argument.  */
+      tree cond;
+      char *msg;
+
+      asprintf (&msg, "First argument of '%s' intrinsic should be present",
+               expr->symtree->n.sym->name);
+      cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (arg1, 0),
+                    build_int_cst (TREE_TYPE (TREE_OPERAND (arg1, 0)), 0));
+      gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
+      gfc_free (msg);
+    }
+
+  if (argexpr->next->expr->expr_type == EXPR_VARIABLE
+      && argexpr->next->expr->symtree->n.sym->attr.optional
+      && TREE_CODE (arg2) == INDIRECT_REF)
+    {
+      /* Check the second argument.  */
+      tree cond;
+      char *msg;
+
+      asprintf (&msg, "Second argument of '%s' intrinsic should be present",
+               expr->symtree->n.sym->name);
+      cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (arg2, 0),
+                    build_int_cst (TREE_TYPE (TREE_OPERAND (arg2, 0)), 0));
+      gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
+      gfc_free (msg);
+    }
+
   limit = TREE_VALUE (arg);
   if (TREE_TYPE (limit) != type)
     limit = convert (type, limit);
@@ -1396,23 +1435,40 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 
   mvar = gfc_create_var (type, "M");
   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
-  for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
+  for (arg = TREE_CHAIN (arg), i = 0, argexpr = argexpr->next;
+       arg != NULL_TREE; arg = TREE_CHAIN (arg), i++)
     {
+      tree cond;
+
       val = TREE_VALUE (arg);
-      if (TREE_TYPE (val) != type)
-       val = convert (type, val);
 
-      /* Only evaluate the argument once.  */
-      if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
-        val = gfc_evaluate_now (val, &se->pre);
+      /* Handle absent optional arguments by ignoring the comparison.  */
+      if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE
+         && argexpr->expr->symtree->n.sym->attr.optional
+         && TREE_CODE (val) == INDIRECT_REF)
+       cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
+                      build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+      else
+      {
+       cond = NULL_TREE;
+
+       /* Only evaluate the argument once.  */
+       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
+         val = gfc_evaluate_now (val, &se->pre);
+      }
 
       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
 
-      tmp = build2 (op, boolean_type_node, val, limit);
+      tmp = build2 (op, boolean_type_node, convert (type, val), limit);
       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+
+      if (cond != NULL_TREE)
+       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+
       gfc_add_expr_to_block (&se->pre, tmp);
       elsecase = build_empty_stmt ();
       limit = mvar;
+      argexpr = argexpr->next;
     }
   se->expr = mvar;
 }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 77dc469..71c389a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2007-07-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+       PR fortran/31198
+       * gfortran.dg/min_max_optional_1.f90: New test.
+       * gfortran.dg/min_max_optional_2.f90: New test.
+       * gfortran.dg/min_max_optional_3.f90: New test.
+
 2007-07-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/32545
@@ -16,7 +23,7 @@
 2007-07-03  Christopher D. Rickett  <crickett@lanl.gov>
 
        PR fortran/32579
-        * gfortran.dg/iso_c_binding_only.f03: Updated test case.
+       * gfortran.dg/iso_c_binding_only.f03: Updated test case.
 
 2007-07-03  Tobias Burnus  <burnus@net-b.de>
 

diff --git a/gcc/testsuite/gfortran.dg/min_max_optional_1.f90 b/gcc/testsuite/gfortran.dg/min_max_optional_1.f90
new file mode 100644 (file)
index 0000000..250010d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/min_max_optional_1.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+IF (T1(1.0,1.0) .NE. (1.0,1.0) ) CALL ABORT()
+IF (T1(1.0) .NE. (1.0,0.0)) CALL ABORT()
+IF (M1(1,2,3) .NE. 3) CALL ABORT()
+IF (M1(1,2,A4=4) .NE. 4) CALL ABORT()
+CONTAINS
+
+COMPLEX FUNCTION T1(X,Y)
+  REAL :: X
+  REAL, OPTIONAL :: Y
+  T1=CMPLX(X,Y)
+END FUNCTION T1
+
+INTEGER FUNCTION M1(A1,A2,A3,A4)
+  INTEGER :: A1,A2
+  INTEGER, OPTIONAL :: A3,A4
+  M1=MAX(A1,A2,A3,A4)
+END FUNCTION M1
+
+END

diff --git a/gcc/testsuite/gfortran.dg/min_max_optional_2.f90 b/gcc/testsuite/gfortran.dg/min_max_optional_2.f90
new file mode 100644 (file)
index 0000000..51e0fee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/min_max_optional_2.f90
@@ -0,0 +1,13 @@
+! { dg-do run }
+! { dg-shouldfail "" }
+  program test 
+    if (m1(3,4) /= 4) call abort
+    if (m1(3) /= 3) call abort
+    print *, m1() 
+  contains 
+    integer function m1(a1,a2) 
+      integer, optional :: a1,a2 
+      m1 = max(a2, a1, 1, 2) 
+    end function m1 
+  end 
+! { dg-output "First argument of 'max' intrinsic should be present" }

diff --git a/gcc/testsuite/gfortran.dg/min_max_optional_3.f90 b/gcc/testsuite/gfortran.dg/min_max_optional_3.f90
new file mode 100644 (file)
index 0000000..e0e6e29
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/min_max_optional_3.f90
@@ -0,0 +1,14 @@
+! { dg-do run }
+! { dg-shouldfail "" }
+  program test 
+    if (m1(1,2,3,4) /= 1) call abort
+    if (m1(1,2,3) /= 1) call abort
+    if (m1(1,2) /= 1) call abort
+    print *, m1(1) 
+    print *, m1() 
+  contains 
+    integer function m1(a1,a2,a3,a4) 
+      integer, optional :: a1,a2,a3,a4 
+      m1 = min(a1,a2,a3,a4) ! { dg-output "Second argument of 'min' intrinsic should be present" }
+    end function m1 
+  end