Bug fixes from trunk

2007-01-06  Paul Thomas  <pault@gcc.gnu.org>

	Bug fixes from trunk

	PR fortran/30034
	* resolve.c (resolve_formal_arglist): Exclude the test for
	pointers and procedures for subroutine arguments as well as
	functions.

	PR fortran/30237
	* intrinsic.c (remove_nullargs): Do not pass up arguments with
	a label. If the actual has a label and the formal has a type
	then emit an error.

	PR fortran/25135
	* module.c (load_generic_interfaces): If the symbol is present
	and is not generic it is ambiguous.

	PR fortran/23060
	* intrinsic.c (compare_actual_formal ): Distinguish argument
	list functions from keywords.
	* intrinsic.c (sort_actual): If formal is NULL, the presence of
	an argument list function actual is an error.
	* trans-expr.c (conv_arglist_function) : New function to
	implement argument list functions %VAL, %REF and %LOC.
	(gfc_conv_function_call): Call it.
	* resolve.c (resolve_actual_arglist): Add arg ptype and check
	argument list functions.
	(resolve_function, resolve_call): Set value of ptype before
	calls to resolve_actual_arglist.
	* primary.c (match_arg_list_function): New function.
	(gfc_match_actual_arglist): Call it before trying for a
	keyword argument.

	PR fortran/27900
	* resolve.c (resolve_actual_arglist): If all else fails and a
	procedure actual argument has no type, see if a specific
	intrinsic matches.

	PR fortran/24325
	* resolve.c (resolve_function): If the function reference is
	FL_VARIABLE this is an error.

2007-01-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30034
	* gfortran.dg/pure_formal_proc_1.f90: New test.

	PR fortran/30237
	* gfortran.dg/intrinsic_actual_3.f90: New test.

	PR fortran/25135
	* gfortran.dg/generic_11.f90: New test.
	* gfortran.dg/interface_7.f90: Remove name clash between module
	name and procedure 'x' referenced in the interface.

	PR fortran/23060
	* gfortran.dg/c_by_val.c: Called by c_by_val_1.f.
	* gfortran.dg/c_by_val_1.f: New test.
	* gfortran.dg/c_by_val_2.f: New test.
	* gfortran.dg/c_by_val_3.f: New test.

	PR fortran/27900
	* gfortran.dg/intrinsic_actual_4.f90: New test.

	PR fortran/24325
	* gfortran.dg/func_decl_3.f90: New test.

From-SVN: r120525

gcc/fortran/ChangeLog

@@ -1,3 +1,44 @@
+2007-01-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30034
+	* resolve.c (resolve_formal_arglist): Exclude the test for
+	pointers and procedures for subroutine arguments as well as
+	functions.
+
+	PR fortran/30237
+	* intrinsic.c (remove_nullargs): Do not pass up arguments with
+	a label. If the actual has a label and the formal has a type
+	then emit an error.
+
+	PR fortran/25135
+	* module.c (load_generic_interfaces): If the symbol is present
+	and is not generic it is ambiguous.
+
+	PR fortran/23060
+	* intrinsic.c (compare_actual_formal ): Distinguish argument
+	list functions from keywords.
+	* intrinsic.c (sort_actual): If formal is NULL, the presence of
+	an argument list function actual is an error.
+	* trans-expr.c (conv_arglist_function) : New function to
+	implement argument list functions %VAL, %REF and %LOC.
+	(gfc_conv_function_call): Call it.
+	* resolve.c (resolve_actual_arglist): Add arg ptype and check
+	argument list functions.
+	(resolve_function, resolve_call): Set value of ptype before
+	calls to resolve_actual_arglist.
+	* primary.c (match_arg_list_function): New function.
+	(gfc_match_actual_arglist): Call it before trying for a
+	keyword argument.
+
+	PR fortran/27900
+	* resolve.c (resolve_actual_arglist): If all else fails and a
+	procedure actual argument has no type, see if a specific
+	intrinsic matches.
+
+	PR fortran/24325
+	* resolve.c (resolve_function): If the function reference is
+	FL_VARIABLE this is an error.
+
 2007-01-03  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/25818

