}
+/* Free the line buffer if necessary. */
+
+static void
+free_line (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.line_buffer == NULL)
+ return;
+
+ free_mem (dtp->u.p.line_buffer);
+ dtp->u.p.line_buffer = NULL;
+}
+
+
static char
next_char (st_parameter_dt *dtp)
{
int length;
+ gfc_offset record;
char c, *p;
if (dtp->u.p.last_char != '\0')
goto done;
}
- length = 1;
+ /* Read from line_buffer if enabled. */
- p = salloc_r (dtp->u.p.current_unit->s, &length);
- if (p == NULL)
+ if (dtp->u.p.line_buffer_enabled)
+ {
+ dtp->u.p.at_eol = 0;
+
+ c = dtp->u.p.line_buffer[dtp->u.p.item_count];
+ if (c != '\0' && dtp->u.p.item_count < 64)
+ {
+ dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
+ dtp->u.p.item_count++;
+ goto done;
+ }
+
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
+ }
+
+ /* Handle the end-of-record condition for internal array unit */
+ if (is_array_io(dtp) && dtp->u.p.current_unit->bytes_left == 0)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
- return '\0';
+ c = '\n';
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+
+ /* Check for "end-of-file" condition */
+ if (record == 0)
+ longjmp (*dtp->u.p.eof_jump, 1);
+
+ record *= dtp->u.p.current_unit->recl;
+
+ if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ longjmp (*dtp->u.p.eof_jump, 1);
+
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ goto done;
}
- if (length == 0)
+ /* Get the next character and handle end-of-record conditions */
+
+ length = 1;
+
+ p = salloc_r (dtp->u.p.current_unit->s, &length);
+
+ if (is_internal_unit(dtp))
{
- /* For internal files return a newline instead of signalling EOF. */
- /* ??? This isn't quite right, but we don't handle internal files
- with multiple records. */
- if (is_internal_unit (dtp))
- c = '\n';
+ if (is_array_io(dtp))
+ {
+ /* End of record is handled in the next pass through, above. The
+ check for NULL here is cautionary. */
+ if (p == NULL)
+ {
+ generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
+ return '\0';
+ }
+
+ dtp->u.p.current_unit->bytes_left--;
+ c = *p;
+ }
else
- longjmp (*dtp->u.p.eof_jump, 1);
+ {
+ if (p == NULL)
+ longjmp (*dtp->u.p.eof_jump, 1);
+ if (length == 0)
+ c = '\n';
+ else
+ c = *p;
+ }
}
else
- c = *p;
-
+ {
+ if (p == NULL)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return '\0';
+ }
+ if (length == 0)
+ longjmp (*dtp->u.p.eof_jump, 1);
+ c = *p;
+ }
done:
dtp->u.p.at_eol = (c == '\n' || c == '\r');
return c;
static void
eat_separator (st_parameter_dt *dtp)
{
- char c;
+ char c, n;
eat_spaces (dtp);
dtp->u.p.comma_flag = 0;
dtp->u.p.input_complete = 1;
break;
- case '\n':
case '\r':
+ n = next_char(dtp);
+ if (n == '\n')
+ dtp->u.p.at_eol = 1;
+ else
+ {
+ unget_char (dtp, n);
+ unget_char (dtp, c);
+ }
+ break;
+
+ case '\n':
dtp->u.p.at_eol = 1;
break;
else
{
c = eat_spaces (dtp);
- if (c == '\n')
+ if (c == '\n' || c == '\r')
goto restart;
}
}
+/* To read a logical we have to look ahead in the input stream to make sure
+ there is not an equal sign indicating a variable name. To do this we use
+ line_buffer to point to a temporary buffer, pushing characters there for
+ possible later reading. */
+
+static void
+l_push_char (st_parameter_dt *dtp, char c)
+{
+ char *new;
+
+ if (dtp->u.p.line_buffer == NULL)
+ {
+ dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
+ memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
+ }
+
+ dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
+}
+
+
/* Read a logical character on the input. */
static void
read_logical (st_parameter_dt *dtp, int length)
{
char c, message[100];
- int v;
+ int i, v;
if (parse_repeat (dtp))
return;
- c = next_char (dtp);
+ c = tolower (next_char (dtp));
+ l_push_char (dtp, c);
switch (c)
{
case 't':
- case 'T':
v = 1;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+
+ if (!is_separator(c))
+ goto possible_name;
+
+ unget_char (dtp, c);
break;
case 'f':
- case 'F':
v = 0;
- break;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+
+ if (!is_separator(c))
+ goto possible_name;
+ unget_char (dtp, c);
+ break;
case '.':
- c = next_char (dtp);
+ c = tolower (next_char (dtp));
switch (c)
{
- case 't':
- case 'T':
- v = 1;
- break;
- case 'f':
- case 'F':
- v = 0;
- break;
- default:
- goto bad_logical;
+ case 't':
+ v = 1;
+ break;
+ case 'f':
+ v = 0;
+ break;
+ default:
+ goto bad_logical;
}
break;
unget_char (dtp, c);
eat_separator (dtp);
- free_saved (dtp);
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
set_integer ((int *) dtp->u.p.value, v, length);
return;
+ possible_name:
+
+ for(i = 0; i < 63; i++)
+ {
+ c = next_char (dtp);
+ if (is_separator(c))
+ {
+ /* All done if this is not a namelist read. */
+ if (!dtp->u.p.namelist_mode)
+ goto logical_done;
+
+ unget_char (dtp, c);
+ eat_separator (dtp);
+ c = next_char (dtp);
+ if (c != '=')
+ {
+ unget_char (dtp, c);
+ goto logical_done;
+ }
+ }
+
+ l_push_char (dtp, c);
+ if (c == '=')
+ {
+ dtp->u.p.nml_read_error = 1;
+ dtp->u.p.line_buffer_enabled = 1;
+ dtp->u.p.item_count = 0;
+ return;
+ }
+
+ }
+
bad_logical:
if (nml_bad_return (dtp, c))
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ return;
+
+ logical_done:
+
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
+ dtp->u.p.saved_type = BT_LOGICAL;
+ dtp->u.p.saved_length = length;
+ set_integer ((int *) dtp->u.p.value, v, length);
}
goto done;
}
- if (c != '\n')
+ if (c != '\n' && c != '\r')
push_char (dtp, c);
break;
{ /* Found a null value. */
eat_separator (dtp);
dtp->u.p.repeat_count = 0;
+
+ /* eat_separator sets this flag if the separator was a comma */
+ if (dtp->u.p.comma_flag)
+ goto cleanup;
+
+ /* eat_separator sets this flag if the separator was a \n or \r */
if (dtp->u.p.at_eol)
finish_separator (dtp);
- else
+ else
goto cleanup;
}
eat_spaces (dtp);
neg = 0;
- /*process a potential sign. */
-
+ /* Process a potential sign. */
c = next_char (dtp);
switch (c)
{
break;
}
- /*process characters up to the next ':' , ',' or ')' */
-
+ /* Process characters up to the next ':' , ',' or ')'. */
for (;;)
{
c = next_char (dtp);
break;
case ',': case ')':
- if ( (c==',' && dim == rank -1)
- || (c==')' && dim < rank -1))
+ if ((c==',' && dim == rank -1)
+ || (c==')' && dim < rank -1))
{
st_sprintf (parse_err_msg,
"Bad number of index fields");
}
if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
- || (indx == 2 && dtp->u.p.saved_string == 0))
+ || (indx == 2 && dtp->u.p.saved_string == 0))
{
st_sprintf(parse_err_msg, "Bad index triplet");
goto err_ret;
/* If '( : ? )' or '( ? : )' break and flag read failure. */
null_flag = 0;
if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
- || (indx==1 && dtp->u.p.saved_string == 0))
+ || (indx==1 && dtp->u.p.saved_string == 0))
{
null_flag = 1;
break;
}
/* Now read the index. */
-
- if (convert_integer (dtp, sizeof(int), neg))
+ if (convert_integer (dtp, sizeof(ssize_t), neg))
{
st_sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
break;
}
- /*feed the index values to the triplet arrays. */
-
+ /* Feed the index values to the triplet arrays. */
if (!null_flag)
{
if (indx == 0)
- ls[dim].start = *(int *)dtp->u.p.value;
+ memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
if (indx == 1)
- ls[dim].end = *(int *)dtp->u.p.value;
+ memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
if (indx == 2)
- ls[dim].step = *(int *)dtp->u.p.value;
+ memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
}
- /*singlet or doublet indices */
-
+ /* Singlet or doublet indices. */
if (c==',' || c==')')
{
if (indx == 0)
{
- ls[dim].start = *(int *)dtp->u.p.value;
- ls[dim].end = *(int *)dtp->u.p.value;
+ memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
+ ls[dim].end = ls[dim].start;
}
break;
}
}
- /*Check the values of the triplet indices. */
-
- if ( (ls[dim].start > (ssize_t)ad[dim].ubound)
- || (ls[dim].start < (ssize_t)ad[dim].lbound)
- || (ls[dim].end > (ssize_t)ad[dim].ubound)
- || (ls[dim].end < (ssize_t)ad[dim].lbound))
+ /* Check the values of the triplet indices. */
+ if ((ls[dim].start > (ssize_t)ad[dim].ubound)
+ || (ls[dim].start < (ssize_t)ad[dim].lbound)
+ || (ls[dim].end > (ssize_t)ad[dim].ubound)
+ || (ls[dim].end < (ssize_t)ad[dim].lbound))
{
st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
goto err_ret;
}
if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
- || (ls[dim].step == 0))
+ || (ls[dim].step == 0))
{
st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
goto err_ret;
}
/* Initialise the loop index counter. */
-
ls[dim].idx = ls[dim].start;
-
}
eat_spaces (dtp);
return SUCCESS;
/* "&namelist_name\n" */
len = dtp->namelist_name_len;
+#ifdef HAVE_CRLF
+ p = write_block (dtp, len + 3);
+#else
p = write_block (dtp, len + 2);
+#endif
if (!p)
goto query_return;
memcpy (p, "&", 1);
memcpy ((char*)(p + 1), dtp->namelist_name, len);
+#ifdef HAVE_CRLF
+ memcpy ((char*)(p + len + 1), "\r\n", 2);
+#else
memcpy ((char*)(p + len + 1), "\n", 1);
+#endif
for (nl = dtp->u.p.ionml; nl; nl = nl->next)
{
/* " var_name\n" */
len = strlen (nl->var_name);
+#ifdef HAVE_CRLF
+ p = write_block (dtp, len + 3);
+#else
p = write_block (dtp, len + 2);
+#endif
if (!p)
goto query_return;
memcpy (p, " ", 1);
memcpy ((char*)(p + 1), nl->var_name, len);
+#ifdef HAVE_CRLF
+ memcpy ((char*)(p + len + 1), "\r\n", 2);
+#else
memcpy ((char*)(p + len + 1), "\n", 1);
+#endif
}
/* "&end\n" */
+#ifdef HAVE_CRLF
+ p = write_block (dtp, 6);
+#else
p = write_block (dtp, 5);
+#endif
if (!p)
goto query_return;
+#ifdef HAVE_CRLF
+ memcpy (p, "&end\r\n", 6);
+#else
memcpy (p, "&end\n", 5);
+#endif
}
/* Flush the stream to force immediate output. */
dtp->u.p.eof_jump = NULL;
free_saved (dtp);
+ free_line (dtp);
return;
/* All namelist error calls return from here */
dtp->u.p.eof_jump = NULL;
free_saved (dtp);
+ free_line (dtp);
generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
return;
}
OSDN Git Service
