re PR fortran/25818 ([4.1 only] Problem with handling optional and entry master arguments)

2006-12-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25818
	* trans-array.c (gfc_trans_g77_array): If the variable is
	optional or not always present, make the statement conditional
	on presence of the argument.
	* gfortran.h : Add symbol_attribute not_always_present.
	* resolve.c (check_argument_lists): New function to check if
	arguments are not present in all entries.

	PR fortran/30084
	* module.c (mio_component_ref): Move treatment of unique name
	variables, during output, to fix_mio_expr.
	(fix_mio_expr): New function that fixes defective expressions
	before they are written to the module file.
	(mio_expr): Call the new function.
	(resolve_entries): Call check_argument_lists.

2006-12-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25818
	* gfortran.dg/entry_array_specs_2.f: New test.

	PR fortran/30084
	* gfortran.dg/nested_modules_6.f90: New test.

From-SVN: r120155

gcc/fortran/ChangeLog

+2006-12-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25818
+	* trans-array.c (gfc_trans_g77_array): If the variable is
+	optional or not always present, make the statement conditional
+	on presence of the argument.
+	* gfortran.h : Add symbol_attribute not_always_present.
+	* resolve.c (check_argument_lists): New function to check if
+	arguments are not present in all entries.
+
+	PR fortran/30084
+	* module.c (mio_component_ref): Move treatment of unique name
+	variables, during output, to fix_mio_expr.
+	(fix_mio_expr): New function that fixes defective expressions
+	before they are written to the module file.
+	(mio_expr): Call the new function.
+	(resolve_entries): Call check_argument_lists.
+
 2006-12-21  Roger Sayle  <roger@eyesopen.com>
 
 	* trans-array.c (gfc_trans_create_temp_array): When the size is known

gcc/fortran/gfortran.h

@@ -480,7 +480,7 @@ typedef struct
   /* Variable attributes.  */
   unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
     optional:1, pointer:1, save:1, target:1, value:1, volatile_:1,
-    dummy:1, result:1, assign:1, threadprivate:1;
+    dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1;
 
   unsigned data:1,		/* Symbol is named in a DATA statement.  */
     protected:1,		/* Symbol has been marked as protected.  */

gcc/fortran/module.c

@@ -2194,27 +2194,9 @@ mio_symtree_ref (gfc_symtree ** stp)
 {
   pointer_info *p;
   fixup_t *f;
-  gfc_symtree * ns_st = NULL;
 
   if (iomode == IO_OUTPUT)
-    {
-      /* If this is a symtree for a symbol that came from a contained module
-	 namespace, it has a unique name and we should look in the current
-	 namespace to see if the required, non-contained symbol is available
-	 yet. If so, the latter should be written.  */
-      if ((*stp)->n.sym && check_unique_name((*stp)->name))
-	ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
-				    (*stp)->n.sym->name);
-
-      /* On the other hand, if the existing symbol is the module name or the
-	 new symbol is a dummy argument, do not do the promotion.  */
-      if (ns_st && ns_st->n.sym
-	    && ns_st->n.sym->attr.flavor != FL_MODULE
-	    && !(*stp)->n.sym->attr.dummy)
-	mio_symbol_ref (&ns_st->n.sym);
-      else
-	mio_symbol_ref (&(*stp)->n.sym);
-    }
+    mio_symbol_ref (&(*stp)->n.sym);
   else
     {
       require_atom (ATOM_INTEGER);
@@ -2554,6 +2536,48 @@ static const mstring intrinsics[] =
     minit (NULL, -1)
 };
 
+
+/* Remedy a couple of situations where the gfc_expr's can be defective.  */
+ 
+static void
+fix_mio_expr (gfc_expr *e)
+{
+  gfc_symtree *ns_st = NULL;
+  const char *fname;
+
+  if (iomode != IO_OUTPUT)
+    return;
+
+  if (e->symtree)
+    {
+      /* If this is a symtree for a symbol that came from a contained module
+	 namespace, it has a unique name and we should look in the current
+	 namespace to see if the required, non-contained symbol is available
+	 yet. If so, the latter should be written.  */
+      if (e->symtree->n.sym && check_unique_name(e->symtree->name))
+	ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
+				    e->symtree->n.sym->name);
+
+      /* On the other hand, if the existing symbol is the module name or the
+	 new symbol is a dummy argument, do not do the promotion.  */
+      if (ns_st && ns_st->n.sym
+	    && ns_st->n.sym->attr.flavor != FL_MODULE
+	    && !e->symtree->n.sym->attr.dummy)
+	e->symtree = ns_st;
+    }
+  else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
+    {
+      /* In some circumstances, a function used in an initialization
+	 expression, in one use associated module, can fail to be
+	 coupled to its symtree when used in a specification
+	 expression in another module.  */
+      fname = e->value.function.esym ? e->value.function.esym->name :
+				       e->value.function.isym->name;
+      e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
+    }
+}
+
+
 /* Read and write expressions.  The form "()" is allowed to indicate a
    NULL expression.  */
 
