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

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

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

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,

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,

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

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

gcc/fortran/iresolve.c

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

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:

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

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 \

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 \
+	ishftc.lo link.lo mvbits.lo pack_generic.lo perror.lo \
-	sleep.lo spread_generic.lo string_intrinsics.lo system.lo \
+	signal.lo size.lo sleep.lo spread_generic.lo \
-	rand.lo random.lo rename.lo reshape_generic.lo \
+	string_intrinsics.lo system.lo rand.lo random.lo rename.lo \
-	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
+	reshape_generic.lo reshape_packed.lo selected_int_kind.lo \
-	stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
+	selected_real_kind.lo stat.lo symlnk.lo system_clock.lo \
-	tty.lo umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
+	time.lo transpose_generic.lo tty.lo umask.lo unlink.lo \
-	in_unpack_generic.lo normalize.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
 

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
 

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

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

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