void
read_x (st_parameter_dt * dtp, int n)
{
if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
dtp->u.p.sf_read_comma = 0;
if (n > 0)
read_sf (dtp, &n, 1);
dtp->u.p.sf_read_comma = 1;
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
}
static void
namelist_write_newline (st_parameter_dt *dtp)
{
if (!is_internal_unit (dtp))
{
#ifdef HAVE_CRLF
write_character (dtp, "\r\n", 1, 2);
#else
write_character (dtp, "\n", 1, 1);
#endif
return;
}
if (is_array_io (dtp))
{
gfc_offset record;
int finished, length;
length = (int) dtp->u.p.current_unit->bytes_left;
/* Now that the current record has been padded out,
determine where the next record in the array is. */
record = next_array_record (dtp, dtp->u.p.current_unit->ls,
&finished);
if (finished)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
else
{
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
}
else
write_character (dtp, " ", 1, 1);
}
void
read_x (st_parameter_dt *dtp, int n)
{
int length;
char *p, q;
if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
if (n == 0)
return;
length = n;
if (is_internal_unit (dtp))
{
p = mem_alloc_r (dtp->u.p.current_unit->s, &length);
if (unlikely (length < n))
n = length;
goto done;
}
if (dtp->u.p.sf_seen_eor)
return;
p = fbuf_read (dtp->u.p.current_unit, &length);
if (p == NULL)
{
hit_eof (dtp);
return;
}
if (length == 0 && dtp->u.p.item_count == 1)
{
if (dtp->u.p.current_unit->pad_status == PAD_NO)
{
hit_eof (dtp);
return;
}
else
return;
}
n = 0;
while (n < length)
{
q = *p;
if (q == '\n' || q == '\r')
{
/* Unexpected end of line. Set the position. */
fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
dtp->u.p.sf_seen_eor = 1;
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
/* See if there is an LF. Use fbuf_read rather then fbuf_getc so
the position is not advanced unless it really is an LF. */
int readlen = 1;
p = fbuf_read (dtp->u.p.current_unit, &readlen);
if (*p == '\n' && readlen == 1)
{
dtp->u.p.sf_seen_eor = 2;
fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
}
}
goto done;
}
n++;
p++;
}
fbuf_seek (dtp->u.p.current_unit, n, SEEK_CUR);
done:
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) n;
dtp->u.p.current_unit->bytes_left -= n;
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
}
void
parse_format (st_parameter_dt *dtp)
{
format_data *fmt;
bool format_cache_ok, seen_data_desc = false;
/* Don't cache for internal units and set an arbitrary limit on the size of
format strings we will cache. (Avoids memory issues.) */
format_cache_ok = !is_internal_unit (dtp);
/* Lookup format string to see if it has already been parsed. */
if (format_cache_ok)
{
dtp->u.p.fmt = find_parsed_format (dtp);
if (dtp->u.p.fmt != NULL)
{
dtp->u.p.fmt->reversion_ok = 0;
dtp->u.p.fmt->saved_token = FMT_NONE;
dtp->u.p.fmt->saved_format = NULL;
reset_fnode_counters (dtp);
return;
}
}
/* Not found so proceed as follows. */
dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
fmt->format_string = dtp->format;
fmt->format_string_len = dtp->format_len;
fmt->string = NULL;
fmt->saved_token = FMT_NONE;
fmt->error = NULL;
fmt->value = 0;
/* Initialize variables used during traversal of the tree. */
fmt->reversion_ok = 0;
fmt->saved_format = NULL;
/* Allocate the first format node as the root of the tree. */
fmt->last = &fmt->array;
fmt->last->next = NULL;
fmt->avail = &fmt->array.array[0];
memset (fmt->avail, 0, sizeof (*fmt->avail));
fmt->avail->format = FMT_LPAREN;
fmt->avail->repeat = 1;
fmt->avail++;
if (format_lex (fmt) == FMT_LPAREN)
fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok,
&seen_data_desc);
else
fmt->error = "Missing initial left parenthesis in format";
if (fmt->error)
{
format_error (dtp, NULL, fmt->error);
free_format_hash_table (dtp->u.p.current_unit);
return;
}
if (format_cache_ok)
save_parsed_format (dtp);
else
dtp->u.p.format_not_saved = 1;
}
void
read_x (st_parameter_dt *dtp, int n)
{
int length, q, q2;
if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
if (n == 0)
return;
length = n;
if (is_internal_unit (dtp))
{
mem_alloc_r (dtp->u.p.current_unit->s, &length);
if (unlikely (length < n))
n = length;
goto done;
}
if (dtp->u.p.sf_seen_eor)
return;
n = 0;
while (n < length)
{
q = fbuf_getc (dtp->u.p.current_unit);
if (q == EOF)
break;
else if (q == '\n' || q == '\r')
{
/* Unexpected end of line. Set the position. */
dtp->u.p.sf_seen_eor = 1;
/* If we see an EOR during non-advancing I/O, we need to skip
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
/* See if there is an LF. */
q2 = fbuf_getc (dtp->u.p.current_unit);
if (q2 == '\n')
dtp->u.p.sf_seen_eor = 2;
else if (q2 != EOF) /* Oops, seek back. */
fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
}
goto done;
}
n++;
}
done:
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) n;
dtp->u.p.current_unit->bytes_left -= n;
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
}
