re PR fortran/30964 (optional arguments to random_seed)

	PR fortran/30964
	PR fortran/33054

	* trans-expr.c (gfc_conv_function_call): When no formal argument
	list is available, we still substitute missing optional arguments.
	* check.c (gfc_check_random_seed): Correct the check on the
	number of arguments to RANDOM_SEED.
	* intrinsic.c (add_subroutines): Add a resolution function to
	RANDOM_SEED.
	* iresolve.c (gfc_resolve_random_seed): New function.
	* intrinsic.h (gfc_resolve_random_seed): New prototype.

	* intrinsics/random.c (random_seed): Rename into random_seed_i4.
	(random_seed_i8): New function.
	* gfortran.map (GFORTRAN_1.0): Remove _gfortran_random_seed,
	add _gfortran_random_seed_i4 and _gfortran_random_seed_i8.
	* libgfortran.h (iexport_proto): Replace random_seed by
	random_seed_i4 and random_seed_i8.
	* runtime/main.c (init): Call the new random_seed_i4.

	* gfortran.dg/random_4.f90: New test.
	* gfortran.dg/random_5.f90: New test.
	* gfortran.dg/random_6.f90: New test.
	* gfortran.dg/random_7.f90: New test.

From-SVN: r127383

11 files changed, 157 insertions, 35 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a6e5c9edc1a..acbe9a7cf77 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,18 @@
 2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+	PR fortran/30964
+	PR fortran/33054
+	* trans-expr.c (gfc_conv_function_call): When no formal argument
+	list is available, we still substitute missing optional arguments.
+	* check.c (gfc_check_random_seed): Correct the check on the
+	number of arguments to RANDOM_SEED.
+	* intrinsic.c (add_subroutines): Add a resolution function to
+	RANDOM_SEED.
+	* iresolve.c (gfc_resolve_random_seed): New function.
+	* intrinsic.h (gfc_resolve_random_seed): New prototype.
+
+2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
 	PR fortran/32860
 	* error.c (error_uinteger): New function.
 	(error_integer): Call error_uinteger.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f0de08f3a21..23955deab9d 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2880,8 +2880,15 @@ gfc_check_random_number (gfc_expr *harvest)
 try
 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 {
+  unsigned int nargs = 0;
+  locus *where = NULL;
+
   if (size != NULL)
     {
+      if (size->expr_type != EXPR_VARIABLE
+	  || !size->symtree->n.sym->attr.optional)
+	nargs++;
+
       if (scalar_check (size, 0) == FAILURE)
 	return FAILURE;
 
@@ -2897,10 +2904,12 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 
   if (put != NULL)
     {
-
-      if (size != NULL)
-	gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
-		    &put->where);
+      if (put->expr_type != EXPR_VARIABLE
+	  || !put->symtree->n.sym->attr.optional)
+	{
+	  nargs++;
+	  where = &put->where;
+	}
 
       if (array_check (put, 1) == FAILURE)
 	return FAILURE;
@@ -2917,10 +2926,12 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 
   if (get != NULL)
     {
-
-      if (size != NULL || put != NULL)
-	gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
-		   &get->where);
+      if (get->expr_type != EXPR_VARIABLE
+	  || !get->symtree->n.sym->attr.optional)
+	{
+	  nargs++;
+	  where = &get->where;
+	}
 
       if (array_check (get, 2) == FAILURE)
 	return FAILURE;
@@ -2938,6 +2949,10 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 	return FAILURE;
     }
 
+  /* RANDOM_SEED may not have more than one non-optional argument.  */
+  if (nargs > 1)
+    gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
+
   return SUCCESS;
 }
 
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 59006b2ee24..7f02245c7fb 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2467,8 +2467,9 @@ add_subroutines (void)
 	      gfc_check_random_number, NULL, gfc_resolve_random_number,
 	      h, BT_REAL, dr, REQUIRED);
 
-  add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
-	      gfc_check_random_seed, NULL, NULL,
+  add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
+	      BT_UNKNOWN, 0, GFC_STD_F95,
+	      gfc_check_random_seed, NULL, gfc_resolve_random_seed,
 	      sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
 	      gt, BT_INTEGER, di, OPTIONAL);
 
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 79cf3e52951..1e03e0cdd30 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -487,6 +487,7 @@ void gfc_resolve_ltime (gfc_code *);
 void gfc_resolve_mvbits (gfc_code *);
 void gfc_resolve_perror (gfc_code *);
 void gfc_resolve_random_number (gfc_code *);
