Improve run-time diagnostic for "PRINT '(I1', 42":

        * com.c (ffecom_char_args_x_): Renamed from ffecom_char_args_,
        which is now a macro (to avoid lots of changes to other code)
        with new arg, ffecom_char_args_with_null_ being another new
        macro to call same function with different value for new arg.
        This function now appends a null byte to opCONTER expression
        if the new arg is TRUE.
        (ffecom_arg_ptr_to_expr): Support NULL length pointer.
        * ste.c (ffeste_io_cilist_):
        (ffeste_io_icilist_): Pass NULL length ptr for
        FORMAT expression, so null byte gets appended where
        feasible.
        * target.c (ffetarget_character1):
        (ffetarget_concatenate_character1):
        (ffetarget_substr_character1):
        (ffetarget_convert_character1_character1):
        (ffetarget_convert_character1_hollerith):
        (ffetarget_convert_character1_integer4):
        (ffetarget_convert_character1_logical4):
        (ffetarget_convert_character1_typeless):
        (ffetarget_hollerith): Append extra phantom null byte as
        part of FFETARGET-NULL-BYTE kludge.
Yes, even more patches from Craig :-)

From-SVN: r18187

gcc/f/ChangeLog

@@ -29,6 +29,29 @@ Fri Jan  9 19:09:07 1998  Craig Burley  <burley@gnu.org>
 
 Tue Dec 23 14:58:04 1997  Craig Burley  <burley@gnu.org>
 
+	Improve run-time diagnostic for "PRINT '(I1', 42":
+	* com.c (ffecom_char_args_x_): Renamed from ffecom_char_args_,
+	which is now a macro (to avoid lots of changes to other code)
+	with new arg, ffecom_char_args_with_null_ being another new
+	macro to call same function with different value for new arg.
+	This function now appends a null byte to opCONTER expression
+	if the new arg is TRUE.
+	(ffecom_arg_ptr_to_expr): Support NULL length pointer.
+	* ste.c (ffeste_io_cilist_):
+	(ffeste_io_icilist_): Pass NULL length ptr for
+	FORMAT expression, so null byte gets appended where
+	feasible.
+	* target.c (ffetarget_character1):
+	(ffetarget_concatenate_character1):
+	(ffetarget_substr_character1):
+	(ffetarget_convert_character1_character1):
+	(ffetarget_convert_character1_hollerith):
+	(ffetarget_convert_character1_integer4):
+	(ffetarget_convert_character1_logical4):
+	(ffetarget_convert_character1_typeless):
+	(ffetarget_hollerith): Append extra phantom null byte as
+	part of FFETARGET-NULL-BYTE kludge.
+
 	* intrin.c (ffeintrin_fulfill_generic): Don't generate
 	FFEBAD_INTRINSIC_TYPE for CHARACTER*(*) intrinsic.
 

gcc/f/com.c

@@ -420,8 +420,8 @@ static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 				tree dest_tree, ffebld dest,
 				bool *dest_used, tree callee_commons,
 				bool scalar_args);
-static void ffecom_char_args_ (tree *xitem, tree *length,
-			       ffebld expr);
+static void ffecom_char_args_x_ (tree *xitem, tree *length,
+				 ffebld expr, bool with_null);
 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 static ffecomConcatList_
@@ -653,6 +653,9 @@ static char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 #define ffecom_start_compstmt_ bison_rule_pushlevel_
 #define ffecom_end_compstmt_ bison_rule_compstmt_
 
+#define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
+#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
+
 /* For each binding contour we allocate a binding_level structure
  * which records the names defined in that contour.
  * Contours include:
@@ -1646,36 +1649,46 @@ ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
 }
 #endif
 
-/* ffecom_char_args_ -- Return ptr/length args for char subexpression
+/* ffecom_char_args_x_ -- Return ptr/length args for char subexpression
 
    tree ptr_arg;
    tree length_arg;
    ffebld expr;
-   ffecom_char_args_(&ptr_arg,&length_arg,expr);
+   bool with_null;
+   ffecom_char_args_x_(&ptr_arg,&length_arg,expr,with_null);
 
    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
    subexpressions by constructing the appropriate trees for the ptr-to-
    character-text and length-of-character-text arguments in a calling
-   sequence.  */
+   sequence.
+
+   Note that if with_null is TRUE, and the expression is an opCONTER,
+   a null byte is appended to the string.  */
 
 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 static void
