summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog13
-rw-r--r--gcc/fortran/check.c31
-rw-r--r--gcc/fortran/intrinsic.c5
-rw-r--r--gcc/fortran/intrinsic.h1
-rw-r--r--gcc/fortran/iresolve.c10
-rw-r--r--gcc/fortran/trans-expr.c52
-rw-r--r--gcc/testsuite/ChangeLog9
-rw-r--r--gcc/testsuite/gfortran.dg/random_4.f9019
-rw-r--r--gcc/testsuite/gfortran.dg/random_5.f9017
-rw-r--r--gcc/testsuite/gfortran.dg/random_6.f9015
-rw-r--r--gcc/testsuite/gfortran.dg/random_7.f9020
-rw-r--r--libgfortran/ChangeLog12
-rw-r--r--libgfortran/gfortran.map3
-rw-r--r--libgfortran/intrinsics/random.c81
-rw-r--r--libgfortran/libgfortran.h9
-rw-r--r--libgfortran/runtime/main.c2
16 files changed, 248 insertions, 51 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
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 <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>
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 <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);
- 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_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
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);
}
View Lorry Controller Status