Various changes from Craig. See the appropriate ChangeLog files.

From-SVN: r18182

gcc/f/ChangeLog

@@ -14,6 +14,45 @@ Sun Jan 11 02:14:47 1998  Craig Burley  <burley@gnu.org>
 	* stb.c (ffestb_R10014_, ffestb_R10016_, ffestb_R10018_,
 	ffestb_R100110_): Restructure `for' loop for style.
 
+Tue Dec 23 14:58:04 1997  Craig Burley  <burley@gnu.org>
+
+	* com.c (ffecom_gfrt_basictype):
+	(ffecom_gfrt_kindtype):
+	(ffecom_make_gfrt_):
+	(FFECOM_rttypeVOIDSTAR_): New return type `void *', for
+	the SIGNAL intrinsic.
+	* com-rt.def (FFECOM_rttypeSIGNAL): Now returns `void *'.
+	* intdoc.c: Replace `p' kind specifier with `7'.
+	* intrin.c (ffeintrin_check_, ffeintrin_init_0): Replace
+	`p' kind specifier with `7'.
+	* intrin.def (FFEINTRIN_impLOC, FFEINTRIN_impSIGNAL_func,
+	FFEINTRIN_impSIGNAL_subr): Replace `p' specifier with `7'.
+	Also, SIGNAL now returns a `void *' status, not `int'.
+
+Mon Dec 22 12:41:07 1997  Craig Burley  <burley@gnu.org>
+
+	* intrin.c (ffeintrin_init_0): Remove duplicate
+	check for `!'.
+
+Sun Dec 14 02:49:58 1997  Craig Burley  <burley@gnu.org>
+
+	* intrin.c (ffeintrin_init_0): Fix up indentation a bit.
+	Fix bug that prevented checking of arguments other
+	than the first.
+
+	* intdoc.c: Fix up indentation a bit.
+
+Mon Dec  1 19:12:36 1997  Craig Burley  <burley@gnu.org>
+
+	* intrin.c (ffeintrin_check_): Fix up indentation a bit more.
+
+Sun Nov 30 22:22:22 1997  Craig Burley  <burley@gnu.org>
+
+	* intdoc.c: Minor fix-ups.
+
+	* intrin.c (ffeintrin_check_): Fix up indentation a bit.
+
+
 Fri Oct 10 13:00:48 1997  Craig Burley  <burley@gnu.ai.mit.edu>
 
 	* ste.c (ffeste_begin_iterdo_): Fix loop setup so iteration

gcc/f/com-rt.def

@@ -225,7 +225,7 @@ DEFGFRT (FFECOM_gfrtRENAME, "G77_rename_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE
 DEFGFRT (FFECOM_gfrtSECNDS, "G77_secnds_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE)
 DEFGFRT (FFECOM_gfrtSECOND, "G77_second_0", FFECOM_rttypeREAL_F2C_, 0, FALSE, FALSE)
 DEFGFRT (FFECOM_gfrtSIGN, "r_sign", FFECOM_rttypeREAL_F2C_, "&f&f", FALSE, FALSE)
-DEFGFRT (FFECOM_gfrtL_SIGNAL, "G77_signal_0", FFECOM_rttypeFTNINT_, "&i0", FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtL_SIGNAL, "G77_signal_0", FFECOM_rttypeVOIDSTAR_, "&i0", FALSE, FALSE)
 DEFGFRT (FFECOM_gfrtSIN, "r_sin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE)
 DEFGFRT (FFECOM_gfrtSINH, "r_sinh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE)
 DEFGFRT (FFECOM_gfrtSLEEP, "G77_sleep_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE)

gcc/f/com.c

@@ -345,6 +345,7 @@ tree ffecom_f2c_ptr_to_ftnint_type_node;
 typedef enum
   {
     FFECOM_rttypeVOID_,
+    FFECOM_rttypeVOIDSTAR_,	/* C's `void *' type. */
     FFECOM_rttypeFTNINT_,	/* f2c's `ftnint' type. */
     FFECOM_rttypeINTEGER_,	/* f2c's `integer' type. */
     FFECOM_rttypeLONGINT_,	/* f2c's `longint' type. */