-ffecom_char_args_ (tree *xitem, tree *length, ffebld expr)
+ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
 {
   tree item;
   tree high;
   ffetargetCharacter1 val;
+  ffetargetCharacterSize newlen;
 
   switch (ffebld_op (expr))
     {
     case FFEBLD_opCONTER:
       val = ffebld_constant_character1 (ffebld_conter (expr));
-      *length = build_int_2 (ffetarget_length_character1 (val), 0);
+      newlen = ffetarget_length_character1 (val);
+      if (with_null)
+	{
+	  if (newlen != 0)
+	    ++newlen;	/* begin FFETARGET-NULL-KLUDGE. */
+	}
+      *length = build_int_2 (newlen, 0);
       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
-      high = build_int_2 (ffetarget_length_character1 (val),
-			  0);
+      high = build_int_2 (newlen, 0);
       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
-      item = build_string (ffetarget_length_character1 (val),
+      item = build_string (newlen,	/* end FFETARGET-NULL-KLUDGE. */
 			   ffetarget_text_character1 (val));
       TREE_TYPE (item)
 	= build_type_variant
@@ -10818,7 +10831,19 @@ ffecom_arg_expr (ffebld expr, tree *length)
    returns and sets the length return value to NULL_TREE.  Otherwise
    generates code to evaluate the character expression, returns the proper
    pointer to the result, AND sets the length return value to a tree that
-   specifies the length of the result.	*/
+   specifies the length of the result.
+
+   If the length argument is NULL, this is a slightly special
+   case of building a FORMAT expression, that is, an expression that
+   will be used at run time without regard to length.  For the current
+   implementation, which uses the libf2c library, this means it is nice
+   to append a null byte to the end of the expression, where feasible,
+   to make sure any diagnostic about the FORMAT string terminates at
+   some useful point.
+
+   For now, treat %REF(char-expr) as the same as char-expr with a NULL
+   length argument.  This might even be seen as a feature, if a null
+   byte can always be appended.  */
 
 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 tree
@@ -10828,7 +10853,8 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
   tree ign_length;
   ffecomConcatList_ catlist;
 
-  *length = NULL_TREE;
+  if (length != NULL)
+    *length = NULL_TREE;
 
   if (expr == NULL)
     return integer_zero_node;
@@ -10850,8 +10876,11 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
     case FFEBLD_opPERCENT_REF:
       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
 	return ffecom_ptr_to_expr (ffebld_left (expr));
-      ign_length = NULL_TREE;
-      length = &ign_length;
+      if (length != NULL)
+	{
+	  ign_length = NULL_TREE;
+	  length = &ign_length;
+	}
       expr = ffebld_left (expr);
       break;
 
@@ -10877,7 +10906,8 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
     }
 
 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
-  if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
+  if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
+      && (length != NULL))
     {				/* Pass Hollerith by descriptor. */
       ffetargetHollerith h;
 
@@ -10900,14 +10930,21 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
   switch (ffecom_concat_list_count_ (catlist))
     {
     case 0:			/* Shouldn't happen, but in case it does... */
-      *length = ffecom_f2c_ftnlen_zero_node;
-      TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
+      if (length != NULL)
+	{
+	  *length = ffecom_f2c_ftnlen_zero_node;
+	  TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
+	}
       ffecom_concat_list_kill_ (catlist);
       return null_pointer_node;
 
     case 1:			/* The (fairly) easy case. */
-      ffecom_char_args_ (&item, length,
-			 ffecom_concat_list_expr_ (catlist, 0));
+      if (length == NULL)
+	ffecom_char_args_with_null_ (&item, &ign_length,
+				     ffecom_concat_list_expr_ (catlist, 0));
+      else
+	ffecom_char_args_ (&item, length,
+			   ffecom_concat_list_expr_ (catlist, 0));
       ffecom_concat_list_kill_ (catlist);
       assert (item != NULL_TREE);
       return item;
@@ -10943,8 +10980,13 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
 
     for (i = 0; i < count; ++i)
       {
-	ffecom_char_args_ (&citem, &clength,
-			   ffecom_concat_list_expr_ (catlist, i));
+	if ((i == count)
+	    && (length == NULL))
+	  ffecom_char_args_with_null_ (&citem, &clength,
+				       ffecom_concat_list_expr_ (catlist, i));
+	else
+	  ffecom_char_args_ (&citem, &clength,
+			     ffecom_concat_list_expr_ (catlist, i));
 	if ((citem == error_mark_node)
 	    || (clength == error_mark_node))
 	  {
@@ -10963,10 +11005,11 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
 				     citem),
 		      items);
 	clength = ffecom_save_tree (clength);
-	known_length
-	  = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
-		      known_length,
-		      clength);
+	if (length != NULL)
+	  known_length
+	    = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
+			known_length,
+			clength);
 	lengths
 	  = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
 		      ffecom_modify (void_type_node,
@@ -11015,7 +11058,8 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
 		     item,
 		     temporary);
 
-    *length = known_length;
+    if (length != NULL)
+      *length = known_length;
   }
 
   ffecom_concat_list_kill_ (catlist);

