Support FORMAT(I<1+2>) (constant variable-FORMAT

        expressions):
        * bad.def (FFEBAD_FORMAT_VARIABLE): New diagnostic.
        * std.c (ffestd_R1001rtexpr_): New function.
        (ffestd_R1001dump_, ffestd_R1001dump_1005_1_,
        ffestd_R1001dump_1005_2_, ffestd_R1001dump_1005_3_,
        ffestd_R1001dump_1005_4_, ffestd_R1001dump_1005_5_,
        ffestd_R1001dump_1010_2_, ffestd_R1001dump_1010_3_,
        ffestd_R1001dump_1010_4_, ffestd_R1001dump_1010_5_):
        Use new function instead of ffestd_R1001error_.
        * stb.c (ffestb_R10014_, ffestb_R10016_, ffestb_R10018_,
        ffestb_R100110_): Restructure `for' loop for style.
Change from Craig.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@18181 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 89 insertions, 24 deletions

diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog
index 174a15ffe82..0d7dadaf8fa 100644
--- a/gcc/f/ChangeLog
+++ b/gcc/f/ChangeLog
@@ -1,3 +1,19 @@
+Sun Jan 11 02:14:47 1998  Craig Burley  <burley@gnu.org>
+
+	Support FORMAT(I<1+2>) (constant variable-FORMAT
+	expressions):
+	* bad.def (FFEBAD_FORMAT_VARIABLE): New diagnostic.
+	* std.c (ffestd_R1001rtexpr_): New function.
+	(ffestd_R1001dump_, ffestd_R1001dump_1005_1_,
+	ffestd_R1001dump_1005_2_, ffestd_R1001dump_1005_3_,
+	ffestd_R1001dump_1005_4_, ffestd_R1001dump_1005_5_,
+	ffestd_R1001dump_1010_2_, ffestd_R1001dump_1010_3_,
+	ffestd_R1001dump_1010_4_, ffestd_R1001dump_1010_5_):
+	Use new function instead of ffestd_R1001error_.
+
+	* stb.c (ffestb_R10014_, ffestb_R10016_, ffestb_R10018_,
+	ffestb_R100110_): Restructure `for' loop for style.
+
 Fri Oct 10 13:00:48 1997  Craig Burley  <burley@gnu.ai.mit.edu>
 
 	* ste.c (ffeste_begin_iterdo_): Fix loop setup so iteration
diff --git a/gcc/f/bad.def b/gcc/f/bad.def
index 347cd441502..9a3cf5a323d 100644
--- a/gcc/f/bad.def
+++ b/gcc/f/bad.def
@@ -549,6 +549,8 @@ FFEBAD_MSGS1 (FFEBAD_ARRAY_AS_SFARG, FATAL,
 "Array supplied at %1 for dummy argument `%A' in statement function reference at %0")
 FFEBAD_MSGS1 (FFEBAD_FORMAT_UNSUPPORTED, FATAL,
 "Unsupported FORMAT specifier at %0")
+FFEBAD_MSGS1 (FFEBAD_FORMAT_VARIABLE, FATAL,
+"Variable-expression FORMAT specifier at %0 -- unsupported")
 FFEBAD_MSGS2 (FFEBAD_OPEN_UNSUPPORTED, WARN,
 "Unsupported OPEN control item at %0 -- ACTION=, ASSOCIATEVARIABLE=, BLOCKSIZE=, BUFFERCOUNT=, CARRIAGECONTROL=, DEFAULTFILE=, DELIM=, DISPOSE=, EXTENDSIZE=, INITIALSIZE=, KEY=, MAXREC=, NOSPANBLOCKS, ORGANIZATION=, PAD=, POSITION=, READONLY=, RECORDTYPE=, SHARED=, and USEROPEN= are not supported",
 "Unsupported OPEN control item at %0")
