mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-26 09:35:38 +08:00
Code Issues Packages Projects Releases Wiki Activity

check.c (gfc_check_alarm_sub, [...]): New functions.

Browse Source 
* 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
This commit is contained in:
Francois-Xavier Coudert 2005-10-28 23:16:17 +02:00 committed by François-Xavier Coudert
parent 7f0dbff360
commit 185d7d9750
15 changed files with 534 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -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

91
gcc/fortran/check.c
View File

@ -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)
{
@ -2721,6 +2755,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)
{

1
gcc/fortran/gfortran.h
View File

@ -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,

22
gcc/fortran/intrinsic.c
View File

@ -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,

6
gcc/fortran/intrinsic.h
View File

@ -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 *);

114
gcc/fortran/intrinsic.texi
View File

@ -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

83
gcc/fortran/iresolve.c
View File

@ -1391,6 +1391,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)
{
@ -1700,6 +1721,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)
{
@ -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

1
gcc/fortran/trans-intrinsic.c
View File

@ -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:

11
libgfortran/ChangeLog
View File

@ -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

1
libgfortran/Makefile.am
View File

@ -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 \

19
libgfortran/Makefile.in
View File

@ -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

6
libgfortran/config.h.in
View File

@ -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

4
libgfortran/configure vendored
View File

@ -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

2
libgfortran/configure.ac
View File

@ -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])])

170
libgfortran/intrinsics/signal.c Normal file
View File

@ -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);