[gfortran,patch] Fix RANDOM_SEED: optional arguments and -fdefault-integer-8

[gfortran,patch] Fix RANDOM_SEED: optional arguments and -fdefault-integer-8

[FX Coudert]

[-- Attachment #1: Type: text/plain, Size: 1866 bytes --]

Hi all,

This patch fixes various aspects of RANDOM_SEED: its handling of  
optional arguments and its use with -fdefault-integer-8, as well as a  
more generic problem with optional args to intrinsic subroutines.

   * Optional dummies used as optional args to subroutine where not  
checked for presence. This is probably rarely a problem, except when  
the dummy in question is an array (and there aren't so many intrinsic  
subroutines with option array arguments). The trans-expr.c part of  
this patch fixes this, fixing a wrong-code problem that could be seen  
on RANDOM_SEED (second part of PR30964).

   * RANDOM_SEED wrongly rejected calls where more than one argument  
is passed, even though some of these might be missing arguments. The  
real limitation is that no more than one argument be *present*. I  
removed the check from check.c (I still check for cases where more  
than one non-optional arg is passed), and installed instead a run- 
time check in the library. (This fixes the first part of PR30964.)

   * While I was looking at RANDOM_SEED, it noticed that it might not  
work nicely with -fdefault-integer-8. Indeed, in this case, the  
integer(kind=4) library routine was used and passed integer(kind=8)  
arguments! So, I've made two versions of the library routine (which  
are resolved in iresolve.c). When the default integer kind is 8, the  
seed has half the size of the int4 seed, in terms of array size, so  
that the byte-size of the seed is indeed constant. I couldn't think  
of any other choice that made sense (ignoring bytes from the seed to  
keep it a constant array size seemed... gross!)


Bootstrapped and regtested on x86_64-linux, including 4 new testcases  
(one of them tests the behaviour with -fdefault-integer-8); I also  
checked the code generated with -fdefault-integer-8. OK to commit?



:ADDPATCH fortran:

[-- Attachment #2: random_seed.ChangeLog --]
[-- Type: application/octet-stream, Size: 1245 bytes --]

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/30964
	PR fortran/33054
	* 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.


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.


[-- Attachment #3: random_seed.diff --]
[-- Type: application/octet-stream, Size: 14564 bytes --]

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 127363)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -2452,8 +2452,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);
 
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 127363)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2303,36 +2303,38 @@ gfc_conv_function_call (gfc_se * se, gfc
 	    } 
 	}
 
-      if (fsym)
-	{
-	  if (e)
+      /* 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 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);
 
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 127363)
+++ gcc/fortran/intrinsic.h	(working copy)
@@ -481,6 +481,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 *);
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 127363)
+++ gcc/fortran/iresolve.c	(working copy)
@@ -2455,6 +2455,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;
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 127363)
+++ gcc/fortran/check.c	(working copy)
@@ -2805,8 +2805,15 @@ gfc_check_random_number (gfc_expr *harve
 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;
 
@@ -2822,10 +2829,12 @@ gfc_check_random_seed (gfc_expr *size, g
 
   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;
@@ -2842,10 +2851,12 @@ gfc_check_random_seed (gfc_expr *size, g
 
   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;
@@ -2863,6 +2874,10 @@ gfc_check_random_seed (gfc_expr *size, g
 	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;
 }
 
Index: libgfortran/runtime/main.c
===================================================================
--- libgfortran/runtime/main.c	(revision 127363)
+++ libgfortran/runtime/main.c	(working copy)
@@ -162,7 +162,7 @@ init (void)
   /* if (argc > 1 && strcmp(argv[1], "--resume") == 0) resume();  */
 #endif
 
-  random_seed(NULL,NULL,NULL);
+  random_seed_i4 (NULL, NULL, NULL);
 }
 
 
Index: libgfortran/intrinsics/random.c
===================================================================
--- libgfortran/intrinsics/random.c	(revision 127363)
+++ libgfortran/intrinsics/random.c	(working copy)
@@ -32,6 +32,7 @@ Boston, MA 02110-1301, USA.  */
 #include "config.h"
 #include "libgfortran.h"
 #include <gthr.h>
+#include <string.h>
 
 extern void random_r4 (GFC_REAL_4 *);
 iexport_proto(random_r4);
@@ -644,22 +645,22 @@ arandom_r16 (gfc_array_r16 *x)
    must be called with no argument or exactly one argument.  */
 
 void
