1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist output contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran 95 runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
40 #define star_fill(p, n) memset(p, '*', n)
42 #include "write_float.def"
44 typedef unsigned char uchar
;
46 /* Write out default char4. */
49 write_default_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
50 int src_len
, int w_len
)
57 /* Take care of preceding blanks. */
61 p
= write_block (dtp
, k
);
67 /* Get ready to handle delimiters if needed. */
69 switch (dtp
->u
.p
.delim_status
)
71 case DELIM_APOSTROPHE
:
82 /* Now process the remaining characters, one at a time. */
83 for (j
= k
; j
< src_len
; j
++)
87 /* Handle delimiters if any. */
88 if (c
== d
&& d
!= ' ')
90 p
= write_block (dtp
, 2);
97 p
= write_block (dtp
, 1);
101 *p
= c
> 255 ? '?' : (uchar
) c
;
106 /* Write out UTF-8 converted from char4. */
109 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
110 int src_len
, int w_len
)
115 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
116 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
120 /* Take care of preceding blanks. */
124 p
= write_block (dtp
, k
);
130 /* Get ready to handle delimiters if needed. */
132 switch (dtp
->u
.p
.delim_status
)
134 case DELIM_APOSTROPHE
:
145 /* Now process the remaining characters, one at a time. */
146 for (j
= k
; j
< src_len
; j
++)
151 /* Handle the delimiters if any. */
152 if (c
== d
&& d
!= ' ')
154 p
= write_block (dtp
, 2);
161 p
= write_block (dtp
, 1);
169 /* Convert to UTF-8 sequence. */
175 *--q
= ((c
& 0x3F) | 0x80);
179 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
181 *--q
= (c
| masks
[nbytes
-1]);
183 p
= write_block (dtp
, nbytes
);
195 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
200 wlen
= f
->u
.string
.length
< 0
201 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
202 ? len
: f
->u
.string
.length
;
205 /* If this is formatted STREAM IO convert any embedded line feed characters
206 to CR_LF on systems that use that sequence for newlines. See F2003
207 Standard sections 10.6.3 and 9.9 for further information. */
208 if (is_stream_io (dtp
))
210 const char crlf
[] = "\r\n";
214 /* Write out any padding if needed. */
217 p
= write_block (dtp
, wlen
- len
);
220 memset (p
, ' ', wlen
- len
);
223 /* Scan the source string looking for '\n' and convert it if found. */
224 for (i
= 0; i
< wlen
; i
++)
226 if (source
[i
] == '\n')
228 /* Write out the previously scanned characters in the string. */
231 p
= write_block (dtp
, bytes
);
234 memcpy (p
, &source
[q
], bytes
);
239 /* Write out the CR_LF sequence. */
241 p
= write_block (dtp
, 2);
250 /* Write out any remaining bytes if no LF was found. */
253 p
= write_block (dtp
, bytes
);
256 memcpy (p
, &source
[q
], bytes
);
262 p
= write_block (dtp
, wlen
);
267 memcpy (p
, source
, wlen
);
270 memset (p
, ' ', wlen
- len
);
271 memcpy (p
+ wlen
- len
, source
, len
);
279 /* The primary difference between write_a_char4 and write_a is that we have to
280 deal with writing from the first byte of the 4-byte character and pay
281 attention to the most significant bytes. For ENCODING="default" write the
282 lowest significant byte. If the 3 most significant bytes contain
283 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
284 to the UTF-8 encoded string before writing out. */
287 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
292 wlen
= f
->u
.string
.length
< 0
293 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
294 ? len
: f
->u
.string
.length
;
296 q
= (gfc_char4_t
*) source
;
298 /* If this is formatted STREAM IO convert any embedded line feed characters
299 to CR_LF on systems that use that sequence for newlines. See F2003
300 Standard sections 10.6.3 and 9.9 for further information. */
301 if (is_stream_io (dtp
))
303 const char crlf
[] = "\r\n";
308 /* Write out any padding if needed. */
312 p
= write_block (dtp
, wlen
- len
);
315 memset (p
, ' ', wlen
- len
);
318 /* Scan the source string looking for '\n' and convert it if found. */
319 qq
= (gfc_char4_t
*) source
;
320 for (i
= 0; i
< wlen
; i
++)
324 /* Write out the previously scanned characters in the string. */
327 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
328 write_utf8_char4 (dtp
, q
, bytes
, 0);
330 write_default_char4 (dtp
, q
, bytes
, 0);
334 /* Write out the CR_LF sequence. */
335 write_default_char4 (dtp
, crlf
, 2, 0);
341 /* Write out any remaining bytes if no LF was found. */
344 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
345 write_utf8_char4 (dtp
, q
, bytes
, 0);
347 write_default_char4 (dtp
, q
, bytes
, 0);
353 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
354 write_utf8_char4 (dtp
, q
, len
, wlen
);
356 write_default_char4 (dtp
, q
, len
, wlen
);
363 static GFC_INTEGER_LARGEST
364 extract_int (const void *p
, int len
)
366 GFC_INTEGER_LARGEST i
= 0;
376 memcpy ((void *) &tmp
, p
, len
);
383 memcpy ((void *) &tmp
, p
, len
);
390 memcpy ((void *) &tmp
, p
, len
);
397 memcpy ((void *) &tmp
, p
, len
);
401 #ifdef HAVE_GFC_INTEGER_16
405 memcpy ((void *) &tmp
, p
, len
);
411 internal_error (NULL
, "bad integer kind");
417 static GFC_UINTEGER_LARGEST
418 extract_uint (const void *p
, int len
)
420 GFC_UINTEGER_LARGEST i
= 0;
430 memcpy ((void *) &tmp
, p
, len
);
431 i
= (GFC_UINTEGER_1
) tmp
;
437 memcpy ((void *) &tmp
, p
, len
);
438 i
= (GFC_UINTEGER_2
) tmp
;
444 memcpy ((void *) &tmp
, p
, len
);
445 i
= (GFC_UINTEGER_4
) tmp
;
451 memcpy ((void *) &tmp
, p
, len
);
452 i
= (GFC_UINTEGER_8
) tmp
;
455 #ifdef HAVE_GFC_INTEGER_16
459 memcpy ((void *) &tmp
, p
, len
);
460 i
= (GFC_UINTEGER_16
) tmp
;
465 internal_error (NULL
, "bad integer kind");
473 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
477 GFC_INTEGER_LARGEST n
;
479 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
481 p
= write_block (dtp
, wlen
);
485 memset (p
, ' ', wlen
- 1);
486 n
= extract_int (source
, len
);
487 p
[wlen
- 1] = (n
) ? 'T' : 'F';
492 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
493 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
495 GFC_UINTEGER_LARGEST n
= 0;
496 int w
, m
, digits
, nzero
, nblank
;
499 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
504 n
= extract_uint (source
, len
);
508 if (m
== 0 && n
== 0)
513 p
= write_block (dtp
, w
);
521 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
524 /* Select a width if none was specified. The idea here is to always
528 w
= ((digits
< m
) ? m
: digits
);
530 p
= write_block (dtp
, w
);
538 /* See if things will work. */
540 nblank
= w
- (nzero
+ digits
);
549 if (!dtp
->u
.p
.no_leading_blank
)
551 memset (p
, ' ', nblank
);
553 memset (p
, '0', nzero
);
555 memcpy (p
, q
, digits
);
559 memset (p
, '0', nzero
);
561 memcpy (p
, q
, digits
);
563 memset (p
, ' ', nblank
);
564 dtp
->u
.p
.no_leading_blank
= 0;
572 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
574 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
576 GFC_INTEGER_LARGEST n
= 0;
577 int w
, m
, digits
, nsign
, nzero
, nblank
;
581 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
584 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
586 n
= extract_int (source
, len
);
589 if (m
== 0 && n
== 0)
594 p
= write_block (dtp
, w
);
602 sign
= calculate_sign (dtp
, n
< 0);
606 nsign
= sign
== S_NONE
? 0 : 1;
607 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
611 /* Select a width if none was specified. The idea here is to always
615 w
= ((digits
< m
) ? m
: digits
) + nsign
;
617 p
= write_block (dtp
, w
);
625 /* See if things will work. */
627 nblank
= w
- (nsign
+ nzero
+ digits
);
635 memset (p
, ' ', nblank
);
650 memset (p
, '0', nzero
);
653 memcpy (p
, q
, digits
);
660 /* Convert unsigned octal to ascii. */
663 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
667 assert (len
>= GFC_OTOA_BUF_SIZE
);
672 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
677 *--p
= '0' + (n
& 7);
685 /* Convert unsigned binary to ascii. */
688 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
692 assert (len
>= GFC_BTOA_BUF_SIZE
);
697 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
702 *--p
= '0' + (n
& 1);
711 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
713 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
718 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
720 write_int (dtp
, f
, p
, len
, btoa
);
725 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
727 write_int (dtp
, f
, p
, len
, otoa
);
731 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
733 write_int (dtp
, f
, p
, len
, xtoa
);
738 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
740 write_float (dtp
, f
, p
, len
);
745 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
747 write_float (dtp
, f
, p
, len
);
752 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
754 write_float (dtp
, f
, p
, len
);
759 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
761 write_float (dtp
, f
, p
, len
);
766 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
768 write_float (dtp
, f
, p
, len
);
772 /* Take care of the X/TR descriptor. */
775 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
779 p
= write_block (dtp
, len
);
784 memset (&p
[len
- nspaces
], ' ', nspaces
);
788 /* List-directed writing. */
791 /* Write a single character to the output. Returns nonzero if
792 something goes wrong. */
795 write_char (st_parameter_dt
*dtp
, char c
)
799 p
= write_block (dtp
, 1);
809 /* Write a list-directed logical value. */
812 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
814 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
818 /* Write a list-directed integer value. */
821 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
827 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
829 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
858 p
= write_block (dtp
, width
);
861 if (dtp
->u
.p
.no_leading_blank
)
863 memcpy (p
, q
, digits
);
864 memset (p
+ digits
, ' ', width
- digits
);
868 memset (p
, ' ', width
- digits
);
869 memcpy (p
+ width
- digits
, q
, digits
);
874 /* Write a list-directed string. We have to worry about delimiting
875 the strings if the file has been opened in that mode. */
878 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
883 switch (dtp
->u
.p
.delim_status
)
885 case DELIM_APOSTROPHE
:
904 for (i
= 0; i
< length
; i
++)
909 p
= write_block (dtp
, length
+ extra
);
914 memcpy (p
, source
, length
);
919 for (i
= 0; i
< length
; i
++)
933 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
934 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
936 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
940 p
= write_block (dtp
, 1);
943 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
944 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
946 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
948 p
= write_block (dtp
, 1);
955 /* Output a real number with default format.
956 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
957 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
960 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
963 int org_scale
= dtp
->u
.p
.scale_factor
;
965 dtp
->u
.p
.scale_factor
= 1;
989 internal_error (&dtp
->common
, "bad real kind");
992 write_float (dtp
, &f
, source
, length
);
993 dtp
->u
.p
.scale_factor
= org_scale
;
998 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1000 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
1002 if (write_char (dtp
, '('))
1004 write_real (dtp
, source
, kind
);
1006 if (write_char (dtp
, semi_comma
))
1008 write_real (dtp
, source
+ size
/ 2, kind
);
1010 write_char (dtp
, ')');
1014 /* Write the separator between items. */
1017 write_separator (st_parameter_dt
*dtp
)
1021 p
= write_block (dtp
, options
.separator_len
);
1025 memcpy (p
, options
.separator
, options
.separator_len
);
1029 /* Write an item with list formatting.
1030 TODO: handle skipping to the next record correctly, particularly
1034 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1037 if (dtp
->u
.p
.current_unit
== NULL
)
1040 if (dtp
->u
.p
.first_item
)
1042 dtp
->u
.p
.first_item
= 0;
1043 write_char (dtp
, ' ');
1047 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1048 dtp
->u
.p
.delim_status
!= DELIM_NONE
)
1049 write_separator (dtp
);
1055 write_integer (dtp
, p
, kind
);
1058 write_logical (dtp
, p
, kind
);
1061 write_character (dtp
, p
, kind
, size
);
1064 write_real (dtp
, p
, kind
);
1067 write_complex (dtp
, p
, kind
, size
);
1070 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1073 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1078 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1079 size_t size
, size_t nelems
)
1083 size_t stride
= type
== BT_CHARACTER
?
1084 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1088 /* Big loop over all the elements. */
1089 for (elem
= 0; elem
< nelems
; elem
++)
1091 dtp
->u
.p
.item_count
++;
1092 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1098 nml_write_obj writes a namelist object to the output stream. It is called
1099 recursively for derived type components:
1100 obj = is the namelist_info for the current object.
1101 offset = the offset relative to the address held by the object for
1102 derived type arrays.
1103 base = is the namelist_info of the derived type, when obj is a
1105 base_name = the full name for a derived type, including qualifiers
1107 The returned value is a pointer to the object beyond the last one
1108 accessed, including nested derived types. Notice that the namelist is
1109 a linear linked list of objects, including derived types and their
1110 components. A tree, of sorts, is implied by the compound names of
1111 the derived type components and this is how this function recurses through
1114 /* A generous estimate of the number of characters needed to print
1115 repeat counts and indices, including commas, asterices and brackets. */
1117 #define NML_DIGITS 20
1119 static namelist_info
*
1120 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1121 namelist_info
* base
, char * base_name
)
1127 index_type obj_size
;
1131 index_type elem_ctr
;
1132 index_type obj_name_len
;
1137 char rep_buff
[NML_DIGITS
];
1138 namelist_info
* cmp
;
1139 namelist_info
* retval
= obj
->next
;
1140 size_t base_name_len
;
1141 size_t base_var_name_len
;
1143 unit_delim tmp_delim
;
1145 /* Set the character to be used to separate values
1146 to a comma or semi-colon. */
1148 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
1150 /* Write namelist variable names in upper case. If a derived type,
1151 nothing is output. If a component, base and base_name are set. */
1153 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1156 write_character (dtp
, "\r\n ", 1, 3);
1158 write_character (dtp
, "\n ", 1, 2);
1163 len
=strlen (base
->var_name
);
1164 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1166 cup
= toupper (base_name
[dim_i
]);
1167 write_character (dtp
, &cup
, 1, 1);
1170 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1172 cup
= toupper (obj
->var_name
[dim_i
]);
1173 write_character (dtp
, &cup
, 1, 1);
1175 write_character (dtp
, "=", 1, 1);
1178 /* Counts the number of data output on a line, including names. */
1187 case GFC_DTYPE_REAL
:
1188 obj_size
= size_from_real_kind (len
);
1191 case GFC_DTYPE_COMPLEX
:
1192 obj_size
= size_from_complex_kind (len
);
1195 case GFC_DTYPE_CHARACTER
:
1196 obj_size
= obj
->string_length
;
1204 obj_size
= obj
->size
;
1206 /* Set the index vector and count the number of elements. */
1209 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1211 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1212 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1215 /* Main loop to output the data held in the object. */
1218 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1221 /* Build the pointer to the data value. The offset is passed by
1222 recursive calls to this function for arrays of derived types.
1223 Is NULL otherwise. */
1225 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1228 /* Check for repeat counts of intrinsic types. */
1230 if ((elem_ctr
< (nelem
- 1)) &&
1231 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1232 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1237 /* Execute a repeated output. Note the flag no_leading_blank that
1238 is used in the functions used to output the intrinsic types. */
1244 sprintf(rep_buff
, " %d*", rep_ctr
);
1245 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1246 dtp
->u
.p
.no_leading_blank
= 1;
1250 /* Output the data, if an intrinsic type, or recurse into this
1251 routine to treat derived types. */
1256 case GFC_DTYPE_INTEGER
:
1257 write_integer (dtp
, p
, len
);
1260 case GFC_DTYPE_LOGICAL
:
1261 write_logical (dtp
, p
, len
);
1264 case GFC_DTYPE_CHARACTER
:
1265 tmp_delim
= dtp
->u
.p
.delim_status
;
1266 if (dtp
->u
.p
.nml_delim
== '"')
1267 dtp
->u
.p
.delim_status
= DELIM_QUOTE
;
1268 if (dtp
->u
.p
.nml_delim
== '\'')
1269 dtp
->u
.p
.delim_status
= DELIM_APOSTROPHE
;
1270 write_character (dtp
, p
, 1, obj
->string_length
);
1271 dtp
->u
.p
.delim_status
= tmp_delim
;
1274 case GFC_DTYPE_REAL
:
1275 write_real (dtp
, p
, len
);
1278 case GFC_DTYPE_COMPLEX
:
1279 dtp
->u
.p
.no_leading_blank
= 0;
1281 write_complex (dtp
, p
, len
, obj_size
);
1284 case GFC_DTYPE_DERIVED
:
1286 /* To treat a derived type, we need to build two strings:
1287 ext_name = the name, including qualifiers that prepends
1288 component names in the output - passed to
1290 obj_name = the derived type name with no qualifiers but %
1291 appended. This is used to identify the
1294 /* First ext_name => get length of all possible components */
1296 base_name_len
= base_name
? strlen (base_name
) : 0;
1297 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1298 ext_name
= (char*)get_mem ( base_name_len
1300 + strlen (obj
->var_name
)
1301 + obj
->var_rank
* NML_DIGITS
1304 memcpy (ext_name
, base_name
, base_name_len
);
1305 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1306 memcpy (ext_name
+ base_name_len
,
1307 obj
->var_name
+ base_var_name_len
, clen
);
1309 /* Append the qualifier. */
1311 tot_len
= base_name_len
+ clen
;
1312 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1316 ext_name
[tot_len
] = '(';
1319 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1320 tot_len
+= strlen (ext_name
+ tot_len
);
1321 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1325 ext_name
[tot_len
] = '\0';
1329 obj_name_len
= strlen (obj
->var_name
) + 1;
1330 obj_name
= get_mem (obj_name_len
+1);
1331 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1332 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1334 /* Now loop over the components. Update the component pointer
1335 with the return value from nml_write_obj => this loop jumps
1336 past nested derived types. */
1338 for (cmp
= obj
->next
;
1339 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1342 retval
= nml_write_obj (dtp
, cmp
,
1343 (index_type
)(p
- obj
->mem_pos
),
1347 free_mem (obj_name
);
1348 free_mem (ext_name
);
1352 internal_error (&dtp
->common
, "Bad type for namelist write");
1355 /* Reset the leading blank suppression, write a comma (or semi-colon)
1356 and, if 5 values have been output, write a newline and advance
1357 to column 2. Reset the repeat counter. */
1359 dtp
->u
.p
.no_leading_blank
= 0;
1360 write_character (dtp
, &semi_comma
, 1, 1);
1365 write_character (dtp
, "\r\n ", 1, 3);
1367 write_character (dtp
, "\n ", 1, 2);
1373 /* Cycle through and increment the index vector. */
1378 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1380 obj
->ls
[dim_i
].idx
+= nml_carry
;
1382 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1384 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1390 /* Return a pointer beyond the furthest object accessed. */
1395 /* This is the entry function for namelist writes. It outputs the name
1396 of the namelist and iterates through the namelist by calls to
1397 nml_write_obj. The call below has dummys in the arguments used in
1398 the treatment of derived types. */
1401 namelist_write (st_parameter_dt
*dtp
)
1403 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1405 index_type dummy_offset
= 0;
1407 char * dummy_name
= NULL
;
1408 unit_delim tmp_delim
;
1410 /* Set the delimiter for namelist output. */
1412 tmp_delim
= dtp
->u
.p
.delim_status
;
1416 dtp
->u
.p
.nml_delim
= '"';
1419 case (DELIM_APOSTROPHE
):
1420 dtp
->u
.p
.nml_delim
= '\'';
1424 dtp
->u
.p
.nml_delim
= '\0';
1428 /* Temporarily disable namelist delimters. */
1429 dtp
->u
.p
.delim_status
= DELIM_NONE
;
1431 write_character (dtp
, "&", 1, 1);
1433 /* Write namelist name in upper case - f95 std. */
1434 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1436 c
= toupper (dtp
->namelist_name
[i
]);
1437 write_character (dtp
, &c
, 1 ,1);
1440 if (dtp
->u
.p
.ionml
!= NULL
)
1442 t1
= dtp
->u
.p
.ionml
;
1446 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1451 write_character (dtp
, " /\r\n", 1, 5);
1453 write_character (dtp
, " /\n", 1, 4);
1456 /* Restore the original delimiter. */
1457 dtp
->u
.p
.delim_status
= tmp_delim
;