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; }