gcc/f/news.texi

@@ -27,6 +27,26 @@ involve a combination of these elements.
 @heading In 0.5.22:
 @itemize @bullet
 @item
+@item
+Improve diagnostic messages from @code{libf2c}
+so it is more likely that the printing of the
+active format string is limited to the string,
+with no trailing garbage being printed.
+
+(Unlike @code{f2c}, @code{g77} does not append
+a null byte to its compiled form of every
+format string specified via a @code{FORMAT} statement.
+However, @code{f2c} would exhibit the problem
+anyway for a statement like @samp{PRINT '(I)garbage', 1}
+by printing @samp{(I)garbage} as the format string.)
+
+@item
+Improve compilation of FORMAT expressions so that
+a null byte is appended to the last operand if it
+is a constant.
+This provides a cleaner run-time diagnostic as provided
+by @code{libf2c} for statements like @samp{PRINT '(I1', 42}.
+
 Fix @code{SIGNAL} intrinsic so it offers portable
 support for 64-bit systems (such as Digital Alphas
 running GNU/Linux).

gcc/f/ste.c

@@ -999,7 +999,6 @@ ffeste_io_cilist_ (bool have_err,
   int yes;
   tree field;
   tree inits, initn;
-  tree ignore;			/* We ignore the length of format! */
   bool constantp = TRUE;
   static tree errfield, unitfield, endfield, formatfield, recfield;
   tree errinit, unitinit, endinit, formatinit, recinit;
@@ -1086,7 +1085,7 @@ ffeste_io_cilist_ (bool have_err,
       break;
 
     case FFESTV_formatCHAREXPR:
-      formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, &ignore);
+      formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
       if (TREE_CONSTANT (formatexp))
 	{
 	  formatinit = formatexp;
@@ -1305,7 +1304,6 @@ ffeste_io_icilist_ (bool have_err,
   int yes;
   tree field;
   tree inits, initn;
-  tree ignore;			/* We ignore the length of format! */
   bool constantp = TRUE;
   static tree errfield, unitfield, endfield, formatfield, unitlenfield,
     unitnumfield;
@@ -1409,7 +1407,7 @@ ffeste_io_icilist_ (bool have_err,
       break;
 
     case FFESTV_formatCHAREXPR:
-      formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, &ignore);
+      formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
       if (TREE_CONSTANT (formatexp))
 	{
 	  formatinit = formatexp;

gcc/f/target.c

@@ -280,6 +280,13 @@ ffetarget_align (ffetargetAlign *updated_alignment,
   return min_pad;
 }
 
+/* Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
+
 #if FFETARGET_okCHARACTER1
 bool
 ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
@@ -290,8 +297,9 @@ ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
     val->text = NULL;
   else
     {
-      val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length);
+      val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length + 1);
       memcpy (val->text, ffelex_token_text (character), val->length);
+      val->text[val->length] = '\0';
     }
 
   return TRUE;
@@ -318,7 +326,12 @@ ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r)
 #endif
 /* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
 
-   Compare lengths, if equal then use memcmp.  */
+   Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
 
 #if FFETARGET_okCHARACTER1
 ffebad
@@ -331,11 +344,12 @@ ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
     res->text = NULL;
   else
     {
-      res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len);
+      res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1);
       if (l.length != 0)
 	memcpy (res->text, l.text, l.length);
       if (r.length != 0)
 	memcpy (res->text + l.length, r.text, r.length);
+      res->text[*len] = '\0';
     }
 
   return FFEBAD;
@@ -501,7 +515,12 @@ ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l,
 #endif
 /* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
 
-   Compare lengths, if equal then use memcmp.  */
+   Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
 
 #if FFETARGET_okCHARACTER1
 ffebad
@@ -519,8 +538,9 @@ ffetarget_substr_character1 (ffetargetCharacter1 *res,
   else
     {
       res->length = *len = last - first + 1;
-      res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len);
+      res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len + 1);
       memcpy (res->text, l.text + first - 1, *len);
+      res->text[*len] = '\0';
     }
 
   return FFEBAD;
@@ -666,6 +686,13 @@ ffetarget_convert_any_typeless_ (char *res, size_t size,
   return FFEBAD;
 }
 
+/* Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
+
 #if FFETARGET_okCHARACTER1
 ffebad
 ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
@@ -678,7 +705,7 @@ ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
     res->text = NULL;
   else
     {
-      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
+      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
       if (size <= l.length)
 	memcpy (res->text, l.text, size);
       else
@@ -686,12 +713,21 @@ ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
 	  memcpy (res->text, l.text, l.length);
 	  memset (res->text + l.length, ' ', size - l.length);
 	}
+      res->text[size] = '\0';
     }
 
   return FFEBAD;
 }
 
 #endif
+
+/* Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
+
 #if FFETARGET_okCHARACTER1
 ffebad
 ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
@@ -703,7 +739,8 @@ ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
     res->text = NULL;
   else
     {
-      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
+      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
+      res->text[size] = '\0';
       if (size <= l.length)
 	{
 	  char *p;
@@ -727,7 +764,14 @@ ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
 }
 
 #endif
-/* ffetarget_convert_character1_integer1 -- Raw conversion.  */
+/* ffetarget_convert_character1_integer4 -- Raw conversion.
+
+   Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
 
 #if FFETARGET_okCHARACTER1
 ffebad
@@ -788,7 +832,8 @@ ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res,
     res->text = NULL;
   else
     {
-      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
+      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
+      res->text[size] = '\0';
       if (((size_t) size) <= size_of)
 	{
 	  int i = size_of - size;
@@ -813,7 +858,14 @@ ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res,
 }
 
 #endif
-/* ffetarget_convert_character1_logical1 -- Raw conversion.  */
+/* ffetarget_convert_character1_logical4 -- Raw conversion.
+
+   Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
 
 #if FFETARGET_okCHARACTER1
 ffebad
@@ -874,7 +926,8 @@ ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res,
     res->text = NULL;
   else
     {
-      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
+      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
+      res->text[size] = '\0';
       if (((size_t) size) <= size_of)
 	{
 	  int i = size_of - size;
@@ -899,7 +952,14 @@ ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res,
 }
 
 #endif
-/* ffetarget_convert_character1_typeless -- Raw conversion.  */
+/* ffetarget_convert_character1_typeless -- Raw conversion.
+
+   Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
 
 #if FFETARGET_okCHARACTER1
 ffebad
@@ -960,7 +1020,8 @@ ffetarget_convert_character1_typeless (ffetargetCharacter1 *res,
     res->text = NULL;
   else
     {
-      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
+      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
+      res->text[size] = '\0';
       if (((size_t) size) <= size_of)
 	{
 	  int i = size_of - size;
@@ -1101,17 +1162,21 @@ ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
 #endif
 /* ffetarget_hollerith -- Convert token to a hollerith constant
 
-   See prototype.
-
-   Token use count not affected overall.  */
+   Always append a null byte to the end, in case this is wanted in
+   a special case such as passing a string as a FORMAT or %REF.
+   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
+   because it isn't a "feature" that is self-documenting.  Use the
+   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
+   in the code.  */
 
 bool
 ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
 		     mallocPool pool)
 {
   val->length = ffelex_token_length (integer);
-  val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length);
+  val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length + 1);
   memcpy (val->text, ffelex_token_text (integer), val->length);
+  val->text[val->length] = '\0';
 
   return TRUE;
 }