re PR fortran/35203 (OPTIONAL, VALUE actual argument cannot be an INTEGER 0)

2013-03-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/35203
        * trans-decl.c (create_function_arglist): Pass hidden argument
        for passed-by-value optional+value dummies.
        * trans-expr.c (gfc_conv_expr_present,
        gfc_conv_procedure_call): Handle those.

2013-03-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/35203
        * gfortran.dg/optional_absent_3.f90: New.

From-SVN: r197252

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f1f176573c430b9f1f74462cadcc307a2d1a401c..ab23bcaecdaad673a329b6c45635daab7726d94d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2013-03-29  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/35203
+       * trans-decl.c (create_function_arglist): Pass hidden argument
+       for passed-by-value optional+value dummies.
+       * trans-expr.c (gfc_conv_expr_present,
+       gfc_conv_procedure_call): Handle those.
+
 2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/45159

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 0e853bac6a12f066fb3789962dc394f52b189ba3..fafde89f37baf923a02b64ca9093d8eccff99d28 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2142,6 +2142,27 @@ create_function_arglist (gfc_symbol * sym)
                type = gfc_sym_type (f->sym);
            }
        }
+      /* For noncharacter scalar intrinsic types, VALUE passes the value,
+        hence, the optional status cannot be transfered via a NULL pointer.
+        Thus, we will use a hidden argument in that case.  */
+      else if (f->sym->attr.optional && f->sym->attr.value
+              && !f->sym->attr.dimension && !f->sym->ts.type != BT_CLASS
+              && f->sym->ts.type != BT_DERIVED)
+       {
+          tree tmp;
+          strcpy (&name[1], f->sym->name);
+          name[0] = '_';
+          tmp = build_decl (input_location,
+                           PARM_DECL, get_identifier (name),
+                           boolean_type_node);
+
+          hidden_arglist = chainon (hidden_arglist, tmp);
+          DECL_CONTEXT (tmp) = fndecl;
+          DECL_ARTIFICIAL (tmp) = 1;
+          DECL_ARG_TYPE (tmp) = boolean_type_node;
+          TREE_READONLY (tmp) = 1;
+          gfc_finish_decl (tmp);
+       }
 
       /* For non-constant length array arguments, make sure they use
         a different type node from TYPE_ARG_TYPES type.  */

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index d0a9446fccea61654915e5147a5714325f5919a1..98a54d9f6885a93925e1c09cc50a05e94c742ec2 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1126,8 +1126,32 @@ gfc_conv_expr_present (gfc_symbol * sym)
   tree decl, cond;
 
   gcc_assert (sym->attr.dummy);
-
   decl = gfc_get_symbol_decl (sym);
+
+  /* Intrinsic scalars with VALUE attribute which are passed by value
+     use a hidden argument to denote the present status.  */
+  if (sym->attr.value && sym->ts.type != BT_CHARACTER
+      && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
+      && !sym->attr.dimension)
+    {
+      char name[GFC_MAX_SYMBOL_LEN + 2];
+      tree tree_name;
+
+      gcc_assert (TREE_CODE (decl) == PARM_DECL);
+      name[0] = '_';
+      strcpy (&name[1], sym->name);
+      tree_name = get_identifier (name);
+
+      /* Walk function argument list to find hidden arg.  */
+      cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
+      for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
+       if (DECL_NAME (cond) == tree_name)
+         break;
+
+      gcc_assert (cond);
+      return cond;
+    }
+
   if (TREE_CODE (decl) != PARM_DECL)
     {
       /* Array parameters use a temporary descriptor, we want the real
@@ -3729,6 +3753,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   tree len;
   tree base_object;
   vec<tree, va_gc> *stringargs;
+  vec<tree, va_gc> *optionalargs;
   tree result = NULL;
   gfc_formal_arglist *formal;
   gfc_actual_arglist *arg;
@@ -3747,6 +3772,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   arglist = NULL;
   retargs = NULL;
   stringargs = NULL;
+  optionalargs = NULL;
   var = NULL_TREE;
   len = NULL_TREE;
   gfc_clear_ts (&ts);
@@ -3835,11 +3861,27 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
            }
          else
            {
-             /* Pass a NULL pointer for an absent arg.  */
              gfc_init_se (&parmse, NULL);
-             parmse.expr = null_pointer_node;
-             if (arg->missing_arg_type == BT_CHARACTER)
-               parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+
+             /* For scalar arguments with VALUE attribute which are passed by
+                value, pass "0" and a hidden argument gives the optional
+                status.  */
+             if (fsym && fsym->attr.optional && fsym->attr.value
+                 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
+                 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
+               {
+                 parmse.expr = fold_convert (gfc_sym_type (fsym),
+                                             integer_zero_node);
+                 vec_safe_push (optionalargs, boolean_false_node);
+               }
+             else
+               {
+                 /* Pass a NULL pointer for an absent arg.  */
+                 parmse.expr = null_pointer_node;
+                 if (arg->missing_arg_type == BT_CHARACTER)
+                   parmse.string_length = build_int_cst (gfc_charlen_type_node,
+                                                         0);
+               }
            }
        }
       else if (arg->expr->expr_type == EXPR_NULL
@@ -4010,7 +4052,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                        gfc_conv_expr (&parmse, e);
                    }
                  else
