OSDN Git Service

PR fortran/50981
authormikael <mikael@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 4 Jan 2012 14:20:17 +0000 (14:20 +0000)
committermikael <mikael@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 4 Jan 2012 14:20:17 +0000 (14:20 +0000)
* trans-array.h (gfc_walk_elemental_function_args): New argument.
* trans-intrinsic.c (gfc_walk_intrinsic_function): Update call.
* trans-stmt.c (gfc_trans_call): Ditto.
* trans-array.c (gfc_walk_function_expr): Ditto.
(gfc_walk_elemental_function_args): Get the dummy argument list
if possible.  Check that the dummy and the actual argument are both
optional, and set can_be_null_ref accordingly.

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

gcc/fortran/ChangeLog
gcc/fortran/trans-array.c
gcc/fortran/trans-array.h
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-stmt.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/elemental_optional_args_2.f90 [new file with mode: 0644]

index 3f6c5dc..895d200 100644 (file)
@@ -1,6 +1,17 @@
 2012-01-04  Mikael Morin  <mikael@gcc.gnu.org>
 
        PR fortran/50981
+       * trans-array.h (gfc_walk_elemental_function_args): New argument.
+       * trans-intrinsic.c (gfc_walk_intrinsic_function): Update call.
+       * trans-stmt.c (gfc_trans_call): Ditto.
+       * trans-array.c (gfc_walk_function_expr): Ditto.
+       (gfc_walk_elemental_function_args): Get the dummy argument list
+       if possible.  Check that the dummy and the actual argument are both
+       optional, and set can_be_null_ref accordingly.
+
+2012-01-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+       PR fortran/50981
        * trans.h (struct gfc_ss_info): New field data::scalar::can_be_null_ref
        * trans-array.c: If the reference can be NULL, save the reference
        instead of the value.
index a9a060d..494721e 100644 (file)
@@ -8307,12 +8307,16 @@ gfc_reverse_ss (gfc_ss * ss)
 }
 
 
-/* Walk the arguments of an elemental function.  */
+/* Walk the arguments of an elemental function.
+   PROC_EXPR is used to check whether an argument is permitted to be absent.  If
+   it is NULL, we don't do the check and the argument is assumed to be present.
+*/
 
 gfc_ss *
 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
-                                 gfc_ss_type type)
+                                 gfc_expr *proc_expr, gfc_ss_type type)
 {
+  gfc_formal_arglist *dummy_arg;
   int scalar;
   gfc_ss *head;
   gfc_ss *tail;
@@ -8320,6 +8324,28 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
 
   head = gfc_ss_terminator;
   tail = NULL;
+
+  if (proc_expr)
+    {
+      gfc_ref *ref;
+
+      /* Normal procedure case.  */
+      dummy_arg = proc_expr->symtree->n.sym->formal;
+
+      /* Typebound procedure case.  */
+      for (ref = proc_expr->ref; ref; ref = ref->next)
+       {
+         if (ref->type == REF_COMPONENT
+             && ref->u.c.component->attr.proc_pointer
+             && ref->u.c.component->ts.interface)
+           dummy_arg = ref->u.c.component->ts.interface->formal;
+         else
+           dummy_arg = NULL;
+       }
+    }
+  else
+    dummy_arg = NULL;
+
   scalar = 1;
   for (; arg; arg = arg->next)
     {
@@ -8333,6 +8359,13 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
          gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
          newss = gfc_get_scalar_ss (head, arg->expr);
          newss->info->type = type;
+
+         if (dummy_arg != NULL
+             && dummy_arg->sym->attr.optional
+             && arg->expr->symtree
+             && arg->expr->symtree->n.sym->attr.optional
+             && arg->expr->ref == NULL)
+           newss->info->data.scalar.can_be_null_ref = true;
        }
       else
        scalar = 0;
@@ -8344,6 +8377,9 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
           while (tail->next != gfc_ss_terminator)
             tail = tail->next;
         }
+
+      if (dummy_arg != NULL)
+       dummy_arg = dummy_arg->next;
     }
 
   if (scalar)
@@ -8393,7 +8429,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
      by reference.  */
   if (sym->attr.elemental || (comp && comp->attr.elemental))
     return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
