static int
unpack_field(int ctype, int ptype, char * buffer, struct atom * a, void *out) {
if (ctype == CTYPE_ARRAY) {
return unpack_array(ptype, buffer, a , out);
}
if (ctype == CTYPE_PACKED) {
pbc_ctx packed;
struct context * ctx = (struct context *)packed;
int n = _pbcC_open_packed(packed , ptype,
(uint8_t *)buffer + a->v.s.start, a->v.s.end - a->v.s.start);
if (n<=0)
return -1;
int i;
int r =0;
for (i=0;i<n;i++) {
r |= unpack_array(ptype , buffer , &(ctx->a[i]) , out);
}
if (r)
return -1;
return 0;
}
switch(ptype) {
case PTYPE_DOUBLE:
return write_real(ctype, read_double(a), out);
case PTYPE_FLOAT:
return write_real(ctype, read_float(a), out);
case PTYPE_INT64:
case PTYPE_UINT64:
case PTYPE_INT32:
case PTYPE_UINT32:
case PTYPE_FIXED32:
case PTYPE_FIXED64:
case PTYPE_SFIXED32:
case PTYPE_SFIXED64:
case PTYPE_ENUM: // enum must be integer type in pattern mode
case PTYPE_BOOL:
return write_integer(ctype, a , out);
case PTYPE_SINT32: {
struct longlong temp = a->v.i;
varint_dezigzag32(&temp);
return write_longlong(ctype, &temp , out);
}
case PTYPE_SINT64: {
struct longlong temp = a->v.i;
varint_dezigzag64(&temp);
return write_longlong(ctype, &temp , out);
}
case PTYPE_MESSAGE:
((union _pbc_var *)out)->m.buffer = buffer + a->v.s.start;
((union _pbc_var *)out)->m.len = a->v.s.end - a->v.s.start;
return 0;
case PTYPE_STRING:
((union _pbc_var *)out)->s.str = buffer + a->v.s.start;
((union _pbc_var *)out)->s.len = a->v.s.end - a->v.s.start;
return 0;
}
return -1;
}
int DxfMap::write_point(FILE *fp, dxf_map_feature *feature)
{
write_string(fp, 0, (char*)"POINT");
write_number(fp, 8, feature->layer);
write_number(fp, 62, 256); // color determined by layer, line color overwrites layercolor (256 = BYLAYER)
write_real (fp, 10, feature->x);
write_real (fp, 20, feature->y);
write_real (fp, 30, 0.0);
return 0;
}
void main(void)
{
double v_2X;
double v_1X;
double v_0X;
{write_real(0.2);write_real(5.0);
v_0X = sqrt(5.0);write_real((1.0 / v_0X));
v_1X = sqrt(1.0);
v_2X = sqrt(5.0);
write_real((v_1X / v_2X));
return;}
}
static void
write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{
if (write_char (dtp, '('))
return;
write_real (dtp, source, kind);
if (write_char (dtp, ','))
return;
write_real (dtp, source + size / 2, kind);
write_char (dtp, ')');
}
static void
write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{
char semi_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
if (write_char (dtp, '('))
return;
write_real (dtp, source, kind);
if (write_char (dtp, semi_comma))
return;
write_real (dtp, source + size / 2, kind);
write_char (dtp, ')');
}
pfs::error_code ubjson_ostream<OStreamType, JsonType>::write_json (json_type const & j, bool with_prefix)
{
switch (j.type()) {
case data_type::null:
_os << UBJSON_CHAR_NULL;
break;
case data_type::boolean:
_os << (j.boolean_data()
? UBJSON_CHAR_TRUE
: UBJSON_CHAR_FALSE);
break;
case data_type::integer:
return write_integer(j.integer_data(), with_prefix);
case data_type::real:
return write_real(j.real_data(), with_prefix);
case data_type::string:
return write_string(j.string_data(), with_prefix);
case data_type::array:
return write_array(j);
case data_type::object:
return write_object(j);
}
return pfs::error_code();
}
static size_t
write_json(json_t* json, stream_t* stream)
{
switch (json_typeof(json)) {
case JSON_OBJECT: return write_object(json, stream);
case JSON_ARRAY: return write_array(json, stream);
case JSON_STRING: return write_string(json, stream);
case JSON_INTEGER: return write_integer(json, stream);
case JSON_REAL: return write_real(json, stream);
case JSON_TRUE: return write_true(json, stream);
case JSON_FALSE: return write_false(json, stream);
case JSON_NULL: return write_null(json, stream);
default: return 0;
}
}
static void
list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
if (dtp->u.p.current_unit == NULL)
return;
if (dtp->u.p.first_item)
{
dtp->u.p.first_item = 0;
write_char (dtp, ' ');
}
else
{
if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
dtp->u.p.current_unit->delim_status != DELIM_NONE)
write_separator (dtp);
}
switch (type)
{
case BT_INTEGER:
write_integer (dtp, p, kind);
break;
case BT_LOGICAL:
write_logical (dtp, p, kind);
break;
case BT_CHARACTER:
write_character (dtp, p, kind, size);
break;
case BT_REAL:
write_real (dtp, p, kind);
break;
case BT_COMPLEX:
write_complex (dtp, p, kind, size);
break;
default:
internal_error (&dtp->common, "list_formatted_write(): Bad type");
}
dtp->u.p.char_flag = (type == BT_CHARACTER);
}
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;
int len;
index_type obj_size;
index_type nelem;
size_t dim_i;
size_t clen;
index_type elem_ctr;
size_t 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;
size_t base_name_len;
size_t base_var_name_len;
size_t tot_len;
unit_delim tmp_delim;
/* Set the character to be used to separate values
to a comma or semi-colon. */
char semi_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
/* 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)
{
namelist_write_newline (dtp);
write_character (dtp, " ", 1, 1);
len = 0;
if (base)
{
len = strlen (base->var_name);
base_name_len = strlen (base_name);
for (dim_i = 0; dim_i < base_name_len; dim_i++)
{
cup = toupper (base_name[dim_i]);
write_character (dtp, &cup, 1, 1);
}
}
clen = strlen (obj->var_name);
for (dim_i = len; dim_i < clen; dim_i++)
{
cup = toupper (obj->var_name[dim_i]);
write_character (dtp, &cup, 1, 1);
}
write_character (dtp, "=", 1, 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 < (size_t) obj->var_rank; dim_i++)
{
obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
}
/* 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)
{
sprintf(rep_buff, " %d*", rep_ctr);
write_character (dtp, rep_buff, 1, 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:
tmp_delim = dtp->u.p.current_unit->delim_status;
if (dtp->u.p.nml_delim == '"')
dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
if (dtp->u.p.nml_delim == '\'')
dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
write_character (dtp, p, 1, obj->string_length);
dtp->u.p.current_unit->delim_status = tmp_delim;
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 */
base_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0;
ext_name = (char*)get_mem ( base_name_len
+ base_var_name_len
+ strlen (obj->var_name)
+ obj->var_rank * NML_DIGITS
+ 1);
memcpy (ext_name, base_name, base_name_len);
clen = strlen (obj->var_name + base_var_name_len);
memcpy (ext_name + base_name_len,
obj->var_name + base_var_name_len, clen);
/* Append the qualifier. */
tot_len = base_name_len + clen;
for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
{
if (!dim_i)
{
ext_name[tot_len] = '(';
tot_len++;
}
sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
tot_len += strlen (ext_name + tot_len);
ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
tot_len++;
}
ext_name[tot_len] = '\0';
/* Now obj_name. */
obj_name_len = strlen (obj->var_name) + 1;
obj_name = get_mem (obj_name_len+1);
memcpy (obj_name, obj->var_name, obj_name_len-1);
memcpy (obj_name + obj_name_len-1, "%", 2);
/* 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 (or semi-colon)
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, &semi_comma, 1, 1);
if (num > 5)
{
num = 0;
namelist_write_newline (dtp);
write_character (dtp, " ", 1, 1);
}
rep_ctr = 1;
}
/* Cycle through and increment the index vector. */
obj_loop:
nml_carry = 1;
for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
{
obj->ls[dim_i].idx += nml_carry ;
nml_carry = 0;
if (obj->ls[dim_i].idx > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
{
obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
nml_carry = 1;
}
}
}
/* Return a pointer beyond the furthest object accessed. */
return retval;
}
void plist_to_bin(plist_t plist, char **plist_bin, uint32_t * length)
{
GPtrArray *objects = NULL;
GHashTable *ref_table = NULL;
struct serialize_s ser_s;
uint8_t offset_size = 0;
uint8_t dict_param_size = 0;
uint64_t num_objects = 0;
uint64_t root_object = 0;
uint64_t offset_table_index = 0;
GByteArray *bplist_buff = NULL;
uint64_t i = 0;
uint8_t *buff = NULL;
uint64_t *offsets = NULL;
uint8_t pad[6] = { 0, 0, 0, 0, 0, 0 };
uint8_t trailer[BPLIST_TRL_SIZE];
//for string
glong len = 0;
int type = 0;
glong items_read = 0;
glong items_written = 0;
GError *error = NULL;
gunichar2 *unicodestr = NULL;
//check for valid input
if (!plist || !plist_bin || *plist_bin || !length)
return;
//list of objects
objects = g_ptr_array_new();
//hashtable to write only once same nodes
ref_table = g_hash_table_new(plist_data_hash, plist_data_compare);
//serialize plist
ser_s.objects = objects;
ser_s.ref_table = ref_table;
serialize_plist(plist, &ser_s);
//now stream to output buffer
offset_size = 0; //unknown yet
dict_param_size = get_needed_bytes(objects->len);
num_objects = objects->len;
root_object = 0; //root is first in list
offset_table_index = 0; //unknown yet
//setup a dynamic bytes array to store bplist in
bplist_buff = g_byte_array_new();
//set magic number and version
g_byte_array_append(bplist_buff, BPLIST_MAGIC, BPLIST_MAGIC_SIZE);
g_byte_array_append(bplist_buff, BPLIST_VERSION, BPLIST_VERSION_SIZE);
//write objects and table
offsets = (uint64_t *) malloc(num_objects * sizeof(uint64_t));
for (i = 0; i < num_objects; i++)
{
plist_data_t data = plist_get_data(g_ptr_array_index(objects, i));
offsets[i] = bplist_buff->len;
switch (data->type)
{
case PLIST_BOOLEAN:
buff = (uint8_t *) malloc(sizeof(uint8_t));
buff[0] = data->boolval ? BPLIST_TRUE : BPLIST_FALSE;
g_byte_array_append(bplist_buff, buff, sizeof(uint8_t));
free(buff);
break;
case PLIST_UINT:
write_int(bplist_buff, data->intval);
break;
case PLIST_REAL:
write_real(bplist_buff, data->realval);
break;
case PLIST_KEY:
case PLIST_STRING:
len = strlen(data->strval);
if ( is_ascii_string(data->strval, len) )
{
write_string(bplist_buff, data->strval);
}
else
{
unicodestr = g_utf8_to_utf16(data->strval, len, &items_read, &items_written, &error);
write_unicode(bplist_buff, unicodestr, items_written);
g_free(unicodestr);
}
break;
case PLIST_DATA:
write_data(bplist_buff, data->buff, data->length);
case PLIST_ARRAY:
write_array(bplist_buff, g_ptr_array_index(objects, i), ref_table, dict_param_size);
break;
case PLIST_DICT:
write_dict(bplist_buff, g_ptr_array_index(objects, i), ref_table, dict_param_size);
break;
case PLIST_DATE:
write_date(bplist_buff, data->timeval.tv_sec + (double) data->timeval.tv_usec / G_USEC_PER_SEC);
break;
default:
break;
}
}
//free intermediate objects
g_hash_table_foreach_remove(ref_table, free_index, NULL);
g_ptr_array_free(objects, TRUE);
g_hash_table_destroy(ref_table);
//write offsets
offset_size = get_needed_bytes(bplist_buff->len);
offset_table_index = bplist_buff->len;
for (i = 0; i < num_objects; i++)
{
uint8_t *offsetbuff = (uint8_t *) malloc(offset_size);
#if G_BYTE_ORDER == G_BIG_ENDIAN
offsets[i] = offsets[i] << ((sizeof(uint64_t) - offset_size) * 8);
#endif
memcpy(offsetbuff, &offsets[i], offset_size);
byte_convert(offsetbuff, offset_size);
g_byte_array_append(bplist_buff, offsetbuff, offset_size);
free(offsetbuff);
}
//experimental pad to reflect apple's files
g_byte_array_append(bplist_buff, pad, 6);
//setup trailer
num_objects = GUINT64_FROM_BE(num_objects);
root_object = GUINT64_FROM_BE(root_object);
offset_table_index = GUINT64_FROM_BE(offset_table_index);
memcpy(trailer + BPLIST_TRL_OFFSIZE_IDX, &offset_size, sizeof(uint8_t));
memcpy(trailer + BPLIST_TRL_PARMSIZE_IDX, &dict_param_size, sizeof(uint8_t));
memcpy(trailer + BPLIST_TRL_NUMOBJ_IDX, &num_objects, sizeof(uint64_t));
memcpy(trailer + BPLIST_TRL_ROOTOBJ_IDX, &root_object, sizeof(uint64_t));
memcpy(trailer + BPLIST_TRL_OFFTAB_IDX, &offset_table_index, sizeof(uint64_t));
g_byte_array_append(bplist_buff, trailer, BPLIST_TRL_SIZE);
//duplicate buffer
*plist_bin = (char *) malloc(bplist_buff->len);
memcpy(*plist_bin, bplist_buff->data, bplist_buff->len);
*length = bplist_buff->len;
g_byte_array_free(bplist_buff, TRUE);
free(offsets);
}
int DxfMap::write_head(FILE *fp)
{
calcBounds();
// head
write_string(fp, 999, (char*)"DXF Map, RTS, University of Hannover");
write_string(fp, 0, (char*)"SECTION");
write_string(fp, 2, (char*)"HEADER");
write_string(fp, 9, (char*)"$ACADVER");
write_string(fp, 1, (char*)"AC1021");
write_string(fp, 9, (char*)"$INSBASE");
write_real (fp, 10, 0.0);
write_real (fp, 20, 0.0);
write_real (fp, 30, 0.0);
write_string(fp, 9, (char*)"$EXTMIN");
write_real (fp, 10, xMin);
write_real (fp, 20, yMin);
write_real (fp, 30, 0.0);
write_string(fp, 9, (char*)"$EXTMAX");
write_real (fp, 10, xMax);
write_real (fp, 20, yMax);
write_real (fp, 30, 0.0);
write_string(fp, 0, (char*)"ENDSEC");
// Tables
write_string(fp, 0, (char*)"SECTION");
write_string(fp, 2, (char*)"TABLES");
write_string(fp, 0, (char*)"TABLE");
write_string(fp, 2, (char*)"LTYPE");
write_number(fp, 70, 1);
write_string(fp, 0, (char*)"LTYPE");
write_string(fp, 2, (char*)"CONTINUOUS");
write_number(fp, 70, 64);
write_string(fp, 3, (char*)"Solid line");
write_number(fp, 72, 65);
write_number(fp, 73, 0);
write_real (fp, 40, 0.0);
write_string(fp, 0, (char*)"ENDTAB");
write_string(fp, 0, (char*)"TABLE");
write_string(fp, 2, (char*)"LAYER");
write_number(fp, 70, 6);
write_string(fp, 0, (char*)"LAYER");
write_number(fp, 2, 0);
write_number(fp, 70, 64);
write_number(fp, 62, 5);
write_string(fp, 6, (char*)"CONTINUOUS");
write_string(fp, 0, (char*)"LAYER");
write_number(fp, 2, 1);
write_number(fp, 70, 64);
write_number(fp, 62, 3);
write_string(fp, 6, (char*)"CONTINUOUS");
write_string(fp, 0, (char*)"LAYER");
write_number(fp, 2, 2);
write_number(fp, 70, 64);
write_number(fp, 62, 2);
write_string(fp, 6, (char*)"CONTINUOUS");
write_string(fp, 0, (char*)"ENDTAB");
write_string(fp, 0, (char*)"TABLE");
write_string(fp, 2, (char*)"STYLE");
write_number(fp, 70, 0);
write_string(fp, 0, (char*)"ENDTAB");
write_string(fp, 0, (char*)"ENDSEC");
// empty block section
write_string(fp, 0, (char*)"SECTION");
write_string(fp, 2, (char*)"BLOCKS");
write_string(fp, 0, (char*)"ENDSEC");
// start Entities
write_string(fp, 0, (char*)"SECTION");
write_string(fp, 2, (char*)"ENTITIES");
return 0;
}
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;
}
