Hi all,
The attached patch regression tested on x86-64-linux.
This adds a static function to allocate and extract the DT format string that
may contain doubled quotes.
OK for trunk, test case also attched.
Jerry
2016-12-16 Jerry DeLisle <[email protected]>
PR fortran/78622
* io.c (format_lex): Continue of string delimiter seen.
2016-12-16 Jerry DeLisle <[email protected]>
PR libgfortran/78622
* io/transfer.c (get_dt_format): New static function to alloc
and set the DT iotype string, handling doubled quotes.
(formatted_transfer_scalar_read,
formatted_transfer_scalar_write): Use new function.
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index d35437a..8f4f268 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -486,12 +486,13 @@ format_lex (void)
if (c == delim)
{
c = next_char (NONSTRING);
-
if (c == '\0')
{
token = FMT_END;
break;
}
+ if (c == delim)
+ continue;
unget_char ();
break;
}
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 5830362..c90e8c5 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1264,6 +1264,33 @@ require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
return 1;
}
+static char *
+get_dt_format (char *p, gfc_charlen_type *length)
+{
+ char delim = p[-1]; /* The delimiter is always the first character back. */
+ char c, *q, *res;
+ gfc_charlen_type len = *length; /* This length already correct, less 'DT'. */
+
+ res = q = xmalloc (len + 2);
+
+ /* Set the beginning of the string to 'DT', length adjusted below. */
+ *q++ = 'D';
+ *q++ = 'T';
+
+ /* The string may contain doubled quotes so scan and skip as needed. */
+ for (; len > 0; len--)
+ {
+ c = *q++ = *p++;
+ if (c == delim)
+ p++; /* Skip the doubled delimiter. */
+ }
+
+ /* Adjust the string length by two now that we are done. */
+ *length += 2;
+
+ return res;
+}
+
/* This function is in the main loop for a formatted data transfer
statement. It would be natural to implement this as a coroutine
@@ -1420,7 +1447,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
- char *iotype = f->u.udf.string;
+ char *iotype;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
@@ -1430,13 +1457,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
iotype = dt;
}
else
- {
- iotype_len += 2;
- iotype = xmalloc (iotype_len);
- iotype[0] = dt[0];
- iotype[1] = dt[1];
- memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
- }
+ iotype = get_dt_format (f->u.udf.string, &iotype_len);
/* Set iostat, intent(out). */
noiostat = 0;
@@ -1890,7 +1911,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
- char *iotype = f->u.udf.string;
+ char *iotype;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
@@ -1900,13 +1921,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
iotype = dt;
}
else
- {
- iotype_len += 2;
- iotype = xmalloc (iotype_len);
- iotype[0] = dt[0];
- iotype[1] = dt[1];
- memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
- }
+ iotype = get_dt_format (f->u.udf.string, &iotype_len);
/* Set iostat, intent(out). */
noiostat = 0;
MODULE m
IMPLICIT NONE
TYPE :: t
CHARACTER :: c
CONTAINS
PROCEDURE :: write_formatted
GENERIC :: WRITE(FORMATTED) => write_formatted
END TYPE t
CONTAINS
SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
CLASS(t), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER(*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: v_list(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER(*), INTENT(INOUT) :: iomsg
WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) iotype
END SUBROUTINE write_formatted
END MODULE m
PROGRAM p
USE m
IMPLICIT NONE
CHARACTER(25) :: str
TYPE(t) :: x
WRITE (str, "(DT'a''b')") x
if (str.ne."DTa'b") call abort
END PROGRAM p