gcc/fortran/interface.c

@@ -1232,7 +1232,6 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 {
   gfc_actual_arglist **new, *a, *actual, temp;
   gfc_formal_arglist *f;
-  gfc_gsymbol *gsym;
   int i, n, na;
   bool rank_check;
 
@@ -1256,7 +1255,8 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 
   for (a = actual; a; a = a->next, f = f->next)
     {
-      if (a->name != NULL)
+      /* Look for keywords but ignore g77 extensions like %VAL.  */
+      if (a->name != NULL && a->name[0] != '%')
 	{
 	  i = 0;
 	  for (f = formal; f; f = f->next, i++)
@@ -1338,16 +1338,10 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && f->sym->attr.flavor == FL_PROCEDURE)
 	{
-	  gsym = gfc_find_gsymbol (gfc_gsym_root,
-				   a->expr->symtree->n.sym->name);
-	  if (gsym == NULL || (gsym->type != GSYM_FUNCTION
-		&& gsym->type != GSYM_SUBROUTINE))
-	    {
-	      if (where)
-		gfc_error ("Expected a procedure for argument '%s' at %L",
-			   f->sym->name, &a->expr->where);
-	      return 0;
-	    }
+	  if (where)
+	    gfc_error ("Expected a procedure for argument '%s' at %L",
+			f->sym->name, &a->expr->where);
+	    return 0;
 	}
 
       if (f->sym->attr.flavor == FL_PROCEDURE

gcc/fortran/intrinsic.c

@@ -2782,7 +2782,7 @@ remove_nullargs (gfc_actual_arglist ** ap)
     {
       next = head->next;
 
-      if (head->expr == NULL)
+      if (head->expr == NULL && !head->label)
 	{
 	  head->next = NULL;
 	  gfc_free_actual_arglist (head);
@@ -2864,7 +2864,11 @@ keywords:
 
       if (f == NULL)
 	{
-	  gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
+	  if (a->name[0] == '%')
+	    gfc_error ("Argument list function at %L is not allowed in this "
+		       "context", where);
+	  else
+	    gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
 		     a->name, name, where);
 	  return FAILURE;
 	}
@@ -2898,6 +2902,12 @@ do_sort:
 
   for (f = formal; f; f = f->next)
     {
+      if (f->actual && f->actual->label != NULL && f->ts.type)
+	{
+	  gfc_error ("ALTERNATE RETURN not permitted at %L", where);
+	  return FAILURE;
+	}
+
       if (f->actual == NULL)
 	{
 	  a = gfc_get_actual_arglist ();

gcc/fortran/module.c

@@ -3016,6 +3016,16 @@ load_generic_interfaces (void)
 	      sym->attr.generic = 1;
 	      sym->attr.use_assoc = 1;
 	    }
+	  else
+	    {
+	      /* Unless sym is a generic interface, this reference
+		 is ambiguous.  */
+	      gfc_symtree *st;
+	      p = p ? p : name;
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+	      st->ambiguous = sym->attr.generic ? 0 : 1;
+	    }
+
 	  if (i == 1)
 	    {
 	      mio_interface_rest (&sym->generic);

gcc/fortran/primary.c

@@ -1429,6 +1429,80 @@ cleanup:
 }
 
 
+/* Match an argument list function, such as %VAL.  */
+
+static match
+match_arg_list_function (gfc_actual_arglist *result)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  locus old_locus;
+  match m;
+
+  old_locus = gfc_current_locus;
+
+  if (gfc_match_char ('%') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  m = gfc_match ("%n (", name);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (name[0] != '\0')
+    {
+      switch (name[0])
+	{
+	case 'l':
+	  if (strncmp(name, "loc", 3) == 0)
+	    {
+	      result->name = "%LOC";
+	      break;
+	    }
+	case 'r':
+	  if (strncmp(name, "ref", 3) == 0)
+	    {
+	      result->name = "%REF";
+	      break;
+	    }
+	case 'v':
+	  if (strncmp(name, "val", 3) == 0)
+	    {
+	      result->name = "%VAL";
+	      break;
+	    }
+	default:
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+    }
+
+  if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
+		      "function at %C") == FAILURE)
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  m = match_actual_arg (&result->expr);
+  if (m != MATCH_YES)
+    goto cleanup;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      m = MATCH_NO;
+      goto cleanup;
+    }
+
+  return MATCH_YES;
+
+cleanup:
+  gfc_current_locus = old_locus;
+  return m;
+}
+
+
 /* Matches an actual argument list of a function or subroutine, from
    the opening parenthesis to the closing parenthesis.  The argument
    list is assumed to allow keyword arguments because we don't know if
@@ -1497,13 +1571,21 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
 	}
       else
 	{
-	  /* See if we have the first keyword argument.  */
-	  m = match_keyword_arg (tail, head);
-	  if (m == MATCH_YES)
-	    seen_keyword = 1;
+	  /* Try an argument list function, like %VAL.  */
+	  m = match_arg_list_function (tail);
 	  if (m == MATCH_ERROR)
 	    goto cleanup;
 
+	  /* See if we have the first keyword argument.  */
+	  if (m == MATCH_NO)
+	    {
+	      m = match_keyword_arg (tail, head);
+	      if (m == MATCH_YES)
+		seen_keyword = 1;
+	      if (m == MATCH_ERROR)
+		goto cleanup;
+	    }
+
 	  if (m == MATCH_NO)
 	    {
 	      /* Try for a non-keyword argument.  */
@@ -1515,6 +1597,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
 	    }
 	}
 
+
     next:
       if (gfc_match_char (')') == MATCH_YES)
 	break;

gcc/fortran/resolve.c

@@ -140,6 +140,21 @@ resolve_formal_arglist (gfc_symbol * proc)
 	      continue;
 	    }
 
+	  if (sym->attr.function
+		&& sym->ts.type == BT_UNKNOWN
+		&& sym->attr.intrinsic)
+	    {
+	      gfc_intrinsic_sym *isym;
+	      isym = gfc_find_function (sym->name);
+	      if (isym == NULL || !isym->specific)
+		{
+		  gfc_error ("Unable to find a specific INTRINSIC procedure "
+			     "for the reference '%s' at %L", sym->name,
+			     &sym->declared_at);
+		}
+	      sym->ts = isym->ts;
+	    }
+
 	  continue;
 	}
 
