OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
Francois-Xavier Coudert 2007-08-12 20:45:29 +00:00 committed by François-Xavier Coudert
parent 096f0d9dbc
commit 34b4bc5c61
16 changed files with 250 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -1,3 +1,16 @@
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

31
gcc/fortran/check.c
View File

@ -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;
}

5
gcc/fortran/intrinsic.c
View File

@ -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);

1
gcc/fortran/intrinsic.h
View File

@ -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 *);

10
gcc/fortran/iresolve.c
View File

@ -2506,6 +2506,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)
{

56
gcc/fortran/trans-expr.c
View File

@ -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
&& 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;
}
}
if (need_interface_mapping)
gfc_add_interface_mapping (&mapping, fsym, &parmse);
/* 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)
{
gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
}
}
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);

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
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

19
gcc/testsuite/gfortran.dg/random_4.f90 Normal file
View File

@ -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

17
gcc/testsuite/gfortran.dg/random_5.f90 Normal file
View File

@ -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.*" }

15
gcc/testsuite/gfortran.dg/random_6.f90 Normal file
View File

@ -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

20
gcc/testsuite/gfortran.dg/random_7.f90 Normal file
View File

@ -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

12
libgfortran/ChangeLog
View File

@ -1,3 +1,15 @@
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-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>

3
libgfortran/gfortran.map
View File

@ -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;

81
libgfortran/intrinsics/random.c
View File

@ -1,5 +1,5 @@
/* Implementation of the RANDOM intrinsics
Copyright 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
Copyright 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
Contributed by Lars Segerlund <seger@linuxmail.org>
and Steve Kargl.
@ -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);
/* 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)
{
/* From the standard: "If no argument is present, the processor assigns
a processor-dependent value to the seed." */
for (i=0; i<kiss_size; i++)
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_array_i4 *put, gfc_array_i4 *get)
/* 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_array_i4 *put, gfc_array_i4 *get)
__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

9
libgfortran/libgfortran.h
View File

@ -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 */

2
libgfortran/runtime/main.c
View File

@ -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);
}