re PR fortran/28384 (ICE on non-existent COMMON block)

2006-07-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/28384
	* trans-common.c (translate_common): If common_segment is NULL
	emit error that common block does not exist.

	PR fortran/20844
	* io.c (check_io_constraints): It is an error if an ADVANCE
	specifier appears without an explicit format.

	PR fortran/28201
	* resolve.c (resolve_generic_s): For a use_associated function,
	do not search for an alternative symbol in the parent name
	space.

	PR fortran/20893
	* resolve.c (resolve_elemental_actual): New function t combine
	all the checks of elemental procedure actual arguments. In
	addition, check of array valued optional args(this PR) has
	been added.
	(resolve_function, resolve_call): Remove parts that treated
	elemental procedure actual arguments and call the above.

2006-07-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20844
	* gfortran.dg/io_constaints_2.f90: Add the test for ADVANCE
	specifiers requiring an explicit format tag..

	PR fortran/28201
	* gfortran.dg/generic_5: New test.

	PR fortran/20893
	* gfortran.dg/elemental_optional_args_1.f90: New test.

From-SVN: r115499

gcc/fortran/ChangeLog

@@ -1,10 +1,33 @@
+2006-07-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/28384
+	* trans-common.c (translate_common): If common_segment is NULL
+	emit error that common block does not exist.
+
+	PR fortran/20844
+	* io.c (check_io_constraints): It is an error if an ADVANCE
+	specifier appears without an explicit format.
+
+	PR fortran/28201
+	* resolve.c (resolve_generic_s): For a use_associated function,
+	do not search for an alternative symbol in the parent name
+	space.
+
+	PR fortran/20893
+	* resolve.c (resolve_elemental_actual): New function t combine
+	all the checks of elemental procedure actual arguments. In
+	addition, check of array valued optional args(this PR) has
+	been added.
+	(resolve_function, resolve_call): Remove parts that treated
+	elemental procedure actual arguments and call the above.
+
 2006-07-14  Steven G. Kargl  <kargls@comcast.net>
 
 	* trans-expr.c (gfc_trans_string_copy): Evaluate the string lengths
 
 006-07-13  Paul Thomas  <pault@gcc.gnu.org>
 
-	PR fortran/28174
+	PR fortran/28353
 	* trans-expr.c (gfc_conv_aliased_arg): Missing formal arg means
 	that intent is INOUT (fixes regression).
 

gcc/fortran/io.c

@@ -2340,6 +2340,12 @@ if (condition) \
 		     "List directed format(*) is not allowed with a "
 		     "ADVANCE=specifier at %L.", &expr->where);
 