diff --git a/gcc/f/stb.c b/gcc/f/stb.c
index 9cf655fa56b..90ae83d5637 100644
--- a/gcc/f/stb.c
+++ b/gcc/f/stb.c
@@ -9214,14 +9214,14 @@ ffestb_R10014_ (ffelexToken t)
 	}
       if (ffestb_local_.format.sign)
 	{
-	  for (i = 0; i < ffelex_token_length (t); ++i)
+	  for (i = ffelex_token_length (t) + 1; i > 0; --i)
 	    ffestb_local_.format.pre.u.signed_val *= 10;
 	  ffestb_local_.format.pre.u.signed_val += strtoul (ffelex_token_text (t),
 							    NULL, 10);
 	}
       else
 	{
-	  for (i = 0; i < ffelex_token_length (t); ++i)
+	  for (i = ffelex_token_length (t) + 1; i > 0; --i)
 	    ffestb_local_.format.pre.u.unsigned_val *= 10;
 	  ffestb_local_.format.pre.u.unsigned_val += strtoul (ffelex_token_text (t),
 							      NULL, 10);
@@ -10105,7 +10105,7 @@ ffestb_R10016_ (ffelexToken t)
 	  ffebad_finish ();
 	  return (ffelexHandler) ffestb_R10016_;
 	}
-      for (i = 0; i < ffelex_token_length (t); ++i)
+      for (i = ffelex_token_length (t) + 1; i > 0; --i)
 	ffestb_local_.format.post.u.unsigned_val *= 10;
       ffestb_local_.format.post.u.unsigned_val += strtoul (ffelex_token_text (t),
 							   NULL, 10);
@@ -10205,7 +10205,7 @@ ffestb_R10018_ (ffelexToken t)
 	  ffebad_finish ();
 	  return (ffelexHandler) ffestb_R10018_;
 	}
-      for (i = 0; i < ffelex_token_length (t); ++i)
+      for (i = ffelex_token_length (t) + 1; i > 0; --i)
 	ffestb_local_.format.dot.u.unsigned_val *= 10;
       ffestb_local_.format.dot.u.unsigned_val += strtoul (ffelex_token_text (t),
 							  NULL, 10);
@@ -10332,7 +10332,7 @@ ffestb_R100110_ (ffelexToken t)
 	  ffebad_finish ();
 	  return (ffelexHandler) ffestb_R100110_;
 	}
-      for (i = 0; i < ffelex_token_length (t); ++i)
+      for (i = ffelex_token_length (t) + 1; i > 0; --i)
 	ffestb_local_.format.exp.u.unsigned_val *= 10;
       ffestb_local_.format.exp.u.unsigned_val += strtoul (ffelex_token_text (t),
 							  NULL, 10);
diff --git a/gcc/f/std.c b/gcc/f/std.c
index 5c11c40a9a3..78538d15978 100644
--- a/gcc/f/std.c
+++ b/gcc/f/std.c
@@ -546,6 +546,7 @@ static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f,
 static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f,
 				      char *string);
 static void ffestd_R1001error_ (ffesttFormatList f);
+static void ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr);
 
 /* Internal macros. */
 
@@ -4360,7 +4361,7 @@ ffestd_R1001dump_ (ffests s, ffesttFormatList list)
 	  if (next->u.R1003D.R1004.present)
 	    {
 	      if (next->u.R1003D.R1004.rtexpr)
-		ffestd_R1001error_ (next);
+		ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
 	      else
 		ffests_printf_1U (s, "%lu",
 				  next->u.R1003D.R1004.u.unsigned_val);
@@ -4393,7 +4394,7 @@ ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, char *string)
   if (f->u.R1005.R1004.present)
     {
       if (f->u.R1005.R1004.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
     }
@@ -4403,7 +4404,7 @@ ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, char *string)
   if (f->u.R1005.R1006.present)
     {
       if (f->u.R1005.R1006.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
     }
@@ -4426,7 +4427,7 @@ ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, char *string)
   if (f->u.R1005.R1004.present)
     {
       if (f->u.R1005.R1004.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
     }
@@ -4434,7 +4435,7 @@ ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, char *string)
   ffests_puts (s, string);
 
   if (f->u.R1005.R1006.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
 }
