From: fxcoudert Date: Sun, 12 Aug 2007 20:45:29 +0000 (+0000) Subject: PR fortran/30964 X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=3d3b790db32448aed311a1df5c182f639ee7ec97 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127383 138bc75d-0d04-0410-961f-82ee72b054a4 --- 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 + 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 + 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 + 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 + 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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 13c6f283939..1d4055b02e1 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,15 @@ +2007-08-12 Francois-Xavier Coudert + + 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 Tobias Burnus diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 8cfc23670b7..31ca41e9f88 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -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; diff --git a/libgfortran/intrinsics/random.c b/libgfortran/intrinsics/random.c index 9a31a0e2995..f64f21c5b80 100644 --- a/libgfortran/intrinsics/random.c +++ b/libgfortran/intrinsics/random.c @@ -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 and Steve Kargl. @@ -32,6 +32,7 @@ Boston, MA 02110-1301, USA. */ #include "config.h" #include "libgfortran.h" #include +#include 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; idata[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 diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 06718013cc8..ce6d28e9f95 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -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 */ diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c index 570e9591213..87adcd228ce 100644 --- a/libgfortran/runtime/main.c +++ b/libgfortran/runtime/main.c @@ -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); }