diff options
author | Francois-Xavier Coudert <coudert@clipper.ens.fr> | 2005-10-28 23:16:17 +0200 |
---|---|---|
committer | François-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2005-10-28 21:16:17 +0000 |
commit | 185d7d97506315bcf48bae38d410f68af50eba4a (patch) | |
tree | fc0a4e0d2fc0100ea5d8070de286cf8217cb2dc9 /gcc/fortran/check.c | |
parent | 7f0dbff3607628e68395992ac86e3e659c7e1b09 (diff) | |
download | gcc-185d7d97506315bcf48bae38d410f68af50eba4a.zip gcc-185d7d97506315bcf48bae38d410f68af50eba4a.tar.gz gcc-185d7d97506315bcf48bae38d410f68af50eba4a.tar.bz2 |
check.c (gfc_check_alarm_sub, [...]): New functions.
* 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.
* Makefile.am (intrinsics): Add signal.c.
* Makefile.in: Regenerate.
* configure.ac: Checks for signal and alarm.
* config.h.in: Regenerate.
* configure: Regenerate.
* intrinsics/signal.c: New file for SIGNAL and ALARM intrinsics.
From-SVN: r105967
Diffstat (limited to 'gcc/fortran/check.c')
-rw-r--r-- | gcc/fortran/check.c | 91 |
1 files changed, 91 insertions, 0 deletions
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) |