+      io_constraint (dt->format_expr == NULL
+		       && dt->format_label == NULL
+		       && dt->namelist == NULL,
+		     "the ADVANCE=specifier at %L must appear with an "
+		     "explicit format expression", &expr->where);
+
       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
 	{
 	  const char * advance = expr->value.character.string;

gcc/fortran/resolve.c

@@ -910,6 +910,147 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 }
 
 
+/* Do the checks of the actual argument list that are specific to elemental
+   procedures.  If called with c == NULL, we have a function, otherwise if
+   expr == NULL, we have a subroutine.  */
+static try
+resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
+{
+  gfc_actual_arglist *arg0;
+  gfc_actual_arglist *arg;
+  gfc_symbol *esym = NULL;
+  gfc_intrinsic_sym *isym = NULL;
+  gfc_expr *e = NULL;
+  gfc_intrinsic_arg *iformal = NULL;
+  gfc_formal_arglist *eformal = NULL;
+  bool formal_optional = false;
+  bool set_by_optional = false;
+  int i;
+  int rank = 0;
+
+  /* Is this an elemental procedure?  */
+  if (expr && expr->value.function.actual != NULL)
+    {
+      if (expr->value.function.esym != NULL
+	    && expr->value.function.esym->attr.elemental)
+	{
+	  arg0 = expr->value.function.actual;
+	  esym = expr->value.function.esym;
+	}
+      else if (expr->value.function.isym != NULL
+		 && expr->value.function.isym->elemental)
+	{
+	  arg0 = expr->value.function.actual;
+	  isym = expr->value.function.isym;
+	}
+      else
+	return SUCCESS;
+    }
+  else if (c && c->ext.actual != NULL
+	     && c->symtree->n.sym->attr.elemental)
+    {
+      arg0 = c->ext.actual;
+      esym = c->symtree->n.sym;
+    }
+  else
+    return SUCCESS;
+
+  /* The rank of an elemental is the rank of its array argument(s).  */
+  for (arg = arg0; arg; arg = arg->next)
+    {
+      if (arg->expr != NULL && arg->expr->rank > 0)
+	{
+	  rank = arg->expr->rank;
+	  if (arg->expr->expr_type == EXPR_VARIABLE
+		&& arg->expr->symtree->n.sym->attr.optional)
+	    set_by_optional = true;
+
+	  /* Function specific; set the result rank and shape.  */
+	  if (expr)
+	    {
+	      expr->rank = rank;
+	      if (!expr->shape && arg->expr->shape)
+		{
+		  expr->shape = gfc_get_shape (rank);
+		  for (i = 0; i < rank; i++)
+		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
+		}
+	    }
+	  break;
+	}
+    }
+
+  /* If it is an array, it shall not be supplied as an actual argument
+     to an elemental procedure unless an array of the same rank is supplied
+     as an actual argument corresponding to a nonoptional dummy argument of
+     that elemental procedure(12.4.1.5).  */
+  formal_optional = false;
+  if (isym)
+    iformal = isym->formal;
+  else
+    eformal = esym->formal;
+
+  for (arg = arg0; arg; arg = arg->next)
+    {
+      if (eformal)
+	{
+	  if (eformal->sym && eformal->sym->attr.optional)
+	    formal_optional = true;
+	  eformal = eformal->next;
+	}
+      else if (isym && iformal)
+	{
+	  if (iformal->optional)
+	    formal_optional = true;
+	  iformal = iformal->next;
+	}
+      else if (isym)
+	formal_optional = true;
+
+      if (arg->expr != NULL
+	    && arg->expr->expr_type == EXPR_VARIABLE
+	    && arg->expr->symtree->n.sym->attr.optional
+	    && formal_optional
+	    && arg->expr->rank
+	    && (set_by_optional || arg->expr->rank != rank)) 
+	{
+	  gfc_error ("'%s' at %L is an array and OPTIONAL; it cannot "
+		     "therefore be an actual argument of an ELEMENTAL " 
+		     "procedure unless there is a non-optional argument "
+		     "with the same rank (12.4.1.5)",
+		     arg->expr->symtree->n.sym->name, &arg->expr->where);
+	  return FAILURE;
+	}
+    }
+
+  for (arg = arg0; arg; arg = arg->next)
+    {
+      if (arg->expr == NULL || arg->expr->rank == 0)
+	continue;
+
+      /* Being elemental, the last upper bound of an assumed size array
+	 argument must be present.  */
+      if (resolve_assumed_size_actual (arg->expr))
+	return FAILURE;
+
+      if (expr)
+	continue;
+
+      /* Elemental subroutine array actual arguments must conform.  */
+      if (e != NULL)
+	{
+	  if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
+		== FAILURE)
+	    return FAILURE;
+	}
+      else
+	e = arg->expr;
+    }
+
+  return SUCCESS;
+}
+
+
 /* Go through each actual argument in ACTUAL and see if it can be
    implemented as an inlined, non-copying intrinsic.  FNSYM is the
    function being called, or NULL if not known.  */
@@ -1237,7 +1378,6 @@ resolve_function (gfc_expr * expr)
   const char *name;
   try t;
   int temp;
-  int i;
 
   sym = NULL;
   if (expr->symtree)
@@ -1313,38 +1453,9 @@ resolve_function (gfc_expr * expr)
   temp = need_full_assumed_size;
   need_full_assumed_size = 0;
 