-                                            GFC_SS_REFERENCE);
+                                            expr, GFC_SS_REFERENCE);
 
   /* Scalar functions are OK as these are evaluated outside the scalarization
      loop.  Pass back and let the caller deal with it.  */
index 340c1a7..19cfac5 100644 (file)
@@ -73,7 +73,7 @@ gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
 gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
 /* Walk the arguments of an elemental function.  */
 gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
-                                         gfc_ss_type);
+                                         gfc_expr *, gfc_ss_type);
 /* Walk an intrinsic function.  */
 gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
                                     gfc_intrinsic_sym *);
index 2bc628d..0caa59d 100644 (file)
@@ -7149,7 +7149,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
 
   if (isym->elemental)
     return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
-                                            GFC_SS_SCALAR);
+                                            NULL, GFC_SS_SCALAR);
 
   if (expr->rank == 0)
     return ss;
index 9e903d8..92f7f43 100644 (file)
@@ -348,7 +348,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
 
   ss = gfc_ss_terminator;
   if (code->resolved_sym->attr.elemental)
-    ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
+    ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
+                                          code->expr1, GFC_SS_REFERENCE);
 
   /* Is not an elemental subroutine call with array valued arguments.  */
   if (ss == gfc_ss_terminator)
index e6c002f..0982a9f 100644 (file)
@@ -1,3 +1,7 @@
+2012-01-04  Mikael Morin  <mikael@gcc.gnu.org>
+
+       * gfortran.dg/elemental_optional_args_2.f90: New test.
+
 2012-01-04  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/49693
diff --git a/gcc/testsuite/gfortran.dg/elemental_optional_args_2.f90 b/gcc/testsuite/gfortran.dg/elemental_optional_args_2.f90
new file mode 100644 (file)
index 0000000..c09384a
--- /dev/null
@@ -0,0 +1,80 @@
+! { dg-do run }
+!
+! PR fortran/50981
+! The program used to dereference a NULL pointer when trying to access
+! an optional dummy argument to be passed to an elemental subprocedure.
+!
+! Original testcase from Andriy Kostyuk <kostyuk@fias.uni-frankfurt.de>
+
+PROGRAM test
+  IMPLICIT NONE
+  REAL(KIND=8), DIMENSION(2) :: aa, rr
+
+  aa(1)=10.
+  aa(2)=11.
+
+
+  ! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:'
+
+  rr=f1(aa,1)
+  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
+  IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
+
+  rr=0
+  rr=ff(aa,1)
+  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
+  IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
+
+
+  ! WRITE(*,*) 'But only f1 works if the optional parameter is absent:'
+
+  rr=0
+  rr=f1(aa)
+  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
+  IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
+
+  rr = 0
+  rr=ff(aa)
+  ! WRITE(*,*) ' rr(1)=', rr(1), '  rr(2)=', rr(2)
+  IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
+
+
+CONTAINS 
+
+    ELEMENTAL REAL(KIND=8) FUNCTION ff(a,b)
+      IMPLICIT NONE
+      REAL(KIND=8), INTENT(IN) :: a
+      INTEGER, INTENT(IN), OPTIONAL :: b
+      REAL(KIND=8), DIMENSION(2) :: ac
+      ac(1)=a
+      ac(2)=a**2
+      ff=SUM(gg(ac,b))
+    END FUNCTION ff
+
+    ELEMENTAL REAL(KIND=8) FUNCTION f1(a,b)
+      IMPLICIT NONE
+      REAL(KIND=8), INTENT(IN) :: a
+      INTEGER, INTENT(IN), OPTIONAL :: b
+      REAL(KIND=8), DIMENSION(2) :: ac
+      ac(1)=a
+      ac(2)=a**2
+      f1=gg(ac(1),b)+gg(ac(2),b) ! This is the same as in ff, but without using the elemental feature of gg
+    END FUNCTION f1
+
+    ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b)
+      IMPLICIT NONE
+      REAL(KIND=8), INTENT(IN) :: a
+      INTEGER, INTENT(IN), OPTIONAL :: b
+      INTEGER ::b1
+      IF(PRESENT(b)) THEN
+        b1=b
+      ELSE
+        b1=1
+      ENDIF
+      gg=a**b1
+    END FUNCTION gg
+
+
+END PROGRAM test
+
+