+void gfc_resolve_random_seed (gfc_code *);
 void gfc_resolve_rename_sub (gfc_code *);
 void gfc_resolve_link_sub (gfc_code *);
 void gfc_resolve_symlnk_sub (gfc_code *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index e3186155f27..6232374161e 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2507,6 +2507,16 @@ gfc_resolve_random_number (gfc_code *c)
 
 
 void
+gfc_resolve_random_seed (gfc_code *c)
+{
+  const char *name;
+
+  name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
 gfc_resolve_rename_sub (gfc_code *c)
 {
   const char *name;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1ae601ff17a..d421a7347e2 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2303,36 +2303,38 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    } 
 	}
 
-      if (fsym)
+      /* The case with fsym->attr.optional is that of a user subroutine
+	 with an interface indicating an optional argument.  When we call
+	 an intrinsic subroutine, however, fsym is NULL, but we might still
+	 have an optional argument, so we proceed to the substitution
+	 just in case.  */
+      if (e && (fsym == NULL || fsym->attr.optional))
 	{
-	  if (e)
+	  /* If an optional argument is itself an optional dummy argument,
+	     check its presence and substitute a null if absent.  */
+	  if (e->expr_type == EXPR_VARIABLE
+	      && e->symtree->n.sym->attr.optional)
+	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts);
+	}
+
+      if (fsym && e)
+	{
+	  /* Obtain the character length of an assumed character length
+	     length procedure from the typespec.  */
+	  if (fsym->ts.type == BT_CHARACTER
+	      && parmse.string_length == NULL_TREE
+	      && e->ts.type == BT_PROCEDURE
+	      && e->symtree->n.sym->ts.type == BT_CHARACTER
+	      && e->symtree->n.sym->ts.cl->length != NULL)
 	    {
-	      /* If an optional argument is itself an optional dummy
-		 argument, check its presence and substitute a null
-		 if absent.  */
-	      if (e->expr_type == EXPR_VARIABLE
-		    && e->symtree->n.sym->attr.optional
-		    && fsym->attr.optional)
-		gfc_conv_missing_dummy (&parmse, e, fsym->ts);
-
-	      /* Obtain the character length of an assumed character
-		 length procedure from the typespec.  */
-	      if (fsym->ts.type == BT_CHARACTER
-		    && parmse.string_length == NULL_TREE
-		    && e->ts.type == BT_PROCEDURE
-		    && e->symtree->n.sym->ts.type == BT_CHARACTER
-		    && e->symtree->n.sym->ts.cl->length != NULL)
-		{
-		  gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
-		  parmse.string_length
-			= e->symtree->n.sym->ts.cl->backend_decl;
-		}
+	      gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
+	      parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
 	    }
-
-	  if (need_interface_mapping)
-	    gfc_add_interface_mapping (&mapping, fsym, &parmse);
 	}
 
+      if (fsym && need_interface_mapping)
+	gfc_add_interface_mapping (&mapping, fsym, &parmse);
+
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 106fe59623e..6640aee6794 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,14 @@
 2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+	PR fortran/30964
+	PR fortran/33054
+	* gfortran.dg/random_4.f90: New test.
+	* gfortran.dg/random_5.f90: New test.
+	* gfortran.dg/random_6.f90: New test.
+	* gfortran.dg/random_7.f90: New test.
+
+2007-08-12  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
 	PR fortran/32860
 	* gcc.dg/format/gcc_gfc-1.c: Updated with new formats.
 
diff --git a/gcc/testsuite/gfortran.dg/random_4.f90 b/gcc/testsuite/gfortran.dg/random_4.f90
new file mode 100644
index 00000000000..416b17c0086
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/random_4.f90
@@ -0,0 +1,19 @@
+! { dg-do run }
+!
+program trs
+  implicit none
+  integer :: size, ierr
+  integer, allocatable, dimension(:) :: seed, check
+  call test_random_seed(size)
+  allocate(seed(size),check(size))
+  call test_random_seed(put=seed)
+  call test_random_seed(get=check)
+  if (any (seed /= check)) call abort
+contains
+  subroutine test_random_seed(size, put, get)
+    integer, optional :: size
+    integer, dimension(:), optional :: put
+    integer, dimension(:), optional :: get
+    call random_seed(size, put, get)
+  end subroutine test_random_seed
+end program trs
diff --git a/gcc/testsuite/gfortran.dg/random_5.f90 b/gcc/testsuite/gfortran.dg/random_5.f90
new file mode 100644
index 00000000000..418bd68fb70
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/random_5.f90
@@ -0,0 +1,17 @@
+! { dg-do run }
+! { dg-shouldfail "" }
+!
+program trs
+  implicit none
+  integer :: size
+  integer :: seed(50)
+  call test_random_seed(size,seed)
+contains
+  subroutine test_random_seed(size, put, get)
+    integer, optional :: size
+    integer, dimension(:), optional :: put
+    integer, dimension(:), optional :: get
+    call random_seed(size, put, get)
+  end subroutine test_random_seed
+end program trs
+! { dg-output "Fortran runtime error: RANDOM_SEED should have at most one argument present.*" }
diff --git a/gcc/testsuite/gfortran.dg/random_6.f90 b/gcc/testsuite/gfortran.dg/random_6.f90
new file mode 100644
index 00000000000..078c8af01f5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/random_6.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+!
+subroutine test1 (size, put, get)
+  integer :: size
+  integer, dimension(:), optional :: put
+  integer, dimension(:), optional :: get
+  call random_seed(size, put, get)
+end
+
+subroutine test2 (size, put, get)
+  integer, optional :: size
+  integer, dimension(:) :: put
+  integer, dimension(:) :: get
+  call random_seed(size, put, get) ! { dg-error "Too many arguments" }
+end
diff --git a/gcc/testsuite/gfortran.dg/random_7.f90 b/gcc/testsuite/gfortran.dg/random_7.f90
new file mode 100644
index 00000000000..46d8ccb8816
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/random_7.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-options "-fdefault-integer-8" }
+!
+program trs
+  implicit none
+  integer :: size, ierr
+  integer, allocatable, dimension(:) :: seed, check
+  call test_random_seed(size)
+  allocate(seed(size),check(size))
+  call test_random_seed(put=seed)
+  call test_random_seed(get=check)
+  if (any (seed /= check)) call abort
+contains
+  subroutine test_random_seed(size, put, get)
+    integer, optional :: size
+    integer, dimension(:), optional :: put
+    integer, dimension(:), optional :: get
+    call random_seed(size, put, get)
+  end subroutine test_random_seed
+end program trs