-  if (expr->value.function.actual != NULL
+  if (resolve_elemental_actual (expr, NULL) == FAILURE)
-      && ((expr->value.function.esym != NULL
+    return FAILURE;
-	   && expr->value.function.esym->attr.elemental)
-	  || (expr->value.function.isym != NULL
-	      && expr->value.function.isym->elemental)))
-    {
-      /* The rank of an elemental is the rank of its array argument(s).  */
-      for (arg = expr->value.function.actual; arg; arg = arg->next)
-	{
-	  if (arg->expr != NULL && arg->expr->rank > 0)
-	    {
-	      expr->rank = arg->expr->rank;
-	      if (!expr->shape && arg->expr->shape)
-		{
-		  expr->shape = gfc_get_shape (expr->rank);
-		  for (i = 0; i < expr->rank; i++)
-		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
-	        }
-	      break;
-	    }
-	}
 
-      /* Being elemental, the last upper bound of an assumed size array
-	 argument must be present.  */
-      for (arg = expr->value.function.actual; arg; arg = arg->next)
-	{
-	  if (arg->expr != NULL
-		&& arg->expr->rank > 0
-		&& resolve_assumed_size_actual (arg->expr))
-	    return FAILURE;
-	}
-    }
   if (omp_workshare_flag
       && expr->value.function.esym
       && ! gfc_elemental (expr->value.function.esym))
@@ -1500,7 +1611,7 @@ resolve_generic_s (gfc_code * c)
   if (m == MATCH_ERROR)
     return FAILURE;
 
-  if (sym->ns->parent != NULL)
+  if (sym->ns->parent != NULL && !sym->attr.use_assoc)
     {
       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
       if (sym != NULL)
@@ -1730,35 +1841,9 @@ resolve_call (gfc_code * c)
 	gfc_internal_error ("resolve_subroutine(): bad function type");
       }
 
-  /* Some checks of elemental subroutines.  */
+  /* Some checks of elemental subroutine actual arguments.  */
-  if (c->ext.actual != NULL
+  if (resolve_elemental_actual (NULL, c) == FAILURE)
-      && c->symtree->n.sym->attr.elemental)
+    return FAILURE;
-    {
-      gfc_actual_arglist * a;
-      gfc_expr * e;
-      e = NULL;
-
-      for (a = c->ext.actual; a; a = a->next)
-	{
-	  if (a->expr == NULL || a->expr->rank == 0)
-	    continue;
-
-	 /* The last upper bound of an assumed size array argument must
-	    be present.  */
-	  if (resolve_assumed_size_actual (a->expr))
-	    return FAILURE;
-
-	  /* Array actual arguments must conform.  */
-	  if (e != NULL)
-	    {
-	      if (gfc_check_conformance ("elemental subroutine", a->expr, e)
-			== FAILURE)
-		return FAILURE;
-	    }
-	  else
-	    e = a->expr;
-	}
-    }
 
   if (t == SUCCESS)
     find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);

gcc/fortran/trans-common.c

@@ -962,6 +962,13 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list)
       current_offset += s->length;
     }
 
