From 2bd749490845f2edc7de74dca4b29fd7d7698dff Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sat, 12 Jun 2004 17:34:47 +0000 Subject: check.c (gfc_check_second_sub, [...]): New functions. * check.c (gfc_check_second_sub, gfc_check_irand, gfc_check_rand gfc_check_srand, gfc_check_etime, gfc_check_etime_sub): New functions. * gfortran.h (gfc_generic_isym_id): New symbols GFC_ISYM_ETIME, GFC_ISYM_IRAND, GFC_ISYM_RAND, GFC_ISYM_SECOND. * trans-intrinsic.c: Use symbols. * intrinsic.c (add_sym_2s): New function. * intrinsic.c: Add etime, dtime, irand, rand, second, srand. * intrinsic.h: Function prototypes. * iresolve.c (gfc_resolve_etime_sub, gfc_resolve_second_sub gfc_resolve_srand): New functions. libgfortran * Makefile.am: Add rand.c and etime.c * Makefile.in: Regenerated. * aclocal.in: Regenerated. * cpu_time.c (second_sub, second): New functions. * rand.c (irand, rand, srand): New file. * etime.c (etime_sub, etime): New file. From-SVN: r83034 --- gcc/fortran/ChangeLog | 13 +++++ gcc/fortran/check.c | 113 ++++++++++++++++++++++++++++++++++++++++++ gcc/fortran/gfortran.h | 4 ++ gcc/fortran/intrinsic.c | 76 ++++++++++++++++++++++++++++ gcc/fortran/intrinsic.h | 11 +++- gcc/fortran/iresolve.c | 37 +++++++++++++- gcc/fortran/trans-intrinsic.c | 4 ++ 7 files changed, 256 insertions(+), 2 deletions(-) (limited to 'gcc/fortran') diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a823c8a..e1cf74e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2004-06-12 Steven G. Kargl + + * check.c (gfc_check_second_sub, gfc_check_irand, gfc_check_rand + gfc_check_srand, gfc_check_etime, gfc_check_etime_sub): New functions. + * gfortran.h (gfc_generic_isym_id): New symbols GFC_ISYM_ETIME, + GFC_ISYM_IRAND, GFC_ISYM_RAND, GFC_ISYM_SECOND. + * trans-intrinsic.c: Use symbols. + * intrinsic.c (add_sym_2s): New function. + * intrinsic.c: Add etime, dtime, irand, rand, second, srand. + * intrinsic.h: Function prototypes. + * iresolve.c (gfc_resolve_etime_sub, gfc_resolve_second_sub + gfc_resolve_srand): New functions. + 2004-06-12 Tobias Schlueter PR fortran/14957 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 007f8d9..cbf3d9d 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1877,6 +1877,23 @@ gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get) return SUCCESS; } +try +gfc_check_second_sub (gfc_expr * time) +{ + + if (scalar_check (time, 0) == FAILURE) + return FAILURE; + + if (type_check (time, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (kind_value_check(time, 0, 4) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note, count, count_rate, and count_max are all optional arguments */ @@ -1935,3 +1952,99 @@ gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate, return SUCCESS; } + +try +gfc_check_irand (gfc_expr * x) +{ + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + if (type_check (x, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind_value_check(x, 0, 4) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +try +gfc_check_rand (gfc_expr * x) +{ + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + if (type_check (x, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind_value_check(x, 0, 4) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +try +gfc_check_srand (gfc_expr * x) +{ + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + if (type_check (x, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind_value_check(x, 0, 4) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +try +gfc_check_etime (gfc_expr * x) +{ + if (array_check (x, 0) == FAILURE) + return FAILURE; + + if (rank_check (x, 0, 1) == FAILURE) + return FAILURE; + + if (variable_check (x, 0) == FAILURE) + return FAILURE; + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (kind_value_check(x, 0, 4) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +try +gfc_check_etime_sub (gfc_expr * values, gfc_expr * time) +{ + if (array_check (values, 0) == FAILURE) + return FAILURE; + + if (rank_check (values, 0, 1) == FAILURE) + return FAILURE; + + if (variable_check (values, 0) == FAILURE) + return FAILURE; + + if (type_check (values, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (kind_value_check(values, 0, 4) == FAILURE) + return FAILURE; + + if (scalar_check (time, 1) == FAILURE) + return FAILURE; + + if (type_check (time, 1, BT_REAL) == FAILURE) + return FAILURE; + + if (kind_value_check(time, 1, 4) == FAILURE) + return FAILURE; + + return SUCCESS; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c82483e..a533b1c 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -301,6 +301,7 @@ enum gfc_generic_isym_id GFC_ISYM_DOT_PRODUCT, GFC_ISYM_DPROD, GFC_ISYM_EOSHIFT, + GFC_ISYM_ETIME, GFC_ISYM_EXP, GFC_ISYM_EXPONENT, GFC_ISYM_FLOOR, @@ -315,6 +316,7 @@ enum gfc_generic_isym_id GFC_ISYM_INDEX, GFC_ISYM_INT, GFC_ISYM_IOR, + GFC_ISYM_IRAND, GFC_ISYM_ISHFT, GFC_ISYM_ISHFTC, GFC_ISYM_LBOUND, @@ -343,12 +345,14 @@ enum gfc_generic_isym_id GFC_ISYM_PACK, GFC_ISYM_PRESENT, GFC_ISYM_PRODUCT, + GFC_ISYM_RAND, GFC_ISYM_REAL, GFC_ISYM_REPEAT, GFC_ISYM_RESHAPE, GFC_ISYM_RRSPACING, GFC_ISYM_SCALE, GFC_ISYM_SCAN, + GFC_ISYM_SECOND, GFC_ISYM_SET_EXPONENT, GFC_ISYM_SHAPE, GFC_ISYM_SI_KIND, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 95e208f..7247d89 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -429,6 +429,32 @@ static void add_sym_2 (const char *name, int elemental, int actual_ok, bt type, } +/* Add the name of an intrinsic subroutine with two arguments to the list + of intrinsic names. */ + +static void add_sym_2s (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *,gfc_expr *,gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *), + void (*resolve)(gfc_code *), + const char* a1, bt type1, int kind1, int optional1, + const char* a2, bt type2, int kind2, int optional2 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3 = check; + sf.f3 = simplify; + rf.s1 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + a2, type2, kind2, optional2, + (void*)0); +} + + static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type, int kind, try (*check)(gfc_expr *,gfc_expr *,gfc_expr *), @@ -989,6 +1015,16 @@ add_functions (void) make_generic ("epsilon", GFC_ISYM_NONE); + /* G77 compatibility */ + add_sym_1 ("etime", 0, 1, BT_REAL, 4, + gfc_check_etime, NULL, NULL, + x, BT_REAL, 4, 0); + + make_alias ("dtime"); + + make_generic ("etime", GFC_ISYM_ETIME); + + add_sym_1 ("exp", 1, 1, BT_REAL, dr, NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_REAL, dr, 0); @@ -1098,6 +1134,13 @@ add_functions (void) make_generic ("ior", GFC_ISYM_IOR); + /* The following function is for G77 compatibility. */ + add_sym_1 ("irand", 0, 1, BT_INTEGER, 4, + gfc_check_irand, NULL, NULL, + i, BT_INTEGER, 4, 0); + + make_generic ("irand", GFC_ISYM_IRAND); + add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft, i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0); @@ -1386,6 +1429,13 @@ add_functions (void) make_generic ("radix", GFC_ISYM_NONE); + /* The following function is for G77 compatibility. */ + add_sym_1 ("rand", 0, 1, BT_REAL, 4, + gfc_check_rand, NULL, NULL, + i, BT_INTEGER, 4, 0); + + make_generic ("rand", GFC_ISYM_RAND); + add_sym_1 ("range", 0, 1, BT_INTEGER, di, gfc_check_range, gfc_simplify_range, NULL, x, BT_REAL, dr, 0); @@ -1436,6 +1486,11 @@ add_functions (void) make_generic ("scan", GFC_ISYM_SCAN); + /* Added for G77 compatibility garbage. */ + add_sym_0 ("second", 0, 1, BT_REAL, 4, NULL, NULL, NULL); + + make_generic ("second", GFC_ISYM_SECOND); + add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di, NULL, gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, 0); @@ -1606,6 +1661,8 @@ add_functions (void) bck, BT_LOGICAL, dl, 1); make_generic ("verify", GFC_ISYM_VERIFY); + + } @@ -1634,11 +1691,25 @@ add_subroutines (void) gfc_check_cpu_time, NULL, gfc_resolve_cpu_time, tm, BT_REAL, dr, 0); + /* More G77 compatibility garbage. */ + add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, + gfc_check_second_sub, NULL, gfc_resolve_second_sub, + tm, BT_REAL, dr, 0); + add_sym_4 ("date_and_time", 0, 1, BT_UNKNOWN, 0, gfc_check_date_and_time, NULL, NULL, dt, BT_CHARACTER, dc, 1, tm, BT_CHARACTER, dc, 1, zn, BT_CHARACTER, dc, 1, vl, BT_INTEGER, di, 1); + /* More G77 compatibility garbage. */ + add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0, + gfc_check_etime_sub, NULL, gfc_resolve_etime_sub, + vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0); + + add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0, + gfc_check_etime_sub, NULL, gfc_resolve_etime_sub, + vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0); + add_sym_2 ("getarg", 0, 1, BT_UNKNOWN, 0, NULL, NULL, NULL, c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0); @@ -1659,6 +1730,11 @@ add_subroutines (void) sz, BT_INTEGER, di, 1, pt, BT_INTEGER, di, 1, gt, BT_INTEGER, di, 1); + /* More G77 compatibility garbage. */ + add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, + gfc_check_srand, NULL, gfc_resolve_srand, + c, BT_INTEGER, 4, 0); + add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0, gfc_check_system_clock, NULL, gfc_resolve_system_clock, c, BT_INTEGER, di, 1, cr, BT_INTEGER, di, 1, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index b2c0e78..ab26143 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -1,6 +1,6 @@ /* Header file for intrinsics check, resolve and simplify function prototypes. - Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb This file is part of GCC. @@ -44,6 +44,8 @@ try gfc_check_dble (gfc_expr *); try gfc_check_digits (gfc_expr *); try gfc_check_dot_product (gfc_expr *, gfc_expr *); try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_etime (gfc_expr *); +try gfc_check_etime_sub (gfc_expr *, gfc_expr *); try gfc_check_huge (gfc_expr *); try gfc_check_i (gfc_expr *); try gfc_check_iand (gfc_expr *, gfc_expr *); @@ -55,6 +57,7 @@ try gfc_check_ieor (gfc_expr *, gfc_expr *); try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_int (gfc_expr *, gfc_expr *); try gfc_check_ior (gfc_expr *, gfc_expr *); +try gfc_check_irand (gfc_expr *); try gfc_check_ishft (gfc_expr *, gfc_expr *); try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_kind (gfc_expr *); @@ -75,18 +78,21 @@ try gfc_check_precision (gfc_expr *); try gfc_check_present (gfc_expr *); try gfc_check_product (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_radix (gfc_expr *); +try gfc_check_rand (gfc_expr *); try gfc_check_range (gfc_expr *); try gfc_check_real (gfc_expr *, gfc_expr *); try gfc_check_repeat (gfc_expr *, gfc_expr *); try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_scale (gfc_expr *, gfc_expr *); try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_second_sub (gfc_expr *); try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *); try gfc_check_set_exponent (gfc_expr *, gfc_expr *); try gfc_check_shape (gfc_expr *); try gfc_check_size (gfc_expr *, gfc_expr *); try gfc_check_sign (gfc_expr *, gfc_expr *); try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_srand (gfc_expr *); try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_transpose (gfc_expr *); @@ -240,6 +246,7 @@ void gfc_resolve_dot_product (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_dprod (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_etime_sub (gfc_code *); void gfc_resolve_exp (gfc_expr *, gfc_expr *); void gfc_resolve_exponent (gfc_expr *, gfc_expr *); void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *); @@ -283,6 +290,7 @@ void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, void gfc_resolve_rrspacing (gfc_expr *, gfc_expr *); void gfc_resolve_scale (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_second_sub (gfc_code *); void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_shape (gfc_expr *, gfc_expr *); void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *); @@ -291,6 +299,7 @@ void gfc_resolve_sinh (gfc_expr *, gfc_expr *); void gfc_resolve_spacing (gfc_expr *, gfc_expr *); void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sqrt (gfc_expr *, gfc_expr *); +void gfc_resolve_srand (gfc_code *); void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_tan (gfc_expr *, gfc_expr *); void gfc_resolve_tanh (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index f1da732..2d8fffd 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1369,6 +1369,42 @@ gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED) name = gfc_get_string (PREFIX("arandom_r%d"), kind); c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); + +} + + +/* G77 compatibility subroutines etime() and dtime(). */ + +void +gfc_resolve_etime_sub (gfc_code * c) +{ + const char *name; + + name = gfc_get_string (PREFIX("etime_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility subroutine second(). */ + +void +gfc_resolve_second_sub (gfc_code * c) +{ + const char *name; + + name = gfc_get_string (PREFIX("second_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility function srand(). */ + +void +gfc_resolve_srand (gfc_code * c) +{ + const char *name; + name = gfc_get_string (PREFIX("srand")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } @@ -1393,7 +1429,6 @@ gfc_resolve_system_clock (gfc_code * c) c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } - void gfc_iresolve_init_1 (void) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 96eb306..e2c1b7e 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2867,6 +2867,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_DOT_PRODUCT: case GFC_ISYM_MATMUL: + case GFC_ISYM_IRAND: + case GFC_ISYM_RAND: + case GFC_ISYM_ETIME: + case GFC_ISYM_SECOND: gfc_conv_intrinsic_funcall (se, expr); break; -- cgit v1.1