@@ -2598,6 +2622,8 @@ mio_expr (gfc_expr ** ep)
   mio_typespec (&e->ts);
   mio_integer (&e->rank);
 
+  fix_mio_expr (e);
+
   switch (e->expr_type)
     {
     case EXPR_OP:

gcc/fortran/resolve.c

@@ -342,6 +342,33 @@ merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
 }
 
 
+/* Flag the arguments that are not present in all entries.  */
+
+static void
+check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
+{
+  gfc_formal_arglist *f, *head;
+  head = new_args;
+
+  for (f = proc->formal; f; f = f->next)
+    {
+      if (f->sym == NULL)
+	continue;
+
+      for (new_args = head; new_args; new_args = new_args->next)
+	{
+	  if (new_args->sym == f->sym)
+	    break;
+	}
+
+      if (new_args)
+	continue;
+
+      f->sym->attr.not_always_present = 1;
+    }
+}
+
+
 /* Resolve alternate entry points.  If a symbol has multiple entry points we
    create a new master symbol for the main routine, and turn the existing
    symbol into an entry point.  */
@@ -541,6 +568,11 @@ resolve_entries (gfc_namespace * ns)
   for (el = ns->entries; el; el = el->next)
     merge_argument_lists (proc, el->sym->formal);
 
+  /* Check the master formal arguments for any that are not
+     present in all entry points.  */
+  for (el = ns->entries; el; el = el->next)
+    check_argument_lists (proc, el->sym->formal);
+
   /* Use the master function for the function body.  */
   ns->proc_name = proc;
 

gcc/fortran/trans-array.c

@@ -3767,6 +3767,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
   locus loc;
   tree offset;
   tree tmp;
+  tree stmt;  
   stmtblock_t block;
 
   gfc_get_backend_locus (&loc);
@@ -3796,13 +3797,21 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
       tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
       gfc_add_modify_expr (&block, parm, tmp);
     }
-  tmp = gfc_finish_block (&block);
+  stmt = gfc_finish_block (&block);
 
   gfc_set_backend_locus (&loc);
 
   gfc_start_block (&block);
+
   /* Add the initialization code to the start of the function.  */
-  gfc_add_expr_to_block (&block, tmp);
+
+  if (sym->attr.optional || sym->attr.not_always_present)
+    {
+      tmp = gfc_conv_expr_present (sym);
+      stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+    }
+  
+  gfc_add_expr_to_block (&block, stmt);
   gfc_add_expr_to_block (&block, body);
 
   return gfc_finish_block (&block);

gcc/testsuite/ChangeLog

+2006-12-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25818
+	* gfortran.dg/entry_array_specs_2.f: New test.
+
+	PR fortran/30084
+	* gfortran.dg/nested_modules_6.f90: New test.
+
 2006-12-22  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
 
 	PR middle-end/7651

gcc/testsuite/gfortran.dg/entry_array_specs_2.f

+! { dg-do run }
+! Tests the patch for PR30025, aka 25818, in which the initialization
+! code for the array a, was causing a segfault in runtime for a call
+! to x, since n is missing.
+!
+! COntributed by Elizabeth Yip <elizabeth.l.yip@boeing.com>
+      program test_entry
+      common // j
+      real a(10)
+      a(1) = 999.
+      call x
+      if (j .ne. 1) call abort ()
+      call y(a,10)
+      if (j .ne. 2) call abort ()
+      stop
+      end 
+      subroutine x
+      common // j
+      real a(n)
+      j = 1
+      return
+      entry y(a,n)
+      call foo(a(1))
+      end
+      subroutine foo(a)
+      common // j
+      real a
+      j = 2
+      return
+      end
+

gcc/testsuite/gfortran.dg/nested_modules_6.f90

+! { dg-do compile }
+! Test the patch for PR30084 in which the reference to SIZE
+! in function diag caused a segfault in module.c.
+!
+! Contributed by Troban Trumsko <trumsko@yahoo.com>
+! and reduced by Steve Kargl <kargl@gcc.gnu.org>
+!
+module tao_random_numbers
+  integer, dimension(10) :: s_buffer
+  integer :: s_last = size (s_buffer)
+end module tao_random_numbers
+
+module linalg
+  contains
+  function diag (a) result (d)
+    real, dimension(:,:), intent(in) :: a
+    real, dimension(min(size(a,dim=1),size(a,dim=2))) :: d
+    integer :: i
+    do i = 1, min(size(a, dim = 1), size(a, dim = 2))
+       d(i) = a(i,i)
+    end do
+  end function diag
+end module linalg
+
+module vamp_rest
+  use tao_random_numbers
+  use linalg
+end module vamp_rest
+
+  use vamp_rest
+  real :: x(2, 2) = reshape ([1.,2.,3.,4.], [2,2]) ! { dg-warning "nonstandard" } 
+  print *, s_last
+  print *, diag (x)
+end
+! { dg-final { cleanup-modules "tao_random_numbers linalg vamp_rest" } }