+  if (common_segment == NULL)
+    {
+      gfc_error ("COMMON '%s' at %L does not exist",
+		 common->name, &common->where);
+      return;
+    }
+
   if (common_segment->offset != 0)
     {
       gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",

gcc/testsuite/ChangeLog

@@ -1,3 +1,15 @@
+2006-07-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/20844
+	* gfortran.dg/io_constaints_2.f90: Add the test for ADVANCE
+	specifiers requiring an explicit format tag..
+
+	PR fortran/28201
+	* gfortran.dg/generic_5: New test.
+
+	PR fortran/20893
+	* gfortran.dg/elemental_optional_args_1.f90: New test.
+
 2006-07-16  Olivier Hainque  <hainque@adacore.com>
 
 	* gnat.dg/assert.ads: New file.

gcc/testsuite/gfortran.dg/elemental_optional_args_1.f90

@@ -0,0 +1,52 @@
+! { dg-do compile }
+! Check the fix for PR20893, in which actual arguments could violate: 
+! "(5) If it is an array, it shall not be supplied as an actual argument to
+! an elemental procedure unless an array of the same rank is supplied as an
+! actual argument corresponding to a nonoptional dummy argument of that 
+! elemental procedure." (12.4.1.5)
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+  CALL T1(1,2)
+CONTAINS
+  SUBROUTINE T1(A1,A2,A3)
+    INTEGER           :: A1,A2, A4(2)
+    INTEGER, OPTIONAL :: A3(2)
+    interface
+      elemental function efoo (B1,B2,B3) result(bar)
+        INTEGER, intent(in)           :: B1, B2
+        integer           :: bar
+        INTEGER, OPTIONAL, intent(in) :: B3
+      end function efoo
+    end interface
+
+! check an intrinsic function
+    write(6,*) MAX(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
+    write(6,*) MAX(A1,A3,A2)
+    write(6,*) MAX(A1,A4,A3)
+! check an internal elemental function
+    write(6,*) foo(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
+    write(6,*) foo(A1,A3,A2)
+    write(6,*) foo(A1,A4,A3)
+! check an external elemental function
+    write(6,*) efoo(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
+    write(6,*) efoo(A1,A3,A2)
+    write(6,*) efoo(A1,A4,A3)
+! check an elemental subroutine
+    call foobar (A1,A2,A3) ! { dg-error "array and OPTIONAL" } 
+    call foobar (A1,A2,A4)
+    call foobar (A1,A4,A4)
+  END SUBROUTINE
+  elemental function foo (B1,B2,B3) result(bar)
+    INTEGER, intent(in)           :: B1, B2
+    integer           :: bar
+    INTEGER, OPTIONAL, intent(in) :: B3
+    bar = 1
+  end function foo
+  elemental subroutine foobar (B1,B2,B3)
+    INTEGER, intent(OUT)           :: B1
+    INTEGER, optional, intent(in)  :: B2, B3
+    B1 = 1
+  end subroutine foobar
+
+END

gcc/testsuite/gfortran.dg/generic_5.f90

@@ -0,0 +1,29 @@
+! { dg-do compile }
+! Tests the patch for PR28201, in which the call to ice would cause an ICE
+! because resolve.c(resolve_generic_s) would try to look in the parent
+! namespace to see if the subroutine was part of a legal generic interface.
+! In this case, there is nothing to test, hence the ICE.
+!
+! Contributed by Daniel Franke  <franke.daniel@gmail.com>
+!
+!
+MODULE ice_gfortran
+  INTERFACE ice
+    MODULE PROCEDURE ice_i
+  END INTERFACE
+
+CONTAINS
+  SUBROUTINE ice_i(i)
+    INTEGER, INTENT(IN) :: i
+    ! do nothing
+  END SUBROUTINE
+END MODULE
+
+MODULE provoke_ice
+CONTAINS
+  SUBROUTINE provoke
+    USE ice_gfortran
+    CALL ice(23.0)   ! { dg-error "is not an intrinsic subroutine" }
+  END SUBROUTINE
+END MODULE
+

gcc/testsuite/gfortran.dg/io_constraints_2.f90

@@ -1,6 +1,7 @@
 ! { dg-do compile }
 ! Part II of the test  of the IO constraints patch, which fixes PRs:
 ! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862.
+! Modified2006-07-08 to check the patch for PR20844.
 !
 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
 !
@@ -52,6 +53,8 @@ end module global
  READ(buffer, fmt='(i6)', advance='YES') a      ! { dg-error "internal file" }
  READ(1, NML=NL, advance='YES')                 ! { dg-error "NAMELIST IO is not allowed" }
 
+ READ(1, advance='YES')                         ! { dg-error "must appear with an explicit format" }
+
  write(1, fmt='(i6)', advance='YES', size = c(1)) a ! { dg-error "output" }
  write(1, fmt='(i6)', advance='YES', eor = 100) a   ! { dg-error "output" }