aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog16
-rw-r--r--gcc/fortran/check.c91
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/intrinsic.c22
-rw-r--r--gcc/fortran/intrinsic.h6
-rw-r--r--gcc/fortran/intrinsic.texi114
-rw-r--r--gcc/fortran/iresolve.c83
-rw-r--r--gcc/fortran/trans-intrinsic.c1
-rw-r--r--libgfortran/ChangeLog11
-rw-r--r--libgfortran/Makefile.am1
-rw-r--r--libgfortran/Makefile.in19
-rw-r--r--libgfortran/config.h.in6
-rwxr-xr-xlibgfortran/configure4
-rw-r--r--libgfortran/configure.ac2
-rw-r--r--libgfortran/intrinsics/signal.c170
15 files changed, 534 insertions, 13 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:
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 6d47929..6311d64 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,4 +1,13 @@
-2005-10-20 Francois-Xavier Coudert <coudert@clipper.ens.fr>
+2005-10-28 Francois-Xavier Coudert <coudert@clipper.ens.fr>
+
+ * 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.
+
+2005-10-28 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* acinclude.m4 (LIBGFOR_CHECK_FPSETMASK): New check.
* configure.ac: Check for floatingpoint.h, fptrap.h and float.h
diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am
index f5a1869..b47b768 100644
--- a/libgfortran/Makefile.am
+++ b/libgfortran/Makefile.am
@@ -66,6 +66,7 @@ intrinsics/link.c \
intrinsics/mvbits.c \
intrinsics/pack_generic.c \
intrinsics/perror.c \
+intrinsics/signal.c \
intrinsics/size.c \
intrinsics/sleep.c \
intrinsics/spread_generic.c \
diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in
index 5ed436f..256fe1d 100644
--- a/libgfortran/Makefile.in
+++ b/libgfortran/Makefile.in
@@ -169,13 +169,14 @@ am__objects_33 = associated.lo abort.lo args.lo bessel.lo \
date_and_time.lo env.lo erf.lo eoshift0.lo eoshift2.lo \
etime.lo exit.lo flush.lo fnum.lo gerror.lo getcwd.lo \
getlog.lo getXid.lo hyper.lo hostnm.lo kill.lo ierrno.lo \
- ishftc.lo link.lo mvbits.lo pack_generic.lo perror.lo size.lo \
- sleep.lo spread_generic.lo string_intrinsics.lo system.lo \
- rand.lo random.lo rename.lo reshape_generic.lo \
- reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
- stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
- tty.lo umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
- in_unpack_generic.lo normalize.lo
+ ishftc.lo link.lo mvbits.lo pack_generic.lo perror.lo \
+ signal.lo size.lo sleep.lo spread_generic.lo \
+ string_intrinsics.lo system.lo rand.lo random.lo rename.lo \
+ reshape_generic.lo reshape_packed.lo selected_int_kind.lo \
+ selected_real_kind.lo stat.lo symlnk.lo system_clock.lo \
+ time.lo transpose_generic.lo tty.lo umask.lo unlink.lo \
+ unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
+ normalize.lo
am__objects_34 =
am__objects_35 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
@@ -406,6 +407,7 @@ intrinsics/link.c \
intrinsics/mvbits.c \
intrinsics/pack_generic.c \
intrinsics/perror.c \
+intrinsics/signal.c \
intrinsics/size.c \
intrinsics/sleep.c \
intrinsics/spread_generic.c \
@@ -2298,6 +2300,9 @@ pack_generic.lo: intrinsics/pack_generic.c
perror.lo: intrinsics/perror.c
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o perror.lo `test -f 'intrinsics/perror.c' || echo '$(srcdir)/'`intrinsics/perror.c
+signal.lo: intrinsics/signal.c
+ $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o signal.lo `test -f 'intrinsics/signal.c' || echo '$(srcdir)/'`intrinsics/signal.c
+
size.lo: intrinsics/size.c
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o size.lo `test -f 'intrinsics/size.c' || echo '$(srcdir)/'`intrinsics/size.c
diff --git a/libgfortran/config.h.in b/libgfortran/config.h.in
index 13fc81f..6dc11a1 100644
--- a/libgfortran/config.h.in
+++ b/libgfortran/config.h.in
@@ -21,6 +21,9 @@
/* libm includes acosl */
#undef HAVE_ACOSL
+/* Define to 1 if you have the `alarm' function. */
+#undef HAVE_ALARM
+
/* libm includes asin */
#undef HAVE_ASIN
@@ -474,6 +477,9 @@
/* libm includes scalbnl */
#undef HAVE_SCALBNL
+/* Define to 1 if you have the `signal' function. */
+#undef HAVE_SIGNAL
+
/* Define to 1 if you have the <signal.h> header file. */
#undef HAVE_SIGNAL_H
diff --git a/libgfortran/configure b/libgfortran/configure
index fd7ee1f..b5bcafaf 100755
--- a/libgfortran/configure
+++ b/libgfortran/configure
@@ -7519,7 +7519,9 @@ done
-for ac_func in sleep time ttyname
+
+
+for ac_func in sleep time ttyname signal alarm
do
as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh`
echo "$as_me:$LINENO: checking for $ac_func" >&5
diff --git a/libgfortran/configure.ac b/libgfortran/configure.ac
index 73b34c0..1808455 100644
--- a/libgfortran/configure.ac
+++ b/libgfortran/configure.ac
@@ -169,7 +169,7 @@ AC_CHECK_MEMBERS([struct stat.st_rdev])
# Check for library functions.
AC_CHECK_FUNCS(getrusage times mkstemp strtof strtold snprintf ftruncate chsize)
AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror)
-AC_CHECK_FUNCS(sleep time ttyname)
+AC_CHECK_FUNCS(sleep time ttyname signal alarm)
# Check libc for getgid, getpid, getuid
AC_CHECK_LIB([c],[getgid],[AC_DEFINE([HAVE_GETGID],[1],[libc includes getgid])])
diff --git a/libgfortran/intrinsics/signal.c b/libgfortran/intrinsics/signal.c
new file mode 100644
index 0000000..9e40358
--- /dev/null
+++ b/libgfortran/intrinsics/signal.c
@@ -0,0 +1,170 @@
+/* Implementation of the SIGNAL and ALARM g77 intrinsics
+ Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public
+License along with libgfortran; see the file COPYING. If not,
+write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "config.h"
+#include "libgfortran.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+#include <errno.h>
+
+/* SIGNAL subroutine with PROCEDURE as handler */
+extern void signal_sub (int *, void (*)(int), int *);
+iexport_proto(signal_sub);
+
+void
+signal_sub (int *number, void (*handler)(int), int *status)
+{
+#ifdef HAVE_SIGNAL
+ if (status != NULL)
+ *status = (int) signal (*number, handler);
+ else
+ signal (*number, handler);
+#else
+ errno = ENOSYS;
+ if (status != NULL)
+ *status = -1;
+#endif
+}
+iexport(signal_sub);
+
+
+/* SIGNAL subroutine with INTEGER as handler */
+extern void signal_sub_int (int *, int *, int *);
+iexport_proto(signal_sub_int);
+
+void
+signal_sub_int (int *number, int *handler, int *status)
+{
+#ifdef HAVE_SIGNAL
+ if (status != NULL)
+ *status = (int) signal (*number, (void (*)(int)) *handler);
+ else
+ signal (*number, (void (*)(int)) *handler);
+#else
+ errno = ENOSYS;
+ if (status != NULL)
+ *status = -1;
+#endif
+}
+iexport(signal_sub_int);
+
+
+/* SIGNAL function with PROCEDURE as handler */
+extern int signal_func (int *, void (*)(int));
+iexport_proto(signal_func);
+
+int
+signal_func (int *number, void (*handler)(int))
+{
+ int status;
+ signal_sub (number, handler, &status);
+ return status;
+}
+iexport(signal_func);
+
+
+/* SIGNAL function with INTEGER as handler */
+extern int signal_func_int (int *, int *);
+iexport_proto(signal_func_int);
+
+int
+signal_func_int (int *number, int *handler)
+{
+ int status;
+ signal_sub_int (number, handler, &status);
+ return status;
+}
+iexport(signal_func_int);
+
+
+
+/* ALARM intrinsic with PROCEDURE as handler */
+extern void alarm_sub (int *, void (*)(int), int *);
+iexport_proto(alarm_sub);
+
+void
+alarm_sub (int *seconds, void (*handler)(int), int *status)
+{
+#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL)
+ if (status != NULL)
+ {
+ if (signal (SIGALRM, handler) == SIG_ERR)
+ *status = -1;
+ else
+ *status = alarm (*seconds);
+ }
+ else
+ {
+ signal (SIGALRM, handler);
+ alarm (*seconds);
+ }
+#else
+ errno = ENOSYS;
+ if (status != NULL)
+ *status = -1;
+#endif
+}
+iexport(alarm_sub);
+
+
+/* ALARM intrinsic with INTEGER as handler */
+extern void alarm_sub_int (int *, int *, int *);
+iexport_proto(alarm_sub_int);
+
+void
+alarm_sub_int (int *seconds, int *handler, int *status)
+{
+#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL)
+ if (status != NULL)
+ {
+ if (signal (SIGALRM, (void (*)(int)) handler) == SIG_ERR)
+ *status = -1;
+ else
+ *status = alarm (*seconds);
+ }
+ else
+ {
+ signal (SIGALRM, (void (*)(int)) handler);
+ alarm (*seconds);
+ }
+#else
+ errno = ENOSYS;
+ if (status != NULL)
+ *status = -1;
+#endif
+}
+iexport(alarm_sub_int);
+
generated by cgit v1.1 at 2024-07-02 07:03:29 +0000