With the attached patch, I have taken a different approach. I have created two
function pointers in the gfc_unit structure. These pointers are set to more
specific versions of next_char and push_char that are geared to the type of I/O
being performed.
This removes the tests for IO type out of the functions and moves these to the
beginning of the read. I have not tested for performance yet, but this should
improve performance by eliminating some tests from each character read.
The function pointers are set by a new function I have called set_workers. The
new versions of next_char and push_char I have referred to as worker functions.
The revised test case is attached.
Regression tested on x86-64. OK for trunk? and later 4.9
Jerry
2014-05-04 Jerry DeLisle <[email protected]>
PR libfortran/52539
* io/io.h (gfc_unit): New function pointers *next_char_fn_ptr
and *push_char_fn_ptr.
*io/list_read.c (next_char): Create macro with this name to call
the new function pointer. Split the original next_char function
into three new functions. (next_char_default, next_char_internal,
next_char_utf8): New functions. (push_char): Create macro with
this name to call new function pointer. Split the original
push_char into three new functions. (push_char_default,
push_char_internal, push_char4): New functions. (set_workers):
New function to initialize the function pointers depending on the
type of IO to be performed. (list_formatted_read_scalar): Use
set_workers function. (finish_list_read): Likewise.
(namelist_read): Likewise.
(nml_get_obj_data): Use push_char_default.
Index: io.h
===================================================================
--- io.h (revision 210026)
+++ io.h (working copy)
@@ -575,6 +575,10 @@ typedef struct gfc_unit
/* Formatting buffer. */
struct fbuf *fbuf;
+
+ /* Function pointer, points to list_read worker functions. */
+ int (*next_char_fn_ptr) (st_parameter_dt *);
+ void (*push_char_fn_ptr) (st_parameter_dt *, int);
}
gfc_unit;
Index: list_read.c
===================================================================
--- list_read.c (revision 210026)
+++ list_read.c (working copy)
@@ -67,10 +67,17 @@ typedef unsigned char uchar;
#define MSGLEN 100
-/* Save a character to a string buffer, enlarging it as necessary. */
+/* Wrappers for calling the current worker functions. */
+
+#define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp))
+#define push_char(dtp, c) ((dtp)->u.p.current_unit->push_char_fn_ptr (dtp, c))
+
+/* Worker function to save a default KIND=1 character to a string
+ buffer, enlarging it as necessary. */
+
static void
-push_char (st_parameter_dt *dtp, char c)
+push_char_default (st_parameter_dt *dtp, int c)
{
char *new;
@@ -96,14 +103,15 @@ static void
}
- dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
+ dtp->u.p.saved_string[dtp->u.p.saved_used++] = (char) c;
}
-/* Save a KIND=4 character to a string buffer, enlarging the buffer
- as necessary. */
+/* Worker function to save a KIND=4 character to a string buffer,
+ enlarging the buffer as necessary. */
+
static void
-push_char4 (st_parameter_dt *dtp, gfc_char4_t c)
+push_char4 (st_parameter_dt *dtp, int c)
{
gfc_char4_t *new, *p = (gfc_char4_t *) dtp->u.p.saved_string;
@@ -118,12 +126,12 @@ static void
if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
{
dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
- new = realloc (p, dtp->u.p.saved_length);
+ new = realloc (p, dtp->u.p.saved_length * sizeof (gfc_char4_t));
if (new == NULL)
generate_error (&dtp->common, LIBERROR_OS, NULL);
p = new;
- memset (new + dtp->u.p.saved_used, 0,
+ memset4 (new + dtp->u.p.saved_used, 0,
dtp->u.p.saved_length - dtp->u.p.saved_used);
}
@@ -162,13 +170,16 @@ free_line (st_parameter_dt *dtp)
}
+/* Unget saves the last character so when reading the next character,
+ we need to check to see if there is a character waiting. Similar,
+ if the line buffer is being used to read_logical, check it too. */
+
static int
-next_char (st_parameter_dt *dtp)
+check_buffers (st_parameter_dt *dtp)
{
- ssize_t length;
- gfc_offset record;
int c;
+ c = '\0';
if (dtp->u.p.last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
@@ -194,7 +205,44 @@ static int
dtp->u.p.line_buffer_pos = 0;
dtp->u.p.line_buffer_enabled = 0;
}
+
+done:
+ dtp->u.p.at_eol = (c == '\n' || c == EOF);
+ return c;
+}
+
+/* Worker function for default character encoded file. */
+static int
+next_char_default (st_parameter_dt *dtp)
+{
+ int c;
+
+ /* Always check the unget and line buffer first. */
+ if ((c = check_buffers (dtp)))
+ return c;
+
+ c = fbuf_getc (dtp->u.p.current_unit);
+ if (c != EOF && is_stream_io (dtp))
+ dtp->u.p.current_unit->strm_pos++;
+
+ dtp->u.p.at_eol = (c == '\n' || c == EOF);
+ return c;
+}
+
+
+/* Worker function for internal and array I/O units. */
+static int
+next_char_internal (st_parameter_dt *dtp)
+{
+ ssize_t length;
+ gfc_offset record;
+ int c;
+
+ /* Always check the unget and line buffer first. */
+ if ((c = check_buffers (dtp)))
+ return c;
+
/* Handle the end-of-record and end-of-file conditions for
internal array unit. */
if (is_array_io (dtp))
@@ -229,58 +277,50 @@ static int
/* Get the next character and handle end-of-record conditions. */
- if (is_internal_unit (dtp))
+ if (dtp->common.unit) /* Check for kind=4 internal unit. */
+ length = sread (dtp->u.p.current_unit->s, &c, sizeof (gfc_char4_t));
+ else
+ {
+ char cc;
+ length = sread (dtp->u.p.current_unit->s, &cc, 1);
+ c = cc;
+ }
+
+ if (unlikely (length < 0))
{
- /* Check for kind=4 internal unit. */
- if (dtp->common.unit)
- length = sread (dtp->u.p.current_unit->s, &c, sizeof (gfc_char4_t));
- else
- {
- char cc;
- length = sread (dtp->u.p.current_unit->s, &cc, 1);
- c = cc;
- }
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return '\0';
+ }
- if (unlikely (length < 0))
+ if (is_array_io (dtp))
+ {
+ /* Check whether we hit EOF. */
+ if (unlikely (length == 0))
{
- generate_error (&dtp->common, LIBERROR_OS, NULL);
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return '\0';
- }
-
- if (is_array_io (dtp))
- {
- /* Check whether we hit EOF. */
- if (unlikely (length == 0))
- {
- generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
- return '\0';
- }
- dtp->u.p.current_unit->bytes_left--;
- }
- else
- {
- if (dtp->u.p.at_eof)
- return EOF;
- if (length == 0)
- {
- c = '\n';
- dtp->u.p.at_eof = 1;
- }
- }
+ }
+ dtp->u.p.current_unit->bytes_left--;
}
else
{
- c = fbuf_getc (dtp->u.p.current_unit);
- if (c != EOF && is_stream_io (dtp))
- dtp->u.p.current_unit->strm_pos++;
+ if (dtp->u.p.at_eof)
+ return EOF;
+ if (length == 0)
+ {
+ c = '\n';
+ dtp->u.p.at_eof = 1;
+ }
}
+
done:
dtp->u.p.at_eol = (c == '\n' || c == EOF);
return c;
}
-static gfc_char4_t
+/* Worker function for UTF encoded files. */
+static int
next_char_utf8 (st_parameter_dt *dtp)
{
static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
@@ -288,9 +328,12 @@ next_char_utf8 (st_parameter_dt *dtp)
int i, nb;
gfc_char4_t c;
- c = next_char (dtp);
+ /* Always check the unget and line buffer first. */
+ if (!(c = check_buffers (dtp)))
+ c = fbuf_getc (dtp->u.p.current_unit);
+
if (c < 0x80)
- return c;
+ goto utf_done;
/* The number of leading 1-bits in the first byte indicates how many
bytes follow. */
@@ -305,11 +348,9 @@ next_char_utf8 (st_parameter_dt *dtp)
/* Decode the bytes read. */
for (i = 1; i < nb; i++)
{
- gfc_char4_t n = next_char (dtp);
-
+ gfc_char4_t n = fbuf_getc (dtp->u.p.current_unit);
if ((n & 0xC0) != 0x80)
goto invalid;
-
c = ((c << 6) + (n & 0x3F));
}
@@ -324,7 +365,9 @@ next_char_utf8 (st_parameter_dt *dtp)
if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
goto invalid;
- return c;
+utf_done:
+ dtp->u.p.at_eol = (c == '\n' || c == (gfc_char4_t) EOF);
+ return (int) c;
invalid:
generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
@@ -1172,96 +1215,50 @@ read_character (st_parameter_dt *dtp, int length _
get_string:
- if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
- for (;;)
- {
- if ((c = next_char_utf8 (dtp)) == EOF)
- goto done_eof;
- switch (c)
- {
- case '"':
- case '\'':
- if (c != quote)
- {
- push_char4 (dtp, c);
- break;
- }
+ for (;;)
+ {
+ if ((c = next_char (dtp)) == EOF)
+ goto done_eof;
+ switch (c)
+ {
+ case '"':
+ case '\'':
+ if (c != quote)
+ {
+ push_char (dtp, c);
+ break;
+ }
- /* See if we have a doubled quote character or the end of
- the string. */
+ /* See if we have a doubled quote character or the end of
+ the string. */
- if ((c = next_char_utf8 (dtp)) == EOF)
- goto done_eof;
- if (c == quote)
- {
- push_char4 (dtp, quote);
- break;
- }
+ if ((c = next_char (dtp)) == EOF)
+ goto done_eof;
+ if (c == quote)
+ {
+ push_char (dtp, quote);
+ break;
+ }
- unget_char (dtp, c);
- goto done;
+ unget_char (dtp, c);
+ goto done;
- CASE_SEPARATORS:
- if (quote == ' ')
- {
- unget_char (dtp, c);
- goto done;
- }
+ CASE_SEPARATORS:
+ if (quote == ' ')
+ {
+ unget_char (dtp, c);
+ goto done;
+ }
- if (c != '\n' && c != '\r')
- push_char4 (dtp, c);
- break;
+ if (c != '\n' && c != '\r')
+ push_char (dtp, c);
+ break;
- default:
- push_char4 (dtp, c);
- break;
- }
- }
- else
- for (;;)
- {
- if ((c = next_char (dtp)) == EOF)
- goto done_eof;
- switch (c)
- {
- case '"':
- case '\'':
- if (c != quote)
- {
- push_char (dtp, c);
- break;
- }
-
- /* See if we have a doubled quote character or the end of
- the string. */
-
- if ((c = next_char (dtp)) == EOF)
- goto done_eof;
- if (c == quote)
- {
- push_char (dtp, quote);
- break;
- }
-
- unget_char (dtp, c);
- goto done;
-
- CASE_SEPARATORS:
- if (quote == ' ')
- {
- unget_char (dtp, c);
- goto done;
- }
-
- if (c != '\n' && c != '\r')
- push_char (dtp, c);
- break;
-
- default:
- push_char (dtp, c);
- break;
- }
- }
+ default:
+ push_char (dtp, c);
+ break;
+ }
+ }
/* At this point, we have to have a separator, or else the string is
invalid. */
@@ -2025,6 +2022,30 @@ check_type (st_parameter_dt *dtp, bt type, int kin
}
+/* Initialize the function pointers to select the correct versions of
+ next_char and push_char depending on what we are doing. */
+
+static void
+set_workers (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+ {
+ dtp->u.p.current_unit->next_char_fn_ptr = &next_char_utf8;
+ dtp->u.p.current_unit->push_char_fn_ptr = &push_char4;
+ }
+ else if (is_internal_unit (dtp))
+ {
+ dtp->u.p.current_unit->next_char_fn_ptr = &next_char_internal;
+ dtp->u.p.current_unit->push_char_fn_ptr = &push_char_default;
+ }
+ else
+ {
+ dtp->u.p.current_unit->next_char_fn_ptr = &next_char_default;
+ dtp->u.p.current_unit->push_char_fn_ptr = &push_char_default;
+ }
+
+}
+
/* Top level data transfer subroutine for list reads. Because we have
to deal with repeat counts, the data item is always saved after
reading, usually in the dtp->u.p.value[] array. If a repeat count is
@@ -2040,6 +2061,9 @@ list_formatted_read_scalar (st_parameter_dt *dtp,
dtp->u.p.namelist_mode = 0;
+ /* Set the next_char and push_char worker functions. */
+ set_workers (dtp);
+
if (dtp->u.p.first_item)
{
dtp->u.p.first_item = 0;
@@ -2174,7 +2182,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp,
memcpy (p, dtp->u.p.saved_string, m);
else
for (i = 0; i < m; i++)
- *q++ = (unsigned char) dtp->u.p.saved_string[i];
+ *q++ = *r++;
}
}
else
@@ -2256,6 +2264,10 @@ finish_list_read (st_parameter_dt *dtp)
if (!is_internal_unit (dtp))
{
int c;
+
+ /* Set the next_char and push_char worker functions. */
+ set_workers (dtp);
+
c = next_char (dtp);
if (c == EOF)
{
@@ -3072,7 +3084,7 @@ get_name:
do
{
if (!is_separator (c))
- push_char (dtp, tolower(c));
+ push_char_default (dtp, tolower(c));
if ((c = next_char (dtp)) == EOF)
goto nml_err_ret;
}
@@ -3087,7 +3099,7 @@ get_name:
are present for an object. (iii) gives the same error message
as (i) */
- push_char (dtp, '\0');
+ push_char_default (dtp, '\0');
if (component_flag)
{
@@ -3326,6 +3338,9 @@ namelist_read (st_parameter_dt *dtp)
dtp->u.p.namelist_mode = 1;
dtp->u.p.input_complete = 0;
dtp->u.p.expanded_read = 0;
+
+ /* Set the next_char and push_char worker functions. */
+ set_workers (dtp);
/* Look for &namelist_name . Skip all characters, testing for $nmlname.
Exit on success or EOF. If '?' or '=?' encountered in stdin, print
! { dg-do run }
! PR52539 UTF-8 support for namelist read and write
character(len=10, kind=4) :: str, str2
character(len=25, kind=4) :: str3
namelist /nml/ str
str = 4_'1a'//char (int (z'4F60'),4) &
//char (int (z'597D'), 4)//4_'b'
open(6, encoding='utf-8')
open(99, encoding='utf-8',form='formatted')
write(99, '(3a)') '&nml str = "', str, '" /'
write(99, '(a)') str
rewind(99)
str = 4_'XXXX'
str2 = 4_'YYYY'
read(99,nml=nml)
read(99, *) str2
if (str2 /= str) call abort
rewind(99)
read(99,'(A)') str3
if (str3 /= 4_'&nml str = "' // str // 4_'" /') call abort
read(99,*) str3
if (str3 /= str) call abort
close(99, status='delete')
end