@@ -173,26 +188,20 @@ resolve_formal_arglist (gfc_symbol * proc)
       if (sym->attr.flavor == FL_UNKNOWN)
 	gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
 
-      if (gfc_pure (proc))
+      if (gfc_pure (proc) && !sym->attr.pointer
+            && sym->attr.flavor != FL_PROCEDURE)
 	{
-	  if (proc->attr.function && !sym->attr.pointer
-              && sym->attr.flavor != FL_PROCEDURE
-	      && sym->attr.intent != INTENT_IN)
-
+	  if (proc->attr.function && sym->attr.intent != INTENT_IN)
 	    gfc_error ("Argument '%s' of pure function '%s' at %L must be "
 		       "INTENT(IN)", sym->name, proc->name,
 		       &sym->declared_at);
 
-	  if (proc->attr.subroutine && !sym->attr.pointer
-	      && sym->attr.intent == INTENT_UNKNOWN)
-
-	    gfc_error
-	      ("Argument '%s' of pure subroutine '%s' at %L must have "
-	       "its INTENT specified", sym->name, proc->name,
-	       &sym->declared_at);
+	  if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+	    gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
+		       "have its INTENT specified", sym->name, proc->name,
+		       &sym->declared_at);
 	}
 
-
       if (gfc_elemental (proc))
 	{
 	  if (sym->as != NULL)
@@ -850,7 +859,7 @@ resolve_assumed_size_actual (gfc_expr *e)
    references.  */
 
 static try
-resolve_actual_arglist (gfc_actual_arglist * arg)
+resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
 {
   gfc_symbol *sym;
   gfc_symtree *parent_st;
@@ -858,7 +867,6 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 
   for (; arg; arg = arg->next)
     {
-
       e = arg->expr;
       if (e == NULL)
         {
@@ -879,7 +887,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	{
 	  if (gfc_resolve_expr (e) != SUCCESS)
 	    return FAILURE;
-	  continue;
+	  goto argument_list;
 	}
 
       /* See if the expression node should really be a variable
@@ -944,7 +952,22 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 		      && sym->ns->parent->proc_name == sym)))
 	    goto got_variable;
 
-	  continue;
+	  /* If all else fails, see if we have a specific intrinsic.  */
+	  if (sym->attr.function
+		&& sym->ts.type == BT_UNKNOWN
+		&& sym->attr.intrinsic)
+	    {
+	      gfc_intrinsic_sym *isym;
+	      isym = gfc_find_function (sym->name);
+	      if (isym == NULL || !isym->specific)
+		{
+		  gfc_error ("Unable to find a specific INTRINSIC procedure "
+			     "for the reference '%s' at %L", sym->name,
+			     &e->where);
+		}
+	      sym->ts = isym->ts;
+	    }
+	  goto argument_list;
 	}
 
       /* See if the name is a module procedure in a parent unit.  */
@@ -968,7 +991,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	  || sym->attr.intrinsic
 	  || sym->attr.external)
 	{
-	  continue;
+	  goto argument_list;
 	}
 
     got_variable:
@@ -982,6 +1005,62 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	  e->ref->u.ar.type = AR_FULL;
 	  e->ref->u.ar.as = sym->as;
 	}
+
+    argument_list:
+      /* Check argument list functions %VAL, %LOC and %REF.  There is
+	 nothing to do for %REF.  */
+      if (arg->name && arg->name[0] == '%')
+	{
+	  if (strncmp ("%VAL", arg->name, 4) == 0)
+	    {
+	      if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
+		{
+		  gfc_error ("By-value argument at %L is not of numeric "
+			     "type", &e->where);
+		  return FAILURE;
+		}
+
+	      if (e->rank)
+		{
+		  gfc_error ("By-value argument at %L cannot be an array or "
+			     "an array section", &e->where);
+		return FAILURE;
+		}
+
+	      /* Intrinsics are still PROC_UNKNOWN here.  However,
+		 since same file external procedures are not resolvable
+		 in gfortran, it is a good deal easier to leave them to
+		 intrinsic.c.  */
+	      if (ptype != PROC_UNKNOWN && ptype != PROC_EXTERNAL)
+		{
+		  gfc_error ("By-value argument at %L is not allowed "
+			     "in this context", &e->where);
+		  return FAILURE;
+		}
+
+	      if (((e->ts.type == BT_REAL || e->ts.type == BT_COMPLEX)
+		    && e->ts.kind > gfc_default_real_kind)
+		      || (e->ts.kind > gfc_default_integer_kind))
+		{
+		  gfc_error ("Kind of by-value argument at %L is larger "
+			     "than default kind", &e->where);
+		  return FAILURE;
+		}
+
+	    }
+
+	  /* Statement functions have already been excluded above.  */
+	  else if (strncmp ("%LOC", arg->name, 4) == 0
+		     && e->ts.type == BT_PROCEDURE)
+	    {
+	      if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
+		{
+		  gfc_error ("Passing internal procedure at %L by location "
+			     "not allowed", &e->where);
+		  return FAILURE;
+		}
+	    }
+	}
     }
 
   return SUCCESS;
