next_char (st_parameter_dt *dtp)
{
int length;
+ gfc_offset record;
char c, *p;
if (dtp->u.p.last_char != '\0')
length = 1;
- p = salloc_r (dtp->u.p.current_unit->s, &length);
- if (p == NULL)
+ /* 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 */
+ 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;
}
goto get_string;
default:
+ if (dtp->u.p.namelist_mode)
+ {
+ unget_char (dtp,c);
+ return;
+ }
push_char (dtp, c);
goto get_string;
}
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. */
OSDN Git Service
