-/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+/* Copyright (C) 2002-2013 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist input contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
if (dtp->u.p.saved_string == NULL)
{
- dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
- // memset below should be commented out.
- memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
+ // Plain malloc should suffice here, zeroing not needed?
+ dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
}
if (is_internal_unit (dtp))
{
- char cc;
- length = sread (dtp->u.p.current_unit->s, &cc, 1);
- c = cc;
+ /* 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;
+ }
+
if (length < 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
err = eat_line (dtp);
if (err)
return err;
- if ((c = next_char (dtp)) == EOF)
- return LIBERROR_END;
- if (c == '!')
- {
- err = eat_line (dtp);
- if (err)
- return err;
- if ((c = next_char (dtp)) == EOF)
- return LIBERROR_END;
- }
+ c = '\n';
}
}
while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
{
char c, *buffer, message[MSGLEN];
int m;
- GFC_INTEGER_LARGEST v, max, max10;
+ GFC_UINTEGER_LARGEST v, max, max10;
+ GFC_INTEGER_LARGEST value;
buffer = dtp->u.p.saved_string;
v = 0;
- max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
+ if (length == -1)
+ max = MAX_REPEAT;
+ else
+ {
+ max = si_max (length);
+ if (negative)
+ max++;
+ }
max10 = max / 10;
for (;;)
if (length != -1)
{
if (negative)
- v = -v;
- set_integer (dtp->u.p.value, v, length);
+ value = -v;
+ else
+ value = v;
+ set_integer (dtp->u.p.value, value, length);
}
else
{
l_push_char (st_parameter_dt *dtp, char c)
{
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 = xcalloc (SCRATCH_SIZE, 1);
dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
}
{
case 't':
v = 1;
- if ((c = next_char (dtp)) == EOF)
- goto bad_logical;
+ c = next_char (dtp);
l_push_char (dtp, c);
- if (!is_separator(c))
+ if (!is_separator(c) && c != EOF)
goto possible_name;
unget_char (dtp, c);
break;
case 'f':
v = 0;
- if ((c = next_char (dtp)) == EOF)
- goto bad_logical;
+ c = next_char (dtp);
l_push_char (dtp, c);
- if (!is_separator(c))
+ if (!is_separator(c) && c != EOF)
goto possible_name;
unget_char (dtp, c);
break;
CASE_SEPARATORS:
+ case EOF:
unget_char (dtp, c);
eat_separator (dtp);
return; /* Null value. */
goto repeat;
CASE_SEPARATORS: /* Not a repeat count. */
+ case EOF:
goto done;
default:
break;
CASE_SEPARATORS:
+ case EOF:
goto done;
default:
break;
CASE_SEPARATORS:
+ case EOF:
unget_char (dtp, c); /* NULL value. */
eat_separator (dtp);
return;
for (;;)
{
- if ((c = next_char (dtp)) == EOF)
- goto eof;
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
break;
CASE_SEPARATORS:
+ case EOF:
unget_char (dtp, c);
goto done; /* String was only digits! */
the string. */
if ((c = next_char (dtp)) == EOF)
- goto eof;
+ goto done_eof;
if (c == quote)
{
push_char (dtp, quote);
case 'E':
case 'd':
case 'D':
+ case 'q':
+ case 'Q':
push_char (dtp, 'e');
goto exp1;
goto exp2;
CASE_SEPARATORS:
+ case EOF:
goto done;
default:
break;
CASE_SEPARATORS:
+ case EOF:
unget_char (dtp, c);
goto done;
&& ((c = next_char (dtp)) == 'y' || c == 'Y')
&& (c = next_char (dtp))))
{
- if (is_separator (c))
+ if (is_separator (c) || (c == EOF))
unget_char (dtp, c);
push_char (dtp, 'i');
push_char (dtp, 'n');
&& ((c = next_char (dtp)) == 'n' || c == 'N')
&& (c = next_char (dtp)))
{
- if (is_separator (c))
+ if (is_separator (c) || (c == EOF))
unget_char (dtp, c);
push_char (dtp, 'n');
push_char (dtp, 'a');
goto bad;
c = next_char (dtp);
- if (is_separator (c))
+ if (is_separator (c) || (c == EOF))
unget_char (dtp, c);
}
goto done_infnan;
break;
CASE_SEPARATORS:
+ case EOF:
unget_char (dtp, c);
eat_separator (dtp);
return;
goto bad_complex;
c = next_char (dtp);
- if (!is_separator (c))
+ if (!is_separator (c) && (c != EOF))
goto bad_complex;
unget_char (dtp, c);
case 'e':
case 'D':
case 'd':
+ case 'Q':
+ case 'q':
goto exp1;
case '+':
goto got_repeat;
CASE_SEPARATORS:
+ case EOF:
if (c != '\n' && c != ',' && c != '\r' && c != ';')
unget_char (dtp, c);
goto done;
case 'e':
case 'D':
case 'd':
+ case 'Q':
+ case 'q':
goto exp1;
case '+':
break;
CASE_SEPARATORS:
+ case EOF:
goto done;
default:
goto unwind;
c = next_char (dtp);
l_push_char (dtp, c);
- if (!is_separator (c))
+ if (!is_separator (c) && (c != EOF))
{
if (c != 'i' && c != 'I')
goto unwind;
}
}
- if (!is_separator (c))
+ if (!is_separator (c) && (c != EOF))
goto unwind;
if (dtp->u.p.namelist_mode)
read_real (dtp, p, kind);
/* Copy value back to temporary if needed. */
if (dtp->u.p.repeat_count > 0)
- memcpy (dtp->u.p.value, p, kind);
+ memcpy (dtp->u.p.value, p, size);
break;
case BT_COMPLEX:
read_complex (dtp, p, kind, size);
/* Inputs a rank-dimensional qualifier, which can contain
singlets, doublets, triplets or ':' with the standard meanings. */
-static try
+static bool
nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
- array_loop_spec *ls, int rank, char *parse_err_msg,
- size_t parse_err_msg_size,
+ array_loop_spec *ls, int rank, bt nml_elem_type,
+ char *parse_err_msg, size_t parse_err_msg_size,
int *parsed_rank)
{
int dim;
/* The next character in the stream should be the '('. */
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
/* Process the qualifier, by dimension and triplet. */
/* Process a potential sign. */
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
switch (c)
{
case '-':
for (;;)
{
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
switch (c)
{
case ' ': case '\t':
eat_spaces (dtp);
if ((c = next_char (dtp) == EOF))
- return FAILURE;
+ return false;
break;
default:
do not allow excess data to be processed. */
if (is_array_section == 1
|| !(compile_options.allow_std & GFC_STD_GNU)
- || !dtp->u.p.ionml->touched
- || dtp->u.p.ionml->type == BT_DERIVED)
+ || nml_elem_type == BT_DERIVED)
ls[dim].end = ls[dim].start;
else
dtp->u.p.expanded_read = 1;
ls[dim].idx = ls[dim].start;
}
eat_spaces (dtp);
- return SUCCESS;
+ return true;
err_ret:
- return FAILURE;
+ return false;
}
static namelist_info *
{
index_type len = strlen (nl->var_name) + 1;
int dim;
- char * ext_name = (char*)get_mem (len + 1);
+ char * ext_name = (char*)xmalloc (len + 1);
memcpy (ext_name, nl->var_name, len-1);
memcpy (ext_name + len - 1, "%", 2);
for (nl = nl->next; nl; nl = nl->next)
index_type len;
char * p;
#ifdef HAVE_CRLF
- static const index_type endlen = 3;
+ static const index_type endlen = 2;
static const char endl[] = "\r\n";
static const char nmlend[] = "&end\r\n";
#else
- static const index_type endlen = 2;
+ static const index_type endlen = 1;
static const char endl[] = "\n";
static const char nmlend[] = "&end\n";
#endif
/* "&namelist_name\n" */
len = dtp->namelist_name_len;
- p = write_block (dtp, len + endlen);
+ p = write_block (dtp, len - 1 + endlen);
if (!p)
goto query_return;
memcpy (p, "&", 1);
memcpy ((char*)(p + 1), dtp->namelist_name, len);
- memcpy ((char*)(p + len + 1), &endl, endlen - 1);
+ memcpy ((char*)(p + len + 1), &endl, endlen);
for (nl = dtp->u.p.ionml; nl; nl = nl->next)
{
/* " var_name\n" */
goto query_return;
memcpy (p, " ", 1);
memcpy ((char*)(p + 1), nl->var_name, len);
- memcpy ((char*)(p + len + 1), &endl, endlen - 1);
+ memcpy ((char*)(p + len + 1), &endl, endlen);
}
/* "&end\n" */
- p = write_block (dtp, endlen + 3);
+ p = write_block (dtp, endlen + 4);
+ if (!p)
goto query_return;
- memcpy (p, &nmlend, endlen + 3);
+ memcpy (p, &nmlend, endlen + 4);
}
/* Flush the stream to force immediate output. */
little data to be available. On the other hand, too much data is an
error. */
-static try
+static bool
nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
namelist_info **pprev_nl, char *nml_err_msg,
size_t nml_err_msg_size, index_type clow, index_type chigh)
/* This object not touched in name parsing. */
if (!nl->touched)
- return SUCCESS;
+ return true;
dtp->u.p.repeat_count = 0;
eat_spaces (dtp);
if (--dtp->u.p.repeat_count <= 0)
{
if (dtp->u.p.input_complete)
- return SUCCESS;
+ return true;
if (dtp->u.p.at_eol)
finish_separator (dtp);
if (dtp->u.p.input_complete)
- return SUCCESS;
+ return true;
dtp->u.p.saved_type = BT_UNKNOWN;
free_saved (dtp);
switch (nl->type)
{
case BT_INTEGER:
- read_integer (dtp, len);
- break;
+ read_integer (dtp, len);
+ break;
case BT_LOGICAL:
- read_logical (dtp, len);
- break;
+ read_logical (dtp, len);
+ break;
case BT_CHARACTER:
- read_character (dtp, len);
- break;
+ read_character (dtp, len);
+ break;
case BT_REAL:
/* Need to copy data back from the real location to the temp in order
case BT_DERIVED:
obj_name_len = strlen (nl->var_name) + 1;
- obj_name = get_mem (obj_name_len+1);
+ obj_name = xmalloc (obj_name_len+1);
memcpy (obj_name, nl->var_name, obj_name_len-1);
memcpy (obj_name + obj_name_len - 1, "%", 2);
since a single object can have multiple reads. */
dtp->u.p.expanded_read = 0;
- /* Now loop over the components. Update the component pointer
- with the return value from nml_write_obj. This loop jumps
- past nested derived types by testing if the potential
- component name contains '%'. */
+ /* Now loop over the components. */
for (cmp = nl->next;
cmp &&
- !strncmp (cmp->var_name, obj_name, obj_name_len) &&
- !strchr (cmp->var_name + obj_name_len, '%');
+ !strncmp (cmp->var_name, obj_name, obj_name_len);
cmp = cmp->next)
{
+ /* Jump over nested derived type by testing if the potential
+ component name contains '%'. */
+ if (strchr (cmp->var_name + obj_name_len, '%'))
+ continue;
- if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
+ if (!nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
pprev_nl, nml_err_msg, nml_err_msg_size,
- clow, chigh) == FAILURE)
+ clow, chigh))
{
free (obj_name);
- return FAILURE;
+ return false;
}
if (dtp->u.p.input_complete)
{
free (obj_name);
- return SUCCESS;
+ return true;
}
}
if (dtp->u.p.nml_read_error)
{
dtp->u.p.expanded_read = 0;
- return SUCCESS;
+ return true;
}
if (dtp->u.p.saved_type == BT_UNKNOWN)
"Repeat count too large for namelist object %s", nl->var_name);
goto nml_err_ret;
}
- return SUCCESS;
+ return true;
nml_err_ret:
- return FAILURE;
+ return false;
}
/* Parses the object name, including array and substring qualifiers. It
touched. nml_read_obj is called at the end and this reads the data in
the manner specified by the object name. */
-static try
+static bool
nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
char *nml_err_msg, size_t nml_err_msg_size)
{
eat_separator (dtp);
if (dtp->u.p.input_complete)
- return SUCCESS;
+ return true;
if (dtp->u.p.at_eol)
finish_separator (dtp);
if (dtp->u.p.input_complete)
- return SUCCESS;
+ return true;
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
switch (c)
{
case '=':
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
if (c != '?')
{
snprintf (nml_err_msg, nml_err_msg_size,
goto nml_err_ret;
}
nml_query (dtp, '=');
- return SUCCESS;
+ return true;
case '?':
nml_query (dtp, '?');
- return SUCCESS;
+ return true;
case '$':
case '&':
}
case '/':
dtp->u.p.input_complete = 1;
- return SUCCESS;
+ return true;
default :
break;
if (!is_separator (c))
push_char (dtp, tolower(c));
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
unget_char (dtp, c);
if (c == '(' && nl->var_rank)
{
parsed_rank = 0;
- if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
- nml_err_msg, nml_err_msg_size,
- &parsed_rank) == FAILURE)
+ if (!nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
+ nl->type, nml_err_msg, nml_err_msg_size,
+ &parsed_rank))
{
char *nml_err_msg_end = strchr (nml_err_msg, '\0');
snprintf (nml_err_msg_end,
qualifier_flag = 1;
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
unget_char (dtp, c);
}
else if (nl->var_rank > 0)
goto nml_err_ret;
}
- if (*pprev_nl == NULL || !component_flag)
+ /* Don't move first_nl further in the list if a qualifier was found. */
+ if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag)
first_nl = nl;
root_nl = nl;
component_flag = 1;
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
goto get_name;
}
descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
- if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg,
- nml_err_msg_size, &parsed_rank)
- == FAILURE)
+ if (!nml_parse_qualifier (dtp, chd, ind, -1, nl->type,
+ nml_err_msg, nml_err_msg_size, &parsed_rank))
{
char *nml_err_msg_end = strchr (nml_err_msg, '\0');
snprintf (nml_err_msg_end,
}
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
unget_char (dtp, c);
}
eat_separator (dtp);
if (dtp->u.p.input_complete)
- return SUCCESS;
+ return true;
if (dtp->u.p.at_eol)
finish_separator (dtp);
if (dtp->u.p.input_complete)
- return SUCCESS;
+ return true;
if ((c = next_char (dtp)) == EOF)
- return FAILURE;
+ return false;
if (c != '=')
{
nl = first_nl;
}
- if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
- clow, chigh) == FAILURE)
+ if (!nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
+ clow, chigh))
goto nml_err_ret;
- return SUCCESS;
+ return true;
nml_err_ret:
- return FAILURE;
+ return false;
}
/* Entry point for namelist input. Goes through input until namelist name
case '?':
nml_query (dtp, '?');
+ goto find_nml_name;
case EOF:
return;
if (dtp->u.p.nml_read_error)
goto find_nml_name;
- /* A trailing space is required, we give a little lattitude here, 10.9.1. */
+ /* A trailing space is required, we give a little latitude here, 10.9.1. */
c = next_char (dtp);
if (!is_separator(c) && c != '!')
{
while (!dtp->u.p.input_complete)
{
- if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
- == FAILURE)
+ if (!nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg))
{
if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
goto nml_err_ret;
projects / platform / upstream / gcc.git / blobdiff