@@ -4455,7 +4456,7 @@ ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, char *string)
   if (f->u.R1005.R1004.present)
     {
       if (f->u.R1005.R1004.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
     }
@@ -4463,7 +4464,7 @@ ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, char *string)
   ffests_puts (s, string);
 
   if (f->u.R1005.R1006.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
 
@@ -4471,7 +4472,7 @@ ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, char *string)
     {
       ffests_putc (s, '.');
       if (f->u.R1005.R1007_or_R1008.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
       else
 	ffests_printf_1U (s, "%lu",
 			  f->u.R1005.R1007_or_R1008.u.unsigned_val);
@@ -4495,7 +4496,7 @@ ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, char *string)
   if (f->u.R1005.R1004.present)
     {
       if (f->u.R1005.R1004.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
     }
@@ -4503,13 +4504,13 @@ ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, char *string)
   ffests_puts (s, string);
 
   if (f->u.R1005.R1006.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
 
   ffests_putc (s, '.');
   if (f->u.R1005.R1007_or_R1008.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
 }
@@ -4530,7 +4531,7 @@ ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, char *string)
   if (f->u.R1005.R1004.present)
     {
       if (f->u.R1005.R1004.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
     }
@@ -4538,13 +4539,13 @@ ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, char *string)
   ffests_puts (s, string);
 
   if (f->u.R1005.R1006.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
 
   ffests_putc (s, '.');
   if (f->u.R1005.R1007_or_R1008.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
 
@@ -4552,7 +4553,7 @@ ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, char *string)
     {
       ffests_putc (s, 'E');
       if (f->u.R1005.R1009.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
     }
@@ -4586,7 +4587,7 @@ ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, char *string)
   if (f->u.R1010.val.present)
     {
       if (f->u.R1010.val.rtexpr)
-	ffestd_R1001error_ (f);
+	ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
       else
 	ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
     }
@@ -4607,7 +4608,7 @@ ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, char *string)
   assert (f->u.R1010.val.present);
 
   if (f->u.R1010.val.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
 
@@ -4627,7 +4628,7 @@ ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, char *string)
   assert (f->u.R1010.val.present);
 
   if (f->u.R1010.val.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
   else
     ffests_printf_1D (s, "%ld", f->u.R1010.val.u.signed_val);
 
@@ -4649,7 +4650,7 @@ ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, char *string)
   ffests_puts (s, string);
 
   if (f->u.R1010.val.rtexpr)
-    ffestd_R1001error_ (f);
+    ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
   else
     ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
 }
@@ -4669,6 +4670,52 @@ ffestd_R1001error_ (ffesttFormatList f)
   ffebad_finish ();
 }
 
+static void
+ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
+{
+  if ((expr == NULL)
+      || (ffebld_op (expr) != FFEBLD_opCONTER)
+      || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
+      || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
+    {
+      ffebad_start (FFEBAD_FORMAT_VARIABLE);
+      ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
+      ffebad_finish ();
+    }
+  else
+    {
+      int val;
+
+      switch (ffeinfo_kindtype (ffebld_info (expr)))
+	{
+#if FFETARGET_okINTEGER1
+	case FFEINFO_kindtypeINTEGER1:
+	  val = ffebld_constant_integer1 (ffebld_conter (expr));
+	  break;
+#endif
+
+#if FFETARGET_okINTEGER2
+	case FFEINFO_kindtypeINTEGER2:
+	  val = ffebld_constant_integer2 (ffebld_conter (expr));
+	  break;
+#endif
+
+#if FFETARGET_okINTEGER3
+	case FFEINFO_kindtypeINTEGER3:
+	  val = ffebld_constant_integer3 (ffebld_conter (expr));
+	  break;
+#endif
+
+	default:
+	  assert ("bad INTEGER constant kind type" == NULL);
+	  /* Fall through. */
+	case FFEINFO_kindtypeANY:
+	  return;
+	}
+      ffests_printf_1D (s, "%ld", val);
+    }
+}
+
 /* ffestd_R1102 -- PROGRAM statement
 
    ffestd_R1102(name_token);