+                   {
                    gfc_conv_expr (&parmse, e);
+                   if (fsym->attr.optional
+                       && fsym->ts.type != BT_CLASS
+                       && fsym->ts.type != BT_DERIVED)
+                     {
+                       if (e->expr_type != EXPR_VARIABLE
+                           || !e->symtree->n.sym->attr.optional
+                           || e->ref != NULL)
+                         vec_safe_push (optionalargs, boolean_true_node);
+                       else
+                         {
+                           tmp = gfc_conv_expr_present (e->symtree->n.sym);
+                           if (!e->symtree->n.sym->attr.value)
+                             parmse.expr
+                               = fold_build3_loc (input_location, COND_EXPR,
+                                       TREE_TYPE (parmse.expr),
+                                       tmp, parmse.expr,
+                                       fold_convert (TREE_TYPE (parmse.expr),
+                                                     integer_zero_node));
+
+                           vec_safe_push (optionalargs, tmp);
+                         }
+                     }
+                   }
                }
              else if (arg->name && arg->name[0] == '%')
                /* Argument list functions %VAL, %LOC and %REF are signalled
@@ -4844,13 +4910,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   gfc_free_interface_mapping (&mapping);
 
   /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS.  */
-  arglen = (vec_safe_length (arglist) + vec_safe_length (stringargs)
-           + vec_safe_length (append_args));
+  arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
+           + vec_safe_length (stringargs) + vec_safe_length (append_args));
   vec_safe_reserve (retargs, arglen);
 
   /* Add the return arguments.  */
   retargs->splice (arglist);
 
+  /* Add the hidden present status for optional+value to the arguments.  */
+  retargs->splice (optionalargs);
+
   /* Add the hidden string length parameters to the arguments.  */
   retargs->splice (stringargs);
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6a02bbd891a0f5d6889eb6a492d3886e94f1fbc6..776a0318001387ad828eb1dcba4ea78ccbd7aade 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -3,6 +3,11 @@
        * gcc.target/i386/avx2-vbroadcastsi128-1.c: Fix intrinsic name.
        * gcc.target/i386/avx2-vbroadcastsi128-1.c: Ditto.
 
+2013-03-29  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/35203
+       * gfortran.dg/optional_absent_3.f90: New.
+
 2013-03-29  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/56737

diff --git a/gcc/testsuite/gfortran.dg/optional_absent_3.f90 b/gcc/testsuite/gfortran.dg/optional_absent_3.f90
new file mode 100644 (file)
index 0000000..f03b479
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_3.f90
@@ -0,0 +1,83 @@
+! { dg-do run }
+!
+! PR fortran/35203
+!
+! Test VALUE + OPTIONAL
+! for integer/real/complex/logical which are passed by value
+!
+program main
+  implicit none
+  call value_test ()
+contains
+  subroutine value_test (ii, rr, cc, ll, ii2, rr2, cc2, ll2)
+    integer, optional :: ii, ii2
+    real,    optional :: rr, rr2
+    complex, optional :: cc, cc2
+    logical, optional :: ll, ll2
+    value :: ii, rr, cc, ll
+
+    call int_test (.false., 0)
+    call int_test (.false., 0, ii)
+    call int_test (.false., 0, ii2)
+    call int_test (.true., 0, 0)
+    call int_test (.true., 2, 2)
+
+    call real_test (.false., 0.0)
+    call real_test (.false., 0.0, rr)
+    call real_test (.false., 0.0, rr2)
+    call real_test (.true., 0.0, 0.0)
+    call real_test (.true., 2.0, 2.0)
+
+    call cmplx_test (.false., cmplx (0.0))
+    call cmplx_test (.false., cmplx (0.0), cc)
+    call cmplx_test (.false., cmplx (0.0), cc2)
+    call cmplx_test (.true., cmplx (0.0), cmplx (0.0))
+    call cmplx_test (.true., cmplx (2.0), cmplx (2.0))
+
+    call bool_test (.false., .false.)
+    call bool_test (.false., .false., ll)
+    call bool_test (.false., .false., ll2)
+    call bool_test (.true., .false., .false.)
+    call bool_test (.true., .true., .true.)
+  end subroutine value_test
+
+  subroutine int_test (ll, val, x)
+    logical, value :: ll
+    integer, value :: val
+    integer, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x /= val) call abort ()
+    endif
+  end subroutine int_test
+
+  subroutine real_test (ll, val, x)
+    logical, value :: ll
+    real, value :: val
+    real, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x /= val) call abort ()
+    endif
+  end subroutine real_test
+
+  subroutine cmplx_test (ll, val, x)
+    logical, value :: ll
+    complex, value :: val
+    complex, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x /= val) call abort ()
+    endif
+  end subroutine cmplx_test
+
+  subroutine bool_test (ll, val, x)
+    logical, value :: ll
+    logical, value :: val
+    logical, value, optional :: x
+    if (ll .neqv. present(x)) call abort
+    if (present(x)) then
+      if (x .neqv. val) call abort ()
+    endif
+  end subroutine bool_test
+end program main