void
format_error (fnode * f, const char *message)
{
int width, i, j, offset;
char *p, buffer[300];
if (f != NULL)
format_string = f->source;
free_fnodes ();
st_sprintf (buffer, "%s\n", message);
j = format_string - ioparm.format;
offset = (j > 60) ? j - 40 : 0;
j -= offset;
width = ioparm.format_len - offset;
if (width > 80)
width = 80;
/* Show the format */
p = strchr (buffer, '\0');
memcpy (p, ioparm.format + offset, width);
p += width;
*p++ = '\n';
/* Show where the problem is */
for (i = 1; i < j; i++)
*p++ = ' ';
*p++ = '^';
*p = '\0';
generate_error (ERROR_FORMAT, buffer);
}
void
format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
{
int width, i, j, offset;
char *p, buffer[300];
format_data *fmt = dtp->u.p.fmt;
if (f != NULL)
fmt->format_string = f->source;
st_sprintf (buffer, "%s\n", message);
j = fmt->format_string - dtp->format;
offset = (j > 60) ? j - 40 : 0;
j -= offset;
width = dtp->format_len - offset;
if (width > 80)
width = 80;
/* Show the format */
p = strchr (buffer, '\0');
memcpy (p, dtp->format + offset, width);
p += width;
*p++ = '\n';
/* Show where the problem is */
for (i = 1; i < j; i++)
*p++ = ' ';
*p++ = '^';
*p = '\0';
generate_error (&dtp->common, ERROR_FORMAT, buffer);
}
static namelist_info *
nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
namelist_info * base, char * base_name)
{
int rep_ctr;
int num;
int nml_carry;
index_type len;
index_type obj_size;
index_type nelem;
index_type dim_i;
index_type clen;
index_type elem_ctr;
index_type obj_name_len;
void * p ;
char cup;
char * obj_name;
char * ext_name;
char rep_buff[NML_DIGITS];
namelist_info * cmp;
namelist_info * retval = obj->next;
/* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */
if (obj->type != GFC_DTYPE_DERIVED)
{
#ifdef HAVE_CRLF
write_character (dtp, "\r\n ", 3);
#else
write_character (dtp, "\n ", 2);
#endif
len = 0;
if (base)
{
len =strlen (base->var_name);
for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
{
cup = toupper (base_name[dim_i]);
write_character (dtp, &cup, 1);
}
}
for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
{
cup = toupper (obj->var_name[dim_i]);
write_character (dtp, &cup, 1);
}
write_character (dtp, "=", 1);
}
/* Counts the number of data output on a line, including names. */
num = 1;
len = obj->len;
switch (obj->type)
{
case GFC_DTYPE_REAL:
obj_size = size_from_real_kind (len);
break;
case GFC_DTYPE_COMPLEX:
obj_size = size_from_complex_kind (len);
break;
case GFC_DTYPE_CHARACTER:
obj_size = obj->string_length;
break;
default:
obj_size = len;
}
if (obj->var_rank)
obj_size = obj->size;
/* Set the index vector and count the number of elements. */
nelem = 1;
for (dim_i=0; dim_i < obj->var_rank; dim_i++)
{
obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
}
/* Main loop to output the data held in the object. */
rep_ctr = 1;
for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
{
/* Build the pointer to the data value. The offset is passed by
recursive calls to this function for arrays of derived types.
Is NULL otherwise. */
p = (void *)(obj->mem_pos + elem_ctr * obj_size);
p += offset;
/* Check for repeat counts of intrinsic types. */
if ((elem_ctr < (nelem - 1)) &&
(obj->type != GFC_DTYPE_DERIVED) &&
!memcmp (p, (void*)(p + obj_size ), obj_size ))
{
rep_ctr++;
}
/* Execute a repeated output. Note the flag no_leading_blank that
is used in the functions used to output the intrinsic types. */
else
{
if (rep_ctr > 1)
{
st_sprintf(rep_buff, " %d*", rep_ctr);
write_character (dtp, rep_buff, strlen (rep_buff));
dtp->u.p.no_leading_blank = 1;
}
num++;
/* Output the data, if an intrinsic type, or recurse into this
routine to treat derived types. */
switch (obj->type)
{
case GFC_DTYPE_INTEGER:
write_integer (dtp, p, len);
break;
case GFC_DTYPE_LOGICAL:
write_logical (dtp, p, len);
break;
case GFC_DTYPE_CHARACTER:
if (dtp->u.p.nml_delim)
write_character (dtp, &dtp->u.p.nml_delim, 1);
write_character (dtp, p, obj->string_length);
if (dtp->u.p.nml_delim)
write_character (dtp, &dtp->u.p.nml_delim, 1);
break;
case GFC_DTYPE_REAL:
write_real (dtp, p, len);
break;
case GFC_DTYPE_COMPLEX:
dtp->u.p.no_leading_blank = 0;
num++;
write_complex (dtp, p, len, obj_size);
break;
case GFC_DTYPE_DERIVED:
/* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends
component names in the output - passed to
nml_write_obj.
obj_name = the derived type name with no qualifiers but %
appended. This is used to identify the
components. */
/* First ext_name => get length of all possible components */
ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
+ (base ? strlen (base->var_name) : 0)
+ strlen (obj->var_name)
+ obj->var_rank * NML_DIGITS
+ 1);
strcpy(ext_name, base_name ? base_name : "");
clen = base ? strlen (base->var_name) : 0;
strcat (ext_name, obj->var_name + clen);
/* Append the qualifier. */
for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
{
strcat (ext_name, dim_i ? "" : "(");
clen = strlen (ext_name);
st_sprintf (ext_name + clen, "%d", (int) obj->ls[dim_i].idx);
strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
}
/* Now obj_name. */
obj_name_len = strlen (obj->var_name) + 1;
obj_name = get_mem (obj_name_len+1);
strcpy (obj_name, obj->var_name);
strcat (obj_name, "%");
/* Now loop over the components. Update the component pointer
with the return value from nml_write_obj => this loop jumps
past nested derived types. */
for (cmp = obj->next;
cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
cmp = retval)
{
retval = nml_write_obj (dtp, cmp,
(index_type)(p - obj->mem_pos),
obj, ext_name);
}
free_mem (obj_name);
free_mem (ext_name);
goto obj_loop;
default:
internal_error (&dtp->common, "Bad type for namelist write");
}
/* Reset the leading blank suppression, write a comma and, if 5
values have been output, write a newline and advance to column
2. Reset the repeat counter. */
dtp->u.p.no_leading_blank = 0;
write_character (dtp, ",", 1);
if (num > 5)
{
num = 0;
#ifdef HAVE_CRLF
write_character (dtp, "\r\n ", 3);
#else
write_character (dtp, "\n ", 2);
#endif
}
rep_ctr = 1;
}
/* Cycle through and increment the index vector. */
obj_loop:
nml_carry = 1;
for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
{
obj->ls[dim_i].idx += nml_carry ;
nml_carry = 0;
if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound)
{
obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
nml_carry = 1;
}
}
}
/* Return a pointer beyond the furthest object accessed. */
return retval;
}