@@ -7448,6 +7449,10 @@ ffecom_make_gfrt_ (ffecomGfrt ix)
       ttype = void_type_node;
       break;
 
+    case FFECOM_rttypeVOIDSTAR_:
+      ttype = TREE_TYPE (null_pointer_node);	/* `void *'. */
+      break;
+
     case FFECOM_rttypeFTNINT_:
       ttype = ffecom_f2c_ftnint_type_node;
       break;
@@ -11632,6 +11637,7 @@ ffecom_gfrt_basictype (ffecomGfrt gfrt)
   switch (ffecom_gfrt_type_[gfrt])
     {
     case FFECOM_rttypeVOID_:
+    case FFECOM_rttypeVOIDSTAR_:
       return FFEINFO_basictypeNONE;
 
     case FFECOM_rttypeFTNINT_:
@@ -11678,6 +11684,7 @@ ffecom_gfrt_kindtype (ffecomGfrt gfrt)
   switch (ffecom_gfrt_type_[gfrt])
     {
     case FFECOM_rttypeVOID_:
+    case FFECOM_rttypeVOIDSTAR_:
       return FFEINFO_kindtypeNONE;
 
     case FFECOM_rttypeFTNINT_:

gcc/f/intdoc.c

@@ -494,7 +494,7 @@ external procedure.\n\
       if ((argi[0] == '*')
 	  || (argi[0] == 'n')
 	  || (argi[0] == '+')
-      || (argi[0] == 'p'))
+	  || (argi[0] == 'p'))
 	printf ("-1, @var{%s}-2, @dots{}, @var{%s}-n",
 		argc, argc);
     }
@@ -559,7 +559,7 @@ this intrinsic is valid only when used as the argument to\n\
 	}
 #if 0
       else if ((c[0] == 'I')
-	       && (c[1] == 'p'))
+	       && (c[1] == '7'))
 	printf (", the exact type being wide enough to hold a pointer\n\
 on the target system (typically @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=4)}).\n\n");
 #endif
@@ -730,10 +730,6 @@ types of all the arguments.\n\n");
 		      argument_name_string (imp, 0));
 	      break;
 
-	    case 'p':
-	      printf ("@code{INTEGER} wide enough to hold a pointer");
-	      break;
-
 	    default:
 	      assert ("Ia" == NULL);
 	      break;
@@ -848,7 +844,7 @@ types of all the arguments.\n\n");
 	      break;
 
 	    default:
-	      assert ("N1" == NULL);
+	      assert ("E1" == NULL);
 	      break;
 	    }
 	  break;
@@ -1209,10 +1205,6 @@ print_type_string (char *c)
 	  printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
 	  break;
 
-	case 'p':
-	  printf ("@code{INTEGER(KIND=0)}");
-	  break;
-
 	default:
 	  assert ("Ia" == NULL);
 	  break;
@@ -1336,7 +1328,7 @@ print_type_string (char *c)
       break;
 
     default:
-      assert ("arg type?" == NULL);
+      assert ("type?" == NULL);
       break;
     }
 }

gcc/f/intdoc.in

