diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 16 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 91 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 6 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 114 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.c | 83 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 1 |
8 files changed, 331 insertions, 3 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f31943c..046cb44 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2005-10-28 Francois-Xavier Coudert <coudert@clipper.ens.fr> + + * check.c (gfc_check_alarm_sub, gfc_check_signal, + gfc_check_signal_sub): New functions. + * gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SIGNAL. + * intrinsic.c (add_functions): Add signal intrinsic. + (add_subroutines): Add signal and alarm intrinsics. + * intrinsic.texi: Document the new intrinsics. + * iresolve.c (gfc_resolve_signal, gfc_resolve_alarm_sub, + gfc_resolve_signal_sub): New functions. + * trans-intrinsic.c (gfc_conv_intrinsic_function): Add case + for GFC_ISYM_SIGNAL. + * intrinsic.h: Add prototypes for gfc_check_alarm_sub, + gfc_check_signal, gfc_check_signal_sub, gfc_resolve_signal, + gfc_resolve_alarm_sub, gfc_resolve_signal_sub. + 2005-10-28 Steven Bosscher <stevenb@suse.de> PR fortran/24545 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 25601f7..d5218d3 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2430,6 +2430,40 @@ gfc_check_irand (gfc_expr * x) return SUCCESS; } + +try +gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status) +{ + if (scalar_check (seconds, 0) == FAILURE) + return FAILURE; + + if (type_check (seconds, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) + { + gfc_error ( + "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where); + return FAILURE; + } + + if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (scalar_check (status, 2) == FAILURE) + return FAILURE; + + if (type_check (status, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + try gfc_check_rand (gfc_expr * x) { @@ -2722,6 +2756,63 @@ gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status) try +gfc_check_signal (gfc_expr * number, gfc_expr * handler) +{ + if (scalar_check (number, 0) == FAILURE) + return FAILURE; + + if (type_check (number, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) + { + gfc_error ( + "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where); + return FAILURE; + } + + if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status) +{ + if (scalar_check (number, 0) == FAILURE) + return FAILURE; + + if (type_check (number, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE) + { + gfc_error ( + "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where); + return FAILURE; + } + + if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE) + return FAILURE; + + if (status == NULL) + return SUCCESS; + + if (type_check (status, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (status, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status) { if (type_check (cmd, 0, BT_CHARACTER) == FAILURE) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 56d008c..54bce8f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -392,6 +392,7 @@ enum gfc_generic_isym_id GFC_ISYM_SHAPE, GFC_ISYM_SI_KIND, GFC_ISYM_SIGN, + GFC_ISYM_SIGNAL, GFC_ISYM_SIN, GFC_ISYM_SINH, GFC_ISYM_SIZE, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 93dde15..d414a05 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -871,7 +871,8 @@ add_functions (void) *s = "s", *dm = "dim", *kind = "kind", *msk = "mask", *x = "x", *sh = "shift", *stg = "string", *ssg = "substring", *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b", - *z = "z", *ln = "len", *ut = "unit"; + *z = "z", *ln = "len", *ut = "unit", *han = "handler", + *num = "number"; int di, dr, dd, dl, dc, dz, ii; @@ -1916,6 +1917,12 @@ add_functions (void) make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77); + add_sym_2 ("signal", 1, 1, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_signal, NULL, gfc_resolve_signal, + num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU); + add_sym_1 ("sin", 1, 1, BT_REAL, dr, GFC_STD_F77, gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin, x, BT_REAL, dr, REQUIRED); @@ -2121,7 +2128,8 @@ add_subroutines (void) *f = "from", *sz = "size", *ln = "len", *cr = "count_rate", *com = "command", *length = "length", *st = "status", *val = "value", *num = "number", *name = "name", - *trim_name = "trim_name", *ut = "unit"; + *trim_name = "trim_name", *ut = "unit", *han = "handler", + *sec = "seconds"; int di, dr, dc, dl; @@ -2217,6 +2225,11 @@ add_subroutines (void) gt, BT_INTEGER, di, OPTIONAL); /* More G77 compatibility garbage. */ + add_sym_3s ("alarm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub, + sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED, + st, BT_INTEGER, di, OPTIONAL); + add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand, c, BT_INTEGER, 4, REQUIRED); @@ -2267,6 +2280,11 @@ add_subroutines (void) name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL); + add_sym_3s ("signal", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_signal_sub, NULL, gfc_resolve_signal_sub, + num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED, + st, BT_INTEGER, di, OPTIONAL); + add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub, name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 950ac7d..556c6e4 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -109,6 +109,7 @@ 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_signal (gfc_expr *, gfc_expr *); try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_srand (gfc_expr *); try gfc_check_stat (gfc_expr *, gfc_expr *); @@ -126,6 +127,7 @@ try gfc_check_x (gfc_expr *); /* Intrinsic subroutines. */ +try gfc_check_alarm_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_chdir_sub (gfc_expr *, gfc_expr *); try gfc_check_cpu_time (gfc_expr *); try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *); @@ -147,6 +149,7 @@ try gfc_check_perror (gfc_expr *); try gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_link_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_sleep_sub (gfc_expr *); try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_system_sub (gfc_expr *, gfc_expr *); @@ -360,6 +363,7 @@ 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 *); +void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sin (gfc_expr *, gfc_expr *); void gfc_resolve_sinh (gfc_expr *, gfc_expr *); void gfc_resolve_spacing (gfc_expr *, gfc_expr *); @@ -385,6 +389,7 @@ void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); /* Intrinsic subroutine resolution. */ +void gfc_resolve_alarm_sub (gfc_code *); void gfc_resolve_chdir_sub (gfc_code *); void gfc_resolve_cpu_time (gfc_code *); void gfc_resolve_exit (gfc_code *); @@ -405,6 +410,7 @@ void gfc_resolve_random_number (gfc_code *); void gfc_resolve_rename_sub (gfc_code *); void gfc_resolve_link_sub (gfc_code *); void gfc_resolve_symlnk_sub (gfc_code *); +void gfc_resolve_signal_sub (gfc_code *); void gfc_resolve_sleep_sub (gfc_code *); void gfc_resolve_stat_sub (gfc_code *); void gfc_resolve_system_clock (gfc_code *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 5db2472..e731fbd 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -41,6 +41,7 @@ and editing. All contributions and corrections are strongly encouraged. * @code{ADJUSTR}: ADJUSTR, Right adjust a string * @code{AIMAG}: AIMAG, Imaginary part of complex number * @code{AINT}: AINT, Truncate to a whole number +* @code{ALARM}: ALARM, Set an alarm clock * @code{ALL}: ALL, Determine if all values are true * @code{ALLOCATED}: ALLOCATED, Status of allocatable entity * @code{ANINT}: ANINT, Nearest whole number @@ -91,9 +92,10 @@ and editing. All contributions and corrections are strongly encouraged. * @code{LOG}: LOG, Logarithm function * @code{LOG10}: LOG10, Base 10 logarithm function * @code{REAL}: REAL, Convert to real type -* @code{SQRT}: SQRT, Square-root function +* @code{SIGNAL}: SIGNAL, Signal handling subroutine (or function) * @code{SIN}: SIN, Sine function * @code{SINH}: SINH, Hyperbolic sine function +* @code{SQRT}: SQRT, Square-root function * @code{TAN}: TAN, Tangent function * @code{TANH}: TANH, Hyperbolic tangent function @end menu @@ -512,6 +514,57 @@ end program test_aint +@node ALARM +@section @code{ALARM} --- Execute a routine after a given delay +@findex @code{ALARM} intrinsic +@cindex + +@table @asis +@item @emph{Description}: +@code{ALARM(SECONDS [, STATUS])} causes external subroutine @var{HANDLER} +to be executed after a delay of @var{SECONDS} by using @code{alarm(1)} to +set up a signal and @code{signal(2)} to catch it. If @var{STATUS} is +supplied, it will be returned with the number of seconds remaining until +any previously scheduled alarm was due to be delivered, or zero if there +was no previously scheduled alarm. + +@item @emph{Option}: +gnu + +@item @emph{Class}: +subroutine + +@item @emph{Syntax}: +@code{CALL ALARM(SECONDS, HANDLER)} +@code{CALL ALARM(SECONDS, HANDLER, STATUS)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{SECONDS} @tab The type of the argument shall be a scalar +@code{INTEGER}. It is @code{INTENT(IN)}. +@item @var{HANDLER} @tab Signal handler (@code{INTEGER FUNCTION} or +@code{SUBROUTINE}) or dummy/global @code{INTEGER} scalar. +@code{INTEGER}. It is @code{INTENT(IN)}. +@item @var{STATUS} @tab (Optional) @var{STATUS} shall be a scalar +@code{INTEGER} variable. It is @code{INTENT(OUT)}. +@end multitable + +@item @emph{Example}: +@smallexample +program test_alarm + external handler_print + integer i + call alarm (3, handler_print, i) + print *, i + call sleep(10) +end program test_alarm +@end smallexample +This will cause the external routine @var{handler_print} to be called +after 3 seconds. +@end table + + + @node ALL @section @code{ALL} --- All values in @var{MASK} along @var{DIM} are true @findex @code{ALL} intrinsic @@ -2925,6 +2978,65 @@ program test_real @end table + +@node SIGNAL +@section @code{SIGNAL} --- Signal handling subroutine (or function) +@findex @code{SIGNAL} intrinsic +@cindex SIGNAL subroutine + +@table @asis +@item @emph{Description}: +@code{SIGNAL(NUMBER, HANDLER [, STATUS])} causes external subroutine +@var{HANDLER} to be executed with a single integer argument when signal +@var{NUMBER} occurs. If @var{HANDLER} is an integer, it can be used to +turn off handling of signal @var{NUMBER} or revert to its default +action. See @code{signal(2)}. + +If @code{SIGNAL} is called as a subroutine and the @var{STATUS} argument +is supplied, it is set to the value returned by @code{signal(2)}. + +@item @emph{Option}: +gnu + +@item @emph{Class}: +subroutine, non-elemental function + +@item @emph{Syntax}: +@multitable @columnfractions .30 .80 +@item @code{CALL ALARM(NUMBER, HANDLER)} +@item @code{CALL ALARM(NUMBER, HANDLER, STATUS)} +@item @code{STATUS = ALARM(NUMBER, HANDLER)} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item @var{NUMBER} @tab shall be a scalar integer, with @code{INTENT(IN)} +@item @var{HANDLER}@tab Signal handler (@code{INTEGER FUNCTION} or +@code{SUBROUTINE}) or dummy/global @code{INTEGER} scalar. +@code{INTEGER}. It is @code{INTENT(IN)}. +@item @var{STATUS} @tab (Optional) @var{STATUS} shall be a scalar +integer. It has @code{INTENT(OUT)}. +@end multitable + +@item @emph{Return value}: +The @code{SIGNAL} functions returns the value returned by @code{signal(2)}. + +@item @emph{Example}: +@smallexample +program test_signal + intrinsic signal + external handler_print + + call signal (12, handler_print) + call signal (10, 1) + + call sleep (30) +end program test_signal +@end smallexample +@end table + + + @node SIN @section @code{SIN} --- Sine function @findex @code{SIN} intrinsic diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 09d85e3..ae55aa7 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1392,6 +1392,27 @@ gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED) void +gfc_resolve_signal (gfc_expr * f, gfc_expr *number, gfc_expr *handler) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &f->ts, 2); + f->value.function.name = gfc_get_string (PREFIX("signal_func_int")); + } + else + f->value.function.name = gfc_get_string (PREFIX("signal_func")); + + if (number->ts.kind != gfc_c_int_kind) + gfc_convert_type (number, &f->ts, 2); +} + + +void gfc_resolve_sin (gfc_expr * f, gfc_expr * x) { f->ts = x->ts; @@ -1701,6 +1722,37 @@ gfc_resolve_verify (gfc_expr * f, gfc_expr * string, /* Intrinsic subroutine resolution. */ void +gfc_resolve_alarm_sub (gfc_code * c) +{ + const char *name; + gfc_expr *seconds, *handler, *status; + gfc_typespec ts; + + seconds = c->ext.actual->expr; + handler = c->ext.actual->next->expr; + status = c->ext.actual->next->next->expr; + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &ts, 2); + name = gfc_get_string (PREFIX("alarm_sub_int")); + } + else + name = gfc_get_string (PREFIX("alarm_sub")); + + if (seconds->ts.kind != gfc_c_int_kind) + gfc_convert_type (seconds, &ts, 2); + if (status != NULL && status->ts.kind != gfc_c_int_kind) + gfc_convert_type (status, &ts, 2); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +void gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED) { const char *name; @@ -1926,6 +1978,37 @@ gfc_resolve_get_environment_variable (gfc_code * code) code->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } +void +gfc_resolve_signal_sub (gfc_code * c) +{ + const char *name; + gfc_expr *number, *handler, *status; + gfc_typespec ts; + + number = c->ext.actual->expr; + handler = c->ext.actual->next->expr; + status = c->ext.actual->next->next->expr; + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &ts, 2); + name = gfc_get_string (PREFIX("signal_sub_int")); + } + else + name = gfc_get_string (PREFIX("signal_sub")); + + if (number->ts.kind != gfc_c_int_kind) + gfc_convert_type (number, &ts, 2); + if (status != NULL && status->ts.kind != gfc_c_int_kind) + gfc_convert_type (status, &ts, 2); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + /* Resolve the SYSTEM intrinsic subroutine. */ void diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4905ac5..d14688b 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -3100,6 +3100,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_RAND: case GFC_ISYM_RENAME: case GFC_ISYM_SECOND: + case GFC_ISYM_SIGNAL: case GFC_ISYM_STAT: case GFC_ISYM_SYMLNK: case GFC_ISYM_SYSTEM: |