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. */
311 p
= write_block (dtp
, wlen
- len
);
314 memset (p
, ' ', wlen
- len
);
317 /* Scan the source string looking for '\n' and convert it if found. */
318 qq
= (gfc_char4_t
*) source
;
319 for (i
= 0; i
< wlen
; i
++)
323 /* Write out the previously scanned characters in the string. */
326 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
327 write_utf8_char4 (dtp
, q
, bytes
, 0);
329 write_default_char4 (dtp
, q
, bytes
, 0);
333 /* Write out the CR_LF sequence. */
334 write_default_char4 (dtp
, crlf
, 2, 0);
340 /* Write out any remaining bytes if no LF was found. */
343 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
344 write_utf8_char4 (dtp
, q
, bytes
, 0);
346 write_default_char4 (dtp
, q
, bytes
, 0);
352 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
353 write_utf8_char4 (dtp
, q
, len
, wlen
);
355 write_default_char4 (dtp
, q
, len
, wlen
);
362 static GFC_INTEGER_LARGEST
363 extract_int (const void *p
, int len
)
365 GFC_INTEGER_LARGEST i
= 0;
375 memcpy ((void *) &tmp
, p
, len
);
382 memcpy ((void *) &tmp
, p
, len
);
389 memcpy ((void *) &tmp
, p
, len
);
396 memcpy ((void *) &tmp
, p
, len
);
400 #ifdef HAVE_GFC_INTEGER_16
404 memcpy ((void *) &tmp
, p
, len
);
410 internal_error (NULL
, "bad integer kind");
416 static GFC_UINTEGER_LARGEST
417 extract_uint (const void *p
, int len
)
419 GFC_UINTEGER_LARGEST i
= 0;
429 memcpy ((void *) &tmp
, p
, len
);
430 i
= (GFC_UINTEGER_1
) tmp
;
436 memcpy ((void *) &tmp
, p
, len
);
437 i
= (GFC_UINTEGER_2
) tmp
;
443 memcpy ((void *) &tmp
, p
, len
);
444 i
= (GFC_UINTEGER_4
) tmp
;
450 memcpy ((void *) &tmp
, p
, len
);
451 i
= (GFC_UINTEGER_8
) tmp
;
454 #ifdef HAVE_GFC_INTEGER_16
458 memcpy ((void *) &tmp
, p
, len
);
459 i
= (GFC_UINTEGER_16
) tmp
;
464 internal_error (NULL
, "bad integer kind");
472 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
476 GFC_INTEGER_LARGEST n
;
478 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
480 p
= write_block (dtp
, wlen
);
484 memset (p
, ' ', wlen
- 1);
485 n
= extract_int (source
, len
);
486 p
[wlen
- 1] = (n
) ? 'T' : 'F';
491 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
492 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
494 GFC_UINTEGER_LARGEST n
= 0;
495 int w
, m
, digits
, nzero
, nblank
;
498 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
503 n
= extract_uint (source
, len
);
507 if (m
== 0 && n
== 0)
512 p
= write_block (dtp
, w
);
520 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
523 /* Select a width if none was specified. The idea here is to always
527 w
= ((digits
< m
) ? m
: digits
);
529 p
= write_block (dtp
, w
);
537 /* See if things will work. */
539 nblank
= w
- (nzero
+ digits
);
548 if (!dtp
->u
.p
.no_leading_blank
)
550 memset (p
, ' ', nblank
);
552 memset (p
, '0', nzero
);
554 memcpy (p
, q
, digits
);
558 memset (p
, '0', nzero
);
560 memcpy (p
, q
, digits
);
562 memset (p
, ' ', nblank
);
563 dtp
->u
.p
.no_leading_blank
= 0;
571 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
573 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
575 GFC_INTEGER_LARGEST n
= 0;
576 int w
, m
, digits
, nsign
, nzero
, nblank
;
580 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
583 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
585 n
= extract_int (source
, len
);
588 if (m
== 0 && n
== 0)
593 p
= write_block (dtp
, w
);
601 sign
= calculate_sign (dtp
, n
< 0);
605 nsign
= sign
== S_NONE
? 0 : 1;
606 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
610 /* Select a width if none was specified. The idea here is to always
614 w
= ((digits
< m
) ? m
: digits
) + nsign
;
616 p
= write_block (dtp
, w
);
624 /* See if things will work. */
626 nblank
= w
- (nsign
+ nzero
+ digits
);
634 memset (p
, ' ', nblank
);
649 memset (p
, '0', nzero
);
652 memcpy (p
, q
, digits
);
659 /* Convert unsigned octal to ascii. */
662 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
666 assert (len
>= GFC_OTOA_BUF_SIZE
);
671 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
676 *--p
= '0' + (n
& 7);
684 /* Convert unsigned binary to ascii. */
687 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
691 assert (len
>= GFC_BTOA_BUF_SIZE
);
696 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
701 *--p
= '0' + (n
& 1);
710 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
712 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
717 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
719 write_int (dtp
, f
, p
, len
, btoa
);
724 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
726 write_int (dtp
, f
, p
, len
, otoa
);
730 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
732 write_int (dtp
, f
, p
, len
, xtoa
);
737 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
739 write_float (dtp
, f
, p
, len
);
744 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
746 write_float (dtp
, f
, p
, len
);
751 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
753 write_float (dtp
, f
, p
, len
);
758 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
760 write_float (dtp
, f
, p
, len
);
765 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
767 write_float (dtp
, f
, p
, len
);
771 /* Take care of the X/TR descriptor. */
774 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
778 p
= write_block (dtp
, len
);
783 memset (&p
[len
- nspaces
], ' ', nspaces
);
787 /* List-directed writing. */
790 /* Write a single character to the output. Returns nonzero if
791 something goes wrong. */
794 write_char (st_parameter_dt
*dtp
, char c
)
798 p
= write_block (dtp
, 1);
808 /* Write a list-directed logical value. */
811 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
813 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
817 /* Write a list-directed integer value. */
820 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
826 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
828 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
857 p
= write_block (dtp
, width
);
860 if (dtp
->u
.p
.no_leading_blank
)
862 memcpy (p
, q
, digits
);
863 memset (p
+ digits
, ' ', width
- digits
);
867 memset (p
, ' ', width
- digits
);
868 memcpy (p
+ width
- digits
, q
, digits
);
873 /* Write a list-directed string. We have to worry about delimiting
874 the strings if the file has been opened in that mode. */
877 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
882 switch (dtp
->u
.p
.delim_status
)
884 case DELIM_APOSTROPHE
:
903 for (i
= 0; i
< length
; i
++)
908 p
= write_block (dtp
, length
+ extra
);
913 memcpy (p
, source
, length
);
918 for (i
= 0; i
< length
; i
++)
932 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
933 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
935 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
939 p
= write_block (dtp
, 1);
942 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
943 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
945 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
947 p
= write_block (dtp
, 1);
954 /* Output a real number with default format.
955 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
956 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
959 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
962 int org_scale
= dtp
->u
.p
.scale_factor
;
964 dtp
->u
.p
.scale_factor
= 1;
988 internal_error (&dtp
->common
, "bad real kind");
991 write_float (dtp
, &f
, source
, length
);
992 dtp
->u
.p
.scale_factor
= org_scale
;
997 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
999 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
1001 if (write_char (dtp
, '('))
1003 write_real (dtp
, source
, kind
);
1005 if (write_char (dtp
, semi_comma
))
1007 write_real (dtp
, source
+ size
/ 2, kind
);
1009 write_char (dtp
, ')');
1013 /* Write the separator between items. */
1016 write_separator (st_parameter_dt
*dtp
)
1020 p
= write_block (dtp
, options
.separator_len
);
1024 memcpy (p
, options
.separator
, options
.separator_len
);
1028 /* Write an item with list formatting.
1029 TODO: handle skipping to the next record correctly, particularly
1033 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1036 if (dtp
->u
.p
.current_unit
== NULL
)
1039 if (dtp
->u
.p
.first_item
)
1041 dtp
->u
.p
.first_item
= 0;
1042 write_char (dtp
, ' ');
1046 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1047 dtp
->u
.p
.delim_status
!= DELIM_NONE
)
1048 write_separator (dtp
);
1054 write_integer (dtp
, p
, kind
);
1057 write_logical (dtp
, p
, kind
);
1060 write_character (dtp
, p
, kind
, size
);
1063 write_real (dtp
, p
, kind
);
1066 write_complex (dtp
, p
, kind
, size
);
1069 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1072 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1077 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1078 size_t size
, size_t nelems
)
1082 size_t stride
= type
== BT_CHARACTER
?
1083 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1087 /* Big loop over all the elements. */
1088 for (elem
= 0; elem
< nelems
; elem
++)
1090 dtp
->u
.p
.item_count
++;
1091 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1097 nml_write_obj writes a namelist object to the output stream. It is called
1098 recursively for derived type components:
1099 obj = is the namelist_info for the current object.
1100 offset = the offset relative to the address held by the object for
1101 derived type arrays.
1102 base = is the namelist_info of the derived type, when obj is a
1104 base_name = the full name for a derived type, including qualifiers
1106 The returned value is a pointer to the object beyond the last one
1107 accessed, including nested derived types. Notice that the namelist is
1108 a linear linked list of objects, including derived types and their
1109 components. A tree, of sorts, is implied by the compound names of
1110 the derived type components and this is how this function recurses through
1113 /* A generous estimate of the number of characters needed to print
1114 repeat counts and indices, including commas, asterices and brackets. */
1116 #define NML_DIGITS 20
1118 static namelist_info
*
1119 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1120 namelist_info
* base
, char * base_name
)
1126 index_type obj_size
;
1130 index_type elem_ctr
;
1131 index_type obj_name_len
;
1136 char rep_buff
[NML_DIGITS
];
1137 namelist_info
* cmp
;
1138 namelist_info
* retval
= obj
->next
;
1139 size_t base_name_len
;
1140 size_t base_var_name_len
;
1142 unit_delim tmp_delim
;
1144 /* Set the character to be used to separate values
1145 to a comma or semi-colon. */
1147 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
1149 /* Write namelist variable names in upper case. If a derived type,
1150 nothing is output. If a component, base and base_name are set. */
1152 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1155 write_character (dtp
, "\r\n ", 1, 3);
1157 write_character (dtp
, "\n ", 1, 2);
1162 len
=strlen (base
->var_name
);
1163 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1165 cup
= toupper (base_name
[dim_i
]);
1166 write_character (dtp
, &cup
, 1, 1);
1169 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1171 cup
= toupper (obj
->var_name
[dim_i
]);
1172 write_character (dtp
, &cup
, 1, 1);
1174 write_character (dtp
, "=", 1, 1);
1177 /* Counts the number of data output on a line, including names. */
1186 case GFC_DTYPE_REAL
:
1187 obj_size
= size_from_real_kind (len
);
1190 case GFC_DTYPE_COMPLEX
:
1191 obj_size
= size_from_complex_kind (len
);
1194 case GFC_DTYPE_CHARACTER
:
1195 obj_size
= obj
->string_length
;
1203 obj_size
= obj
->size
;
1205 /* Set the index vector and count the number of elements. */
1208 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1210 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1211 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1214 /* Main loop to output the data held in the object. */
1217 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1220 /* Build the pointer to the data value. The offset is passed by
1221 recursive calls to this function for arrays of derived types.
1222 Is NULL otherwise. */
1224 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1227 /* Check for repeat counts of intrinsic types. */
1229 if ((elem_ctr
< (nelem
- 1)) &&
1230 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1231 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1236 /* Execute a repeated output. Note the flag no_leading_blank that
1237 is used in the functions used to output the intrinsic types. */
1243 sprintf(rep_buff
, " %d*", rep_ctr
);
1244 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1245 dtp
->u
.p
.no_leading_blank
= 1;
1249 /* Output the data, if an intrinsic type, or recurse into this
1250 routine to treat derived types. */
1255 case GFC_DTYPE_INTEGER
:
1256 write_integer (dtp
, p
, len
);
1259 case GFC_DTYPE_LOGICAL
:
1260 write_logical (dtp
, p
, len
);
1263 case GFC_DTYPE_CHARACTER
:
1264 tmp_delim
= dtp
->u
.p
.delim_status
;
1265 if (dtp
->u
.p
.nml_delim
== '"')
1266 dtp
->u
.p
.delim_status
= DELIM_QUOTE
;
1267 if (dtp
->u
.p
.nml_delim
== '\'')
1268 dtp
->u
.p
.delim_status
= DELIM_APOSTROPHE
;
1269 write_character (dtp
, p
, 1, obj
->string_length
);
1270 dtp
->u
.p
.delim_status
= tmp_delim
;
1273 case GFC_DTYPE_REAL
:
1274 write_real (dtp
, p
, len
);
1277 case GFC_DTYPE_COMPLEX
:
1278 dtp
->u
.p
.no_leading_blank
= 0;
1280 write_complex (dtp
, p
, len
, obj_size
);
1283 case GFC_DTYPE_DERIVED
:
1285 /* To treat a derived type, we need to build two strings:
1286 ext_name = the name, including qualifiers that prepends
1287 component names in the output - passed to
1289 obj_name = the derived type name with no qualifiers but %
1290 appended. This is used to identify the
1293 /* First ext_name => get length of all possible components */
1295 base_name_len
= base_name
? strlen (base_name
) : 0;
1296 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1297 ext_name
= (char*)get_mem ( base_name_len
1299 + strlen (obj
->var_name
)
1300 + obj
->var_rank
* NML_DIGITS
1303 memcpy (ext_name
, base_name
, base_name_len
);
1304 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1305 memcpy (ext_name
+ base_name_len
,
1306 obj
->var_name
+ base_var_name_len
, clen
);
1308 /* Append the qualifier. */
1310 tot_len
= base_name_len
+ clen
;
1311 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1315 ext_name
[tot_len
] = '(';
1318 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1319 tot_len
+= strlen (ext_name
+ tot_len
);
1320 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1324 ext_name
[tot_len
] = '\0';
1328 obj_name_len
= strlen (obj
->var_name
) + 1;
1329 obj_name
= get_mem (obj_name_len
+1);
1330 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1331 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1333 /* Now loop over the components. Update the component pointer
1334 with the return value from nml_write_obj => this loop jumps
1335 past nested derived types. */
1337 for (cmp
= obj
->next
;
1338 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1341 retval
= nml_write_obj (dtp
, cmp
,
1342 (index_type
)(p
- obj
->mem_pos
),
1346 free_mem (obj_name
);
1347 free_mem (ext_name
);
1351 internal_error (&dtp
->common
, "Bad type for namelist write");
1354 /* Reset the leading blank suppression, write a comma (or semi-colon)
1355 and, if 5 values have been output, write a newline and advance
1356 to column 2. Reset the repeat counter. */
1358 dtp
->u
.p
.no_leading_blank
= 0;
1359 write_character (dtp
, &semi_comma
, 1, 1);
1364 write_character (dtp
, "\r\n ", 1, 3);
1366 write_character (dtp
, "\n ", 1, 2);
1372 /* Cycle through and increment the index vector. */
1377 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1379 obj
->ls
[dim_i
].idx
+= nml_carry
;
1381 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1383 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1389 /* Return a pointer beyond the furthest object accessed. */
1394 /* This is the entry function for namelist writes. It outputs the name
1395 of the namelist and iterates through the namelist by calls to
1396 nml_write_obj. The call below has dummys in the arguments used in
1397 the treatment of derived types. */
1400 namelist_write (st_parameter_dt
*dtp
)
1402 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1404 index_type dummy_offset
= 0;
1406 char * dummy_name
= NULL
;
1407 unit_delim tmp_delim
;
1409 /* Set the delimiter for namelist output. */
1411 tmp_delim
= dtp
->u
.p
.delim_status
;
1415 dtp
->u
.p
.nml_delim
= '"';
1418 case (DELIM_APOSTROPHE
):
1419 dtp
->u
.p
.nml_delim
= '\'';
1423 dtp
->u
.p
.nml_delim
= '\0';
1427 /* Temporarily disable namelist delimters. */
1428 dtp
->u
.p
.delim_status
= DELIM_NONE
;
1430 write_character (dtp
, "&", 1, 1);
1432 /* Write namelist name in upper case - f95 std. */
1433 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1435 c
= toupper (dtp
->namelist_name
[i
]);
1436 write_character (dtp
, &c
, 1 ,1);
1439 if (dtp
->u
.p
.ionml
!= NULL
)
1441 t1
= dtp
->u
.p
.ionml
;
1445 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1450 write_character (dtp
, " /\r\n", 1, 5);
1452 write_character (dtp
, " /\n", 1, 4);
1455 /* Restore the original delimiter. */
1456 dtp
->u
.p
.delim_status
= tmp_delim
;