@@ -2190,12 +2190,13 @@ DEFDOC (SIGNAL_subr, "Muck with signal handling.", "\
 If @var{@2@} is a an @code{EXTERNAL} routine, arranges for it to be
 invoked with a single integer argument (of system-dependent length)
 when signal @var{@1@} occurs.
-If @var{@1@} is an integer, it can be
-used to turn off handling of signal @var{@2@} or revert to its default
+If @var{@2@} is an integer, it can be
+used to turn off handling of signal @var{@1@} or revert to its default
 action.
 See @code{signal(2)}.
 
-Note that @var{@2@} will be called using C conventions, so its value in
+Note that @var{@2@} will be called using C conventions,
+so the value of its argument in Fortran terms
 Fortran terms is obtained by applying @code{%LOC()} (or @var{LOC()}) to it.
 
 The value returned by @code{signal(2)} is written to @var{@3@}, if
@@ -2205,24 +2206,106 @@ Otherwise the return value is ignored.
 Some non-GNU implementations of Fortran provide this intrinsic as
 only a function, not as a subroutine, or do not support the
 (optional) @var{@3@} argument.
+
+@emph{Warning:} Use of the @code{libf2c} run-time library function
+@samp{signal_} directly
+(such as via @samp{EXTERNAL SIGNAL})
+requires use of the @code{%VAL()} construct
+to pass an @code{INTEGER} value
+(such as @samp{SIG_IGN} or @samp{SIG_DFL})
+for the @var{@2@} argument.
+
+However, while @samp{CALL SIGNAL(@var{signum}, %VAL(SIG_IGN))}
+works when @samp{SIGNAL} is treated as an external procedure
+(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine),
+this construct is not valid when @samp{SIGNAL} is recognized
+as the intrinsic of that name.
+
+Therefore, for maximum portability and reliability,
+code such references to the @samp{SIGNAL} facility as follows:
+
+@smallexample
+INTRINSIC SIGNAL
+@dots{}
+CALL SIGNAL(@var{signum}, SIG_IGN)
+@end smallexample
+
+@code{g77} will compile such a call correctly,
+while other compilers will generally either do so as well
+or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic,
+allowing you to take appropriate action.
 ")
 
 DEFDOC (SIGNAL_func, "Muck with signal handling.", "\
 If @var{@2@} is a an @code{EXTERNAL} routine, arranges for it to be
 invoked with a single integer argument (of system-dependent length)
 when signal @var{@1@} occurs.
-If @var{@1@} is an integer, it can be
-used to turn off handling of signal @var{@2@} or revert to its default
+If @var{@2@} is an integer, it can be
+used to turn off handling of signal @var{@1@} or revert to its default
 action.
 See @code{signal(2)}.
 
-Note that @var{@2@} will be called using C conventions, so its value in
-Fortran terms is obtained by applying @code{%LOC()} (or @var{LOC()}) to it.
+Note that @var{@2@} will be called using C conventions,
+so the value of its argument in Fortran terms
+is obtained by applying @code{%LOC()} (or @var{LOC()}) to it.
 
 The value returned by @code{signal(2)} is returned.
 
 Due to the side effects performed by this intrinsic, the function
 form is not recommended.
+
+@emph{Warning:} If the returned value is stored in
+an @code{INTEGER(KIND=1)} (default @code{INTEGER}) argument,
+truncation of the original return value occurs on some systems
+(such as Alphas, which have 64-bit pointers but 32-bit default integers),
+with no warning issued by @code{g77} under normal circumstances.
+
+Therefore, the following code fragment might silently fail on
+some systems:
+
+@smallexample
+INTEGER RTN
+EXTERNAL MYHNDL
+RTN = SIGNAL(@var{signum}, MYHNDL)
+@dots{}
+! Restore original handler:
+RTN = SIGNAL(@var{signum}, RTN)
+@end smallexample
+
+The reason for the failure is that @samp{RTN} might not hold
+all the information on the original handler for the signal,
+thus restoring an invalid handler.
+This bug could manifest itself as a spurious run-time failure
+at an arbitrary point later during the program's execution,
+for example.
+
+@emph{Warning:} Use of the @code{libf2c} run-time library function
+@samp{signal_} directly
+(such as via @samp{EXTERNAL SIGNAL})
+requires use of the @code{%VAL()} construct
+to pass an @code{INTEGER} value
+(such as @samp{SIG_IGN} or @samp{SIG_DFL})
+for the @var{@2@} argument.
+
+However, while @samp{RTN = SIGNAL(@var{signum}, %VAL(SIG_IGN))}
+works when @samp{SIGNAL} is treated as an external procedure
+(and resolves, at link time, to @code{libf2c}'s @samp{signal_} routine),
+this construct is not valid when @samp{SIGNAL} is recognized
+as the intrinsic of that name.
+
+Therefore, for maximum portability and reliability,
+code such references to the @samp{SIGNAL} facility as follows:
+
+@smallexample
+INTRINSIC SIGNAL
+@dots{}
+RTN = SIGNAL(@var{signum}, SIG_IGN)
+@end smallexample
+
+@code{g77} will compile such a call correctly,
+while other compilers will generally either do so as well
+or reject the @samp{INTRINSIC SIGNAL} statement via a diagnostic,
+allowing you to take appropriate action.
 ")
 
 DEFDOC (KILL_func, "Signal a process.", "\

gcc/f/intrin.c

@@ -398,6 +398,10 @@ ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
 		    case 6:
 		      akt = 3;
 		      break;
+
+		    case 7:
+		      akt = ffecom_pointer_kind ();
+		      break;
 		    }
 		}
 	      okay &= anynum || (ffeinfo_kindtype (i) == akt);
@@ -593,6 +597,10 @@ ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
 	    case 6:
 	      kt = 3;
 	      break;
+
+	    case 7:
+	      kt = ffecom_pointer_kind ();
+	      break;
 	    }
 	}
       break;
