This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [gfortran] add SIGNAL and ALARM intrinsics
I don't understand how you implemented the intrinsic
functions for signal.
Right. Sent the wrong version of the patch. Here it is.
Sorry,
FX
2005-10-15 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-15 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.
Index: gcc/fortran/check.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.34
diff -u -3 -p -r1.34 check.c
--- gcc/fortran/check.c 17 Sep 2005 18:57:59 -0000 1.34
+++ gcc/fortran/check.c 15 Oct 2005 08:35:07 -0000
@@ -2391,6 +2391,38 @@ 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)
+ {
+ must_be (handler, 1, "INTEGER or PROCEDURE");
+ 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)
{
@@ -2683,6 +2715,59 @@ gfc_check_unlink_sub (gfc_expr * name, g
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)
+ {
+ must_be (handler, 1, "INTEGER or PROCEDURE");
+ 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)
+ {
+ must_be (handler, 1, "INTEGER or PROCEDURE");
+ 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)
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.88
diff -u -3 -p -r1.88 gfortran.h
--- gcc/fortran/gfortran.h 1 Oct 2005 07:39:04 -0000 1.88
+++ gcc/fortran/gfortran.h 15 Oct 2005 08:35:08 -0000
@@ -382,6 +382,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,
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.55
diff -u -3 -p -r1.55 intrinsic.c
--- gcc/fortran/intrinsic.c 22 Sep 2005 19:00:22 -0000 1.55
+++ gcc/fortran/intrinsic.c 15 Oct 2005 08:35:08 -0000
@@ -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);
@@ -2114,7 +2121,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;
@@ -2210,6 +2218,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);
@@ -2260,6 +2273,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,
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.33
diff -u -3 -p -r1.33 intrinsic.h
--- gcc/fortran/intrinsic.h 22 Sep 2005 19:00:23 -0000 1.33
+++ gcc/fortran/intrinsic.h 15 Oct 2005 08:35:08 -0000
@@ -108,6 +108,7 @@ try gfc_check_set_exponent (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 *);
@@ -125,6 +126,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 *);
@@ -146,6 +148,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 *);
@@ -358,6 +361,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 *);
@@ -383,6 +387,7 @@ void gfc_resolve_verify (gfc_expr *, gfc
/* 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 *);
@@ -403,6 +408,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 *);
Index: gcc/fortran/intrinsic.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.texi,v
retrieving revision 1.17
diff -u -3 -p -r1.17 intrinsic.texi
--- gcc/fortran/intrinsic.texi 22 Sep 2005 19:00:23 -0000 1.17
+++ gcc/fortran/intrinsic.texi 15 Oct 2005 08:35:08 -0000
@@ -41,6 +41,7 @@ and editing. All contributions and corr
* @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
@@ -90,9 +91,10 @@ and editing. All contributions and corr
* @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
@@ -511,6 +513,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
@@ -2888,6 +2941,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
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.41
diff -u -3 -p -r1.41 iresolve.c
--- gcc/fortran/iresolve.c 3 Oct 2005 07:22:18 -0000 1.41
+++ gcc/fortran/iresolve.c 15 Oct 2005 08:35:09 -0000
@@ -1348,6 +1348,27 @@ gfc_resolve_sign (gfc_expr * f, gfc_expr
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;
@@ -1649,6 +1670,37 @@ gfc_resolve_verify (gfc_expr * f, gfc_ex
/* 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;
@@ -1874,6 +1926,37 @@ gfc_resolve_get_environment_variable (gf
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
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.55
diff -u -3 -p -r1.55 trans-intrinsic.c
--- gcc/fortran/trans-intrinsic.c 3 Oct 2005 07:22:18 -0000 1.55
+++ gcc/fortran/trans-intrinsic.c 15 Oct 2005 08:35:11 -0000
@@ -3066,6 +3066,7 @@ gfc_conv_intrinsic_function (gfc_se * se
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:
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.43
diff -u -3 -p -r1.43 Makefile.am
--- libgfortran/Makefile.am 3 Oct 2005 07:22:19 -0000 1.43
+++ libgfortran/Makefile.am 15 Oct 2005 08:35:12 -0000
@@ -68,6 +68,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 \
Index: libgfortran/configure.ac
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/configure.ac,v
retrieving revision 1.36
diff -u -3 -p -r1.36 configure.ac
--- libgfortran/configure.ac 27 Sep 2005 21:12:48 -0000 1.36
+++ libgfortran/configure.ac 15 Oct 2005 08:35:13 -0000
@@ -168,7 +168,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])])
Index: libgfortran/intrinsics/signal.c
===================================================================
RCS file: libgfortran/intrinsics/signal.c
diff -N libgfortran/intrinsics/signal.c
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ libgfortran/intrinsics/signal.c 15 Oct 2005 08:35:13 -0000
@@ -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);
+