@@ -1457,11 +1536,19 @@ resolve_function (gfc_expr * expr)
   const char *name;
   try t;
   int temp;
+  procedure_type p = PROC_INTRINSIC;
 
   sym = NULL;
   if (expr->symtree)
     sym = expr->symtree->n.sym;
 
+  if (sym && sym->attr.flavor == FL_VARIABLE)
+    {
+      gfc_error ("'%s' at %L is not a function",
+		 sym->name, &expr->where);
+      return FAILURE;
+    }
+
   /* If the procedure is not internal, a statement function or a module
      procedure,it must be external and should be checked for usage.  */
   if (sym && !sym->attr.dummy && !sym->attr.contained
@@ -1473,8 +1560,11 @@ resolve_function (gfc_expr * expr)
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
 
-  if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
-    return FAILURE;
+  if (expr->symtree && expr->symtree->n.sym)
+    p = expr->symtree->n.sym->attr.proc;
+
+  if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
+      return FAILURE;
 
   /* Resume assumed_size checking. */
   need_full_assumed_size--;
@@ -1854,6 +1944,7 @@ static try
 resolve_call (gfc_code * c)
 {
   try t;
+  procedure_type ptype = PROC_INTRINSIC;
 
   if (c->symtree && c->symtree->n.sym
 	&& c->symtree->n.sym->ts.type != BT_UNKNOWN)
@@ -1900,7 +1991,10 @@ resolve_call (gfc_code * c)
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
 
-  if (resolve_actual_arglist (c->ext.actual) == FAILURE)
+  if (c->symtree && c->symtree->n.sym)
+    ptype = c->symtree->n.sym->attr.proc;
+
+  if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
     return FAILURE;
 
   /* Resume assumed_size checking. */
@@ -5560,7 +5654,6 @@ static try
 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
 {
   gfc_formal_arglist *arg;
-  gfc_symtree *st;
 
   if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
     gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
@@ -5570,16 +5663,6 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
 	&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
     return FAILURE;
 
-  st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
-  if (st && st->ambiguous
-	 && sym->attr.referenced
-	 && !sym->attr.generic)
-    {
-      gfc_error ("Procedure %s at %L is ambiguous",
-		 sym->name, &sym->declared_at);
-      return FAILURE;
-    }
-
   if (sym->ts.type == BT_CHARACTER)
     {
       gfc_charlen *cl = sym->ts.cl;

gcc/fortran/trans-expr.c

@@ -1862,6 +1862,57 @@ is_aliased_array (gfc_expr * e)
   return false;
 }
 
+/* Generate the code for argument list functions.  */
+
+static void
+conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
+{
+  tree type = NULL_TREE;
+  /* Pass by value for g77 %VAL(arg), pass the address
+     indirectly for %LOC, else by reference.  Thus %REF
+     is a "do-nothing" and %LOC is the same as an F95
+     pointer.  */
+  if (strncmp (name, "%VAL", 4) == 0)
+    {
+      gfc_conv_expr (se, expr);
+      /* %VAL converts argument to default kind.  */
+      switch (expr->ts.type)
+	{
+	  case BT_REAL:
+	    type = gfc_get_real_type (gfc_default_real_kind);
+	    se->expr = fold_convert (type, se->expr);
+	    break;
+	  case BT_COMPLEX:
+	    type = gfc_get_complex_type (gfc_default_complex_kind);
+	    se->expr = fold_convert (type, se->expr);
+	    break;
+	  case BT_INTEGER:
+	    type = gfc_get_int_type (gfc_default_integer_kind);
+	    se->expr = fold_convert (type, se->expr);
+	    break;
+	  case BT_LOGICAL:
+	    type = gfc_get_logical_type (gfc_default_logical_kind);
+	    se->expr = fold_convert (type, se->expr);
+	    break;
+	  /* This should have been resolved away.  */
+	  case BT_UNKNOWN: case BT_CHARACTER: case BT_DERIVED:
+	  case BT_PROCEDURE: case BT_HOLLERITH:
+	    gfc_internal_error ("Bad type in conv_arglist_function");
+	}
+	  
+    }
+  else if (strncmp (name, "%LOC", 4) == 0)
+    {
+      gfc_conv_expr_reference (se, expr);
+      se->expr = gfc_build_addr_expr (NULL, se->expr);
+    }
+  else if (strncmp (name, "%REF", 4) == 0)
+    gfc_conv_expr_reference (se, expr);
+  else
+    gfc_error ("Unknown argument list function at %L", &expr->where);
+}
+
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.  */
@@ -1975,17 +2026,24 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 
 	  if (argss == gfc_ss_terminator)
             {
-	      gfc_conv_expr_reference (&parmse, e);
 	      parm_kind = SCALAR;
-              if (fsym && fsym->attr.pointer
-		  && e->expr_type != EXPR_NULL)
-                {
-                  /* Scalar pointer dummy args require an extra level of
-		  indirection. The null pointer already contains
-		  this level of indirection.  */
-		  parm_kind = SCALAR_POINTER;
-                  parmse.expr = build_fold_addr_expr (parmse.expr);
-                }
+	      if (arg->name && arg->name[0] == '%')
+		/* Argument list functions %VAL, %LOC and %REF are signalled
+		   through arg->name.  */
+		conv_arglist_function (&parmse, arg->expr, arg->name);
+	      else
+		{
+		  gfc_conv_expr_reference (&parmse, e);
+		  if (fsym && fsym->attr.pointer
+			&& e->expr_type != EXPR_NULL)
+		    {
+		      /* Scalar pointer dummy args require an extra level of
+			 indirection. The null pointer already contains
+			 this level of indirection.  */
+		      parm_kind = SCALAR_POINTER;
+		      parmse.expr = build_fold_addr_expr (parmse.expr);
+		    }
+		}
             }
 	  else
 	    {

gcc/testsuite/ChangeLog

@@ -1,3 +1,28 @@
+2007-01-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30034
+	* gfortran.dg/pure_formal_proc_1.f90: New test.
+
+	PR fortran/30237
+	* gfortran.dg/intrinsic_actual_3.f90: New test.
+
+	PR fortran/25135
+	* gfortran.dg/generic_11.f90: New test.
+	* gfortran.dg/interface_7.f90: Remove name clash between module
+	name and procedure 'x' referenced in the interface.
+
+	PR fortran/23060
+	* gfortran.dg/c_by_val.c: Called by c_by_val_1.f.
+	* gfortran.dg/c_by_val_1.f: New test.
+	* gfortran.dg/c_by_val_2.f: New test.
+	* gfortran.dg/c_by_val_3.f: New test.
+
+	PR fortran/27900
+	* gfortran.dg/intrinsic_actual_4.f90: New test.
+
+	PR fortran/24325
+	* gfortran.dg/func_decl_3.f90: New test.
+
 2007-01-05  Richard Guenther  <rguenther@suse.de>
 
 	PR middle-end/27826

gcc/testsuite/gfortran.dg/c_by_val.c

@@ -0,0 +1,41 @@
+/*  Passing from fortran to C by value, using %VAL.  */
+
+typedef struct { float r, i; } complex;
+extern void f_to_f__ (float*, float, float*, float**);
+extern void i_to_i__ (int*, int, int*, int**);
+extern void c_to_c__ (complex*, complex, complex*, complex**);
+extern void abort (void);
+
+void
+f_to_f__(float *retval, float a1, float *a2, float **a3)
+{
+  if ( a1 != *a2 ) abort();
+  if ( a1 != **a3 ) abort();
+  a1 = 0.0;
+  *retval = *a2 * 2.0;
+  return;
+}
+
+void
+i_to_i__(int *retval, int i1, int *i2, int **i3)
+{
+  if ( i1 != *i2 ) abort();
+  if ( i1 != **i3 ) abort();
+  i1 = 0;
+  *retval = *i2 * 3;
+  return;
+}
+
+void
+c_to_c__(complex *retval, complex c1, complex *c2, complex **c3)
+{
+  if ( c1.r != c2->r ) abort();
+  if ( c1.i != c2->i ) abort();
+  if ( c1.r != (*c3)->r ) abort();
+  if ( c1.i != (*c3)->i ) abort();
+  c1.r = 0.0;
+  c1.i = 0.0;
+  retval->r = c2->r * 4.0;
+  retval->i = c2->i * 4.0;
+  return;
+}

gcc/testsuite/gfortran.dg/c_by_val_1.f

@@ -0,0 +1,31 @@
+C { dg-do run }
+C { dg-additional-sources c_by_val.c }
+C { dg-options "-ff2c -w -O0" }
+
+      program c_by_val_1
+      external   f_to_f, i_to_i, c_to_c
+      real       a, b, c
+      integer*4  i, j, k
+      complex    u, v, w, c_to_c
+
+      a = 42.0
+      b = 0.0
+      c = a
+      call  f_to_f (b, %VAL (a), %REF (c), %LOC (c))
+      if ((2.0 * a).ne.b) call abort ()
+
+      i = 99
+      j = 0
+      k = i
+      call i_to_i (j, %VAL (i), %REF (k), %LOC (k))
+      if ((3 * i).ne.j) call abort ()
+
+      u = (-1.0, 2.0)
+      v = (1.0, -2.0)
+      w = u
+      v = c_to_c (%VAL (u), %REF (w), %LOC (w))
+      if ((4.0 * u).ne.v) call abort ()
+
+      stop
+      end
+

gcc/testsuite/gfortran.dg/c_by_val_2.f90

@@ -0,0 +1,29 @@
+! { dg-do compile }
+! { dg-options "-w" }
+
+program c_by_val_2
+  external bar
+  real (4) :: bar, ar(2) = (/1.0,2.0/)
+  type     :: mytype
+    integer  :: i
+  end type mytype
+  type(mytype)  :: z
+  character(8)  :: c = "blooey"
+  print *, sin (%VAL(2.0))   ! { dg-error "not allowed in this context" }
+  print *, foo (%VAL(1.0))   ! { dg-error "not allowed in this context" }
+  call  foobar (%VAL(0.5))   ! { dg-error "not allowed in this context" }
+  print *, bar (%VAL(z))     ! { dg-error "not of numeric type" }
+  print *, bar (%VAL(c))     ! { dg-error "not of numeric type" }
+  print *, bar (%VAL(ar))    ! { dg-error "cannot be an array" }
+  print *, bar (%VAL(0.0))
+contains
+  function foo (a)
+    real(4) :: a, foo
+    foo = cos (a)
+  end function foo
+  subroutine foobar (a)
+    real(4) :: a
+    print *, a
+  end subroutine foobar
+end program c_by_val_2
+

gcc/testsuite/gfortran.dg/c_by_val_3.f90

@@ -0,0 +1,7 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+program c_by_val_3
+  external bar
+  real (4) :: bar
+  print *, bar (%VAL(0.0)) ! { dg-error "argument list function" }
+end program c_by_val_3

gcc/testsuite/gfortran.dg/dummy_procedure_1.f90

@@ -37,7 +37,7 @@ end module m1
   call s1(w) ! { dg-error "not allowed as an actual argument" }
   call s1(x) ! explicit interface
   call s1(y) ! declared external
-  call s1(z) ! already compiled
+  call s1(z) ! { dg-error "Expected a procedure for argument" }
 contains
   integer function w()
     w = 1

gcc/testsuite/gfortran.dg/func_decl_3.f90

@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Tests the fix for PR24325 in which the lack of any declaration
+! that foo is a function or even a procedure was not detected.
+!
+! Contributed by Jakub Jelinek <jakub@gcc.gnu.org>
+!
+  integer foo
+  call test
+contains
+  subroutine test
+    integer :: i
+    i = foo () ! { dg-error "is not a function" }
+  end subroutine test
+end
+

gcc/testsuite/gfortran.dg/generic_11.f90

@@ -0,0 +1,31 @@
+! { dg-do compile }
+! Test the fix for PR25135 in which the ambiguity between subroutine
+! foo in m_foo and interface foo in m_bar was not recognised.
+!
+!Contributed by Yusuke IGUCHI <iguchi@coral.t.u-tokyo.ac.jp>
+!
+module m_foo
+contains
+  subroutine foo
+    print *, "foo"
+  end subroutine
+end module
+
+module m_bar
+  interface foo
+    module procedure bar
+  end interface
+contains
+  subroutine bar
+    print *, "bar"
+  end subroutine
+end module
+
+use m_foo
+use m_bar
+
+call foo ! { dg-error "is an ambiguous reference" } 
+end
+! { dg-final { cleanup-modules "m_foo m_bar" } }
+
+

gcc/testsuite/gfortran.dg/interface_7.f90

@@ -6,7 +6,7 @@
 ! standard explicitly does not require recursion into the formal
 ! arguments of procedures that themselves are interface arguments.
 !
-module x
+module xx
   INTERFACE BAD9
     SUBROUTINE S9A(X)
       REAL :: X
@@ -27,6 +27,6 @@ module x
       END INTERFACE
     END SUBROUTINE S9C  ! { dg-error "Ambiguous interfaces" }
   END INTERFACE BAD9
-end module x
+end module xx
 
-! { dg-final { cleanup-modules "x" } }
+! { dg-final { cleanup-modules "xx" } }

gcc/testsuite/gfortran.dg/intrinsic_actual_3.f90

@@ -0,0 +1,24 @@
+! { dg-do compile }
+! Tests the fix for PR30237 in which alternate returns in intrinsic
+! actual arglists were quietly ignored.
+!
+! Contributed by Brooks Moses <brooks@gcc.gnu.org>
+!
+program ar1
+    interface random_seed
+      subroutine x (a, *)
+        integer a
+      end subroutine x
+    end interface random_seed
+
+    real t1(2)
+    call cpu_time(*20)        ! { dg-error "not permitted" }
+    call cpu_time(*20, t1(1)) ! { dg-error "Too many arguments" }
+! This specific version is permitted by the generic interface.
+    call random_seed(i, *20)
+! The new error gets overwritten but the diagnostic is clear enough.
+    call random_seed(i, *20, *30) ! { dg-error "not consistent" }
+    stop
+20  write(*,*) t1
+30 stop
+end

gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90

@@ -0,0 +1,18 @@
+! { dg-do run }
+! Tests the fix for PR27900, in which an ICE would be caused because
+! the actual argument LEN had no type.
+!
+! Contributed by Klaus Ramstöck <klra67@freenet.de>
+!
+      subroutine sub (proc, chr)
+      external proc
+      integer proc
+      character*(*) chr
+      if (proc (chr) .ne. 6) call abort ()
+      end subroutine sub
+
+      implicit none
+      integer i
+      i = len ("123")
+      call sub (len, "abcdef")
+      end

gcc/testsuite/gfortran.dg/pure_formal_proc_1.f90

@@ -0,0 +1,16 @@
+! { dg-do compile }
+! Test fix for PR30034 in which the legal, pure procedure formal
+! argument was rejected as an error.
+!
+! Contgributed by Troban Trumsko <trumsko@yahoo.com>
+!
+ pure subroutine s_one ( anum, afun )
+    integer, intent(in) :: anum
+    interface
+      pure function afun (k) result (l)
+        implicit none
+        integer, intent(in) :: k
+        integer :: l
+      end function afun
+    end interface
+end subroutine s_one