-random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
+random_seed_i4 (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
 {
   int i;
 
   __gthread_mutex_lock (&random_lock);
 
-  if (size == NULL && put == NULL && get == NULL)
-    {
-      /* From the standard: "If no argument is present, the processor assigns
-         a processor-dependent value to the seed."  */
+  /* Check that we only have one argument present.  */
+  if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1)
+    runtime_error ("RANDOM_SEED should have at most one argument present.");
 
-      for (i=0; i<kiss_size; i++)
+  /* From the standard: "If no argument is present, the processor assigns
+     a processor-dependent value to the seed."  */
+  if (size == NULL && put == NULL && get == NULL)
+      for (i = 0; i < kiss_size; i++)
 	kiss_seed[i] = kiss_default_seed[i];
 
-    }
-
   if (size != NULL)
     *size = kiss_size;
 
@@ -675,7 +676,7 @@ random_seed (GFC_INTEGER_4 *size, gfc_ar
 
       /*  This code now should do correct strides.  */
       for (i = 0; i < kiss_size; i++)
-	kiss_seed[i] =(GFC_UINTEGER_4) put->data[i * put->dim[0].stride];
+	kiss_seed[i] = (GFC_UINTEGER_4) put->data[i * put->dim[0].stride];
     }
 
   /* Return the seed to GET data.  */
@@ -696,7 +697,65 @@ random_seed (GFC_INTEGER_4 *size, gfc_ar
 
   __gthread_mutex_unlock (&random_lock);
 }
-iexport(random_seed);
+iexport(random_seed_i4);
+
+
+void
+random_seed_i8 (GFC_INTEGER_8 *size, gfc_array_i8 *put, gfc_array_i8 *get)
+{
+  int i;
+
+  __gthread_mutex_lock (&random_lock);
+
+  /* Check that we only have one argument present.  */
+  if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1)
+    runtime_error ("RANDOM_SEED should have at most one argument present.");
+
+  /* From the standard: "If no argument is present, the processor assigns
+     a processor-dependent value to the seed."  */
+  if (size == NULL && put == NULL && get == NULL)
+      for (i = 0; i < kiss_size; i++)
+	kiss_seed[i] = kiss_default_seed[i];
+
+  if (size != NULL)
+    *size = kiss_size / 2;
+
+  if (put != NULL)
+    {
+      /* If the rank of the array is not 1, abort.  */
+      if (GFC_DESCRIPTOR_RANK (put) != 1)
+        runtime_error ("Array rank of PUT is not 1.");
+
+      /* If the array is too small, abort.  */
+      if (((put->dim[0].ubound + 1 - put->dim[0].lbound)) < kiss_size / 2)
+        runtime_error ("Array size of PUT is too small.");
+
+      /*  This code now should do correct strides.  */
+      for (i = 0; i < kiss_size; i += 2)
+	memcpy (&kiss_seed[i], &(put->data[i * put->dim[0].stride]),
+		sizeof (GFC_UINTEGER_8));
+    }
+
+  /* Return the seed to GET data.  */
+  if (get != NULL)
+    {
+      /* If the rank of the array is not 1, abort.  */
+      if (GFC_DESCRIPTOR_RANK (get) != 1)
+	runtime_error ("Array rank of GET is not 1.");
+
+      /* If the array is too small, abort.  */
+      if (((get->dim[0].ubound + 1 - get->dim[0].lbound)) < kiss_size / 2)
+	runtime_error ("Array size of GET is too small.");
+
+      /*  This code now should do correct strides.  */
+      for (i = 0; i < kiss_size; i += 2)
+	memcpy (&(get->data[i * get->dim[0].stride]), &kiss_seed[i],
+		sizeof (GFC_UINTEGER_8));
+    }
+
+  __gthread_mutex_unlock (&random_lock);
+}
+iexport(random_seed_i8);
 
 
 #ifndef __GTHREAD_MUTEX_INIT
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 127363)
+++ libgfortran/gfortran.map	(working copy)
@@ -553,7 +553,8 @@ GFORTRAN_1.0 {
     _gfortran_random_r16;
     _gfortran_random_r4;
     _gfortran_random_r8;
-    _gfortran_random_seed;
+    _gfortran_random_seed_i4;
+    _gfortran_random_seed_i8;
     _gfortran_rename_i4;
     _gfortran_rename_i4_sub;
     _gfortran_rename_i8;
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h	(revision 127364)
+++ libgfortran/libgfortran.h	(working copy)
@@ -768,9 +768,12 @@ iexport_proto(compare_string);
 
 /* random.c */
 
-extern void random_seed (GFC_INTEGER_4 * size, gfc_array_i4 * put,
-			 gfc_array_i4 * get);
-iexport_proto(random_seed);
+extern void random_seed_i4 (GFC_INTEGER_4 * size, gfc_array_i4 * put,
+			    gfc_array_i4 * get);
+iexport_proto(random_seed_i4);
+extern void random_seed_i8 (GFC_INTEGER_8 * size, gfc_array_i8 * put,
+			    gfc_array_i8 * get);
+iexport_proto(random_seed_i8);
 
 /* size.c */
 
Index: gcc/testsuite/gfortran.dg/random_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/random_5.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/random_5.f90	(revision 0)
@@ -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.*" }
Index: gcc/testsuite/gfortran.dg/random_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/random_6.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/random_6.f90	(revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/random_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/random_7.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/random_7.f90	(revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/random_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/random_4.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/random_4.f90	(revision 0)
@@ -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

[gfortran,patch] Fix RANDOM_SEED: optional arguments and -fdefault-integer-8

[Thomas Koenig]

:REVIEWMAIL:

Hi FX,

your patch regtests fine on i686-pc-linux-gnu.  OK to commit.  Thanks!

(Strangely, your message didn't make it into my inbox, which is why
I am forced to break thread here.  Maybe my provider's spam filter
is acting up...)

	Thomas