@@ -603,10 +611,6 @@ ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
       kt = 1;
       break;
 
-    case 'p':
-      kt = ffecom_pointer_kind ();
-      break;
-
     case '=':
       need_col = TRUE;
       /* Fall through.  */
@@ -991,6 +995,10 @@ ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
 		    case 6:
 		      akt = 3;
 		      break;
+
+		    case 7:
+		      akt = ffecom_pointer_kind ();
+		      break;
 		    }
 		}
 	      okay &= anynum || (ffeinfo_kindtype (i) == akt);
@@ -1569,14 +1577,14 @@ ffeintrin_init_0 ()
 
       if ((c[0] != '-')
 	  && (c[0] != 'A')
-      && (c[0] != 'C')
-      && (c[0] != 'I')
-      && (c[0] != 'L')
-      && (c[0] != 'R')
-      && (c[0] != 'B')
-      && (c[0] != 'F')
-      && (c[0] != 'N')
-      && (c[0] != 'S'))
+	  && (c[0] != 'C')
+	  && (c[0] != 'I')
+	  && (c[0] != 'L')
+	  && (c[0] != 'R')
+	  && (c[0] != 'B')
+	  && (c[0] != 'F')
+	  && (c[0] != 'N')
+	  && (c[0] != 'S'))
 	{
 	  fprintf (stderr, "%s: bad return-base-type\n",
 		   ffeintrin_imps_[i].name);
@@ -1584,10 +1592,9 @@ ffeintrin_init_0 ()
 	}
       if ((c[1] != '-')
 	  && (c[1] != '=')
-      && ((c[1] < '1')
-	  || (c[1] > '9'))
-	  && (c[1] != 'C')
-	  && (c[1] != 'p'))
+	  && ((c[1] < '1')
+	      || (c[1] > '9'))
+	  && (c[1] != 'C'))
 	{
 	  fprintf (stderr, "%s: bad return-kind-type\n",
 		   ffeintrin_imps_[i].name);
@@ -1613,8 +1620,8 @@ ffeintrin_init_0 ()
 	}
       if ((c[colon + 1] != '-')
 	  && (c[colon + 1] != '*')
-      && ((c[colon + 1] < '0')
-	  || (c[colon + 1] > '9')))
+	  && ((c[colon + 1] < '0')
+	      || (c[colon + 1] > '9')))
 	{
 	  fprintf (stderr, "%s: bad COL-spec\n",
 		   ffeintrin_imps_[i].name);
@@ -1625,7 +1632,7 @@ ffeintrin_init_0 ()
 	{
 	  while ((c[0] != '=')
 		 && (c[0] != ',')
-	  && (c[0] != '\0'))
+		 && (c[0] != '\0'))
 	    ++c;
 	  if (c[0] != '=')
 	    {
@@ -1635,28 +1642,27 @@ ffeintrin_init_0 ()
 	    }
 	  if ((c[1] == '?')
 	      || (c[1] == '!')
-	  || (c[1] == '!')
 	      || (c[1] == '+')
-	  || (c[1] == '*')
+	      || (c[1] == '*')
 	      || (c[1] == 'n')
-	  || (c[1] == 'p'))
+	      || (c[1] == 'p'))
 	    ++c;
 	  if (((c[1] != '-')
 	       && (c[1] != 'A')
-	  && (c[1] != 'C')
-	  && (c[1] != 'I')
-	  && (c[1] != 'L')
-	  && (c[1] != 'R')
-	  && (c[1] != 'B')
-	  && (c[1] != 'F')
-	  && (c[1] != 'N')
-	  && (c[1] != 'S')
-	  && (c[1] != 'g')
-	  && (c[1] != 's'))
+	       && (c[1] != 'C')
+	       && (c[1] != 'I')
+	       && (c[1] != 'L')
+	       && (c[1] != 'R')
+	       && (c[1] != 'B')
+	       && (c[1] != 'F')
+	       && (c[1] != 'N')
+	       && (c[1] != 'S')
+	       && (c[1] != 'g')
+	       && (c[1] != 's'))
 	      || ((c[2] != '*')
 		  && ((c[2] < '1')
 		      || (c[2] > '9'))
-	      && (c[2] != 'A')))
+		  && (c[2] != 'A')))
 	    {
 	      fprintf (stderr, "%s: bad arg-type\n",
 		       ffeintrin_imps_[i].name);
@@ -1693,13 +1699,13 @@ ffeintrin_init_0 ()
 	    ++c;
 	  if ((c[3] == '&')
 	      || (c[3] == 'i')
-	  || (c[3] == 'w')
-	  || (c[3] == 'x'))
+	      || (c[3] == 'w')
+	      || (c[3] == 'x'))
 	    ++c;
 	  if (c[3] == ',')
 	    {
 	      c += 4;
-	      break;
+	      continue;
 	    }
 	  if (c[3] != '\0')
 	    {

gcc/f/intrin.def

@@ -3038,8 +3038,8 @@ DEFSPEC (NONE,
      3    (Same size as CHARACTER*1)
      4    (Twice the size of 2)
      6    (Twice the size as 3)
+     7    (Same size as `char *')
      C    Like 1 (F77), except (F90), if COL is COMPLEX, uses kind type of COL
-     p    ffecom_pointer_kind_
 
    <return-modifier> is:
 
@@ -3309,7 +3309,7 @@ DEFIMP	(LONG,		"LONG",		,,,		"I1:-:A=I6")
 DEFIMP  (LSTAT_func,	"LSTAT_func",	LSTAT,,,	"I1:-:File=A1,SArray=I1(13)w")
 DEFIMP  (LSTAT_subr,	"LSTAT_subr",	LSTAT,,,	"--:-:File=A1,SArray=I1(13)w,Status=?I1w")
 DEFIMP  (LTIME,		"LTIME",	LTIME,,,	"--:-:STime=I1,TArray=I1(9)w")
-DEFIMP	(LOC,		"LOC",		,,,		"Ip:-:Entity=-*&&")
+DEFIMP	(LOC,		"LOC",		,,,		"I7:-:Entity=-*&&")
 DEFIMP	(LSHIFT,	"LSHIFT",	,,,		"I=:0:I=I*,Shift=I*")
 DEFIMP  (MCLOCK,	"MCLOCK",	MCLOCK,,,	"I1:-:")
 DEFIMP  (MCLOCK8,	"MCLOCK8",	MCLOCK,,,	"I2:-:")
@@ -3326,8 +3326,8 @@ DEFIMP  (SECNDS,	"SECNDS",	SECNDS,,,	"R1:-:T=R1")
 DEFIMP  (SECOND_func,	"SECOND_func",	SECOND,SECOND,,	"R1:-:")
 DEFIMP  (SECOND_subr,	"SECOND_subr",	SECOND,,,	"--:-:Seconds=R1w")
 DEFIMP	(SHORT,		"SHORT",	,,,		"I6:-:A=I*")
-DEFIMP	(SIGNAL_func,	"SIGNAL_func",	L_SIGNAL,,,	"I1:-:Number=I*,Handler=s*")
-DEFIMP	(SIGNAL_subr,	"SIGNAL_subr",	L_SIGNAL,,,	"--:-:Number=I*,Handler=s*,Status=?I1w")
+DEFIMP	(SIGNAL_func,	"SIGNAL_func",	L_SIGNAL,,,	"I7:-:Number=I*,Handler=s*")
+DEFIMP	(SIGNAL_subr,	"SIGNAL_subr",	L_SIGNAL,,,	"--:-:Number=I*,Handler=s*,Status=?I7w")
 DEFIMP	(SLEEP,		"SLEEP",	SLEEP,,,	"--:-:Seconds=I1")
 DEFIMP  (SRAND,		"SRAND",	SRAND,,,	"--:-:Seed=I*")
 DEFIMP  (STAT_func,	"STAT_func",	STAT,,,		"I1:-:File=A1,SArray=I1(13)w")

gcc/f/news.texi

@@ -27,6 +27,15 @@ involve a combination of these elements.
 @heading In 0.5.22:
 @itemize @bullet
 @item
+Fix @code{SIGNAL} intrinsic so it offers portable
+support for 64-bit systems (such as Digital Alphas
+running GNU/Linux).
+
+@item
+Support @samp{FORMAT(I<@var{expr}>)} when @var{expr} is a
+compile-time constant @code{INTEGER} expression.
+
+@item
 Fix code generation for iterative @code{DO} loops that
 have one or more references to the iteration variable,
 or to aliases of it, in their control expressions.

libf2c/ChangeLog

+Tue Dec 23 22:56:01 1997  Craig Burley  <burley@gnu.org>
+
+	* libF77/signal_.c (G77_signal_0): Return type is
+	now `void *', to cope with returning previous signal
+	handler on 64-bit systems like Alphas.
+	* f2cext.c (signal_): Changed accordingly.
+
 Tue Sep 30 00:41:39 1997  Craig Burley  <burley@gnu.ai.mit.edu>
 
 	Do a better job of printing the offending FORMAT string

libf2c/f2cext.c

@@ -18,7 +18,7 @@ Boston, MA 02111-1307, USA.  */
 
 
 #include <f2c.h>
-typedef int (*sig_proc)(int);
+typedef void *sig_proc;	/* For now, this will have to do. */
 
 #ifdef Labort
 int abort_ (void) {
@@ -98,8 +98,8 @@ ftnint iargc_ (void) {
 #endif
 
 #ifdef Lsignal
-ftnint signal_ (integer *sigp, sig_proc proc) {
-    extern ftnint G77_signal_0 (integer *sigp, sig_proc proc);
+void *signal_ (integer *sigp, sig_proc proc) {
+    extern void *G77_signal_0 (integer *sigp, sig_proc proc);
     return G77_signal_0 (sigp, proc);
 }
 #endif

libf2c/libF77/signal_.c

@@ -2,13 +2,16 @@
 #include "signal1.h"
 
 #ifdef KR_headers
-ftnint G77_signal_0 (sigp, proc) integer *sigp; sig_pf proc;
+void *
+G77_signal_0 (sigp, proc) integer *sigp; sig_pf proc;
 #else
-ftnint G77_signal_0 (integer *sigp, sig_pf proc)
+void *
+G77_signal_0 (integer *sigp, sig_pf proc)
 #endif
 {
 	int sig;
 	sig = (int)*sigp;
 
-	return (ftnint)signal(sig, proc);
+	return (void *) signal(sig, proc);
 	}
+