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 +#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_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