1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist output contibuted by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA. */
37 #include "libgfortran.h"
40 #define star_fill(p, n) memset(p, '*', n)
44 { SIGN_NONE
, SIGN_MINUS
, SIGN_PLUS
}
48 static int no_leading_blank
= 0 ;
51 write_a (fnode
* f
, const char *source
, int len
)
56 wlen
= f
->u
.string
.length
< 0 ? len
: f
->u
.string
.length
;
58 p
= write_block (wlen
);
63 memcpy (p
, source
, wlen
);
66 memset (p
, ' ', wlen
- len
);
67 memcpy (p
+ wlen
- len
, source
, len
);
71 static GFC_INTEGER_LARGEST
72 extract_int (const void *p
, int len
)
74 GFC_INTEGER_LARGEST i
= 0;
82 i
= *((const GFC_INTEGER_1
*) p
);
85 i
= *((const GFC_INTEGER_2
*) p
);
88 i
= *((const GFC_INTEGER_4
*) p
);
91 i
= *((const GFC_INTEGER_8
*) p
);
93 #ifdef HAVE_GFC_INTEGER_16
95 i
= *((const GFC_INTEGER_16
*) p
);
99 internal_error ("bad integer kind");
105 static GFC_UINTEGER_LARGEST
106 extract_uint (const void *p
, int len
)
108 GFC_UINTEGER_LARGEST i
= 0;
116 i
= (GFC_UINTEGER_1
) *((const GFC_INTEGER_1
*) p
);
119 i
= (GFC_UINTEGER_2
) *((const GFC_INTEGER_2
*) p
);
122 i
= (GFC_UINTEGER_4
) *((const GFC_INTEGER_4
*) p
);
125 i
= (GFC_UINTEGER_8
) *((const GFC_INTEGER_8
*) p
);
127 #ifdef HAVE_GFC_INTEGER_16
129 i
= (GFC_UINTEGER_16
) *((const GFC_INTEGER_16
*) p
);
133 internal_error ("bad integer kind");
139 static GFC_REAL_LARGEST
140 extract_real (const void *p
, int len
)
142 GFC_REAL_LARGEST i
= 0;
146 i
= *((const GFC_REAL_4
*) p
);
149 i
= *((const GFC_REAL_8
*) p
);
151 #ifdef HAVE_GFC_REAL_10
153 i
= *((const GFC_REAL_10
*) p
);
156 #ifdef HAVE_GFC_REAL_16
158 i
= *((const GFC_REAL_16
*) p
);
162 internal_error ("bad real kind");
168 /* Given a flag that indicate if a value is negative or not, return a
169 sign_t that gives the sign that we need to produce. */
172 calculate_sign (int negative_flag
)
174 sign_t s
= SIGN_NONE
;
179 switch (g
.sign_status
)
188 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
196 /* Returns the value of 10**d. */
198 static GFC_REAL_LARGEST
199 calculate_exp (int d
)
202 GFC_REAL_LARGEST r
= 1.0;
204 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
207 r
= (d
>= 0) ? r
: 1.0 / r
;
213 /* Generate corresponding I/O format for FMT_G output.
214 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
215 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
217 Data Magnitude Equivalent Conversion
218 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
219 m = 0 F(w-n).(d-1), n' '
220 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
221 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
222 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
223 ................ ..........
224 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
225 m >= 10**d-0.5 Ew.d[Ee]
227 notes: for Gw.d , n' ' means 4 blanks
228 for Gw.dEe, n' ' means e+2 blanks */
231 calculate_G_format (fnode
*f
, GFC_REAL_LARGEST value
, int *num_blank
)
237 GFC_REAL_LARGEST m
, exp_d
;
241 newf
= get_mem (sizeof (fnode
));
243 /* Absolute value. */
244 m
= (value
> 0.0) ? value
: -value
;
246 /* In case of the two data magnitude ranges,
247 generate E editing, Ew.d[Ee]. */
248 exp_d
= calculate_exp (d
);
249 if ((m
> 0.0 && m
< 0.1 - 0.05 / exp_d
) || (m
>= exp_d
- 0.5 ))
251 newf
->format
= FMT_E
;
259 /* Use binary search to find the data magnitude range. */
268 GFC_REAL_LARGEST temp
;
269 mid
= (low
+ high
) / 2;
271 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
272 temp
= 0.1 * calculate_exp (mid
) - 0.5 * calculate_exp (mid
- d
- 1);
277 if (ubound
== lbound
+ 1)
284 if (ubound
== lbound
+ 1)
295 /* Pad with blanks where the exponent would be. */
301 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
302 newf
->format
= FMT_F
;
303 newf
->u
.real
.w
= f
->u
.real
.w
- *num_blank
;
307 newf
->u
.real
.d
= d
- 1;
309 newf
->u
.real
.d
= - (mid
- d
- 1);
311 /* For F editing, the scale factor is ignored. */
317 /* Output a real number according to its format which is FMT_G free. */
320 output_float (fnode
*f
, GFC_REAL_LARGEST value
)
322 /* This must be large enough to accurately hold any value. */
333 /* Number of digits before the decimal point. */
335 /* Number of zeros after the decimal point. */
337 /* Number of digits after the decimal point. */
339 /* Number of zeros after the decimal point, whatever the precision. */
354 /* We should always know the field width and precision. */
356 internal_error ("Unspecified precision");
358 /* Use sprintf to print the number in the format +D.DDDDe+ddd
359 For an N digit exponent, this gives us (32-6)-N digits after the
360 decimal point, plus another one before the decimal point. */
361 sign
= calculate_sign (value
< 0.0);
365 /* Printf always prints at least two exponent digits. */
370 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
371 abslog
= fabs((double) log10l(value
));
373 abslog
= fabs(log10(value
));
378 edigits
= 1 + (int) log10(abslog
);
381 if (ft
== FMT_F
|| ft
== FMT_EN
382 || ((ft
== FMT_D
|| ft
== FMT_E
) && g
.scale_factor
!= 0))
384 /* Always convert at full precision to avoid double rounding. */
385 ndigits
= 27 - edigits
;
389 /* We know the number of digits, so can let printf do the rounding
395 if (ndigits
> 27 - edigits
)
396 ndigits
= 27 - edigits
;
399 /* # The result will always contain a decimal point, even if no
402 * - The converted value is to be left adjusted on the field boundary
404 * + A sign (+ or -) always be placed before a number
406 * 31 minimum field width
408 * * (ndigits-1) is used as the precision
410 * e format: [-]d.ddde±dd where there is one digit before the
411 * decimal-point character and the number of digits after it is
412 * equal to the precision. The exponent always contains at least two
413 * digits; if the value is zero, the exponent is 00.
415 sprintf (buffer
, "%+-#31.*" GFC_REAL_LARGEST_FORMAT
"e",
418 /* Check the resulting string has punctuation in the correct places. */
419 if (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e')
420 internal_error ("printf is broken");
422 /* Read the exponent back in. */
423 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
425 /* Make sure zero comes out as 0.0e0. */
429 /* Normalize the fractional component. */
430 buffer
[2] = buffer
[1];
433 /* Figure out where to place the decimal point. */
437 nbefore
= e
+ g
.scale_factor
;
470 nafter
= (d
- i
) + 1;
486 /* The exponent must be a multiple of three, with 1-3 digits before
487 the decimal point. */
496 nbefore
= 3 - nbefore
;
515 /* Should never happen. */
516 internal_error ("Unexpected format token");
519 /* Round the value. */
520 if (nbefore
+ nafter
== 0)
523 if (nzero_real
== d
&& digits
[0] >= '5')
525 /* We rounded to zero but shouldn't have */
532 else if (nbefore
+ nafter
< ndigits
)
534 ndigits
= nbefore
+ nafter
;
536 if (digits
[i
] >= '5')
538 /* Propagate the carry. */
539 for (i
--; i
>= 0; i
--)
541 if (digits
[i
] != '9')
551 /* The carry overflowed. Fortunately we have some spare space
552 at the start of the buffer. We may discard some digits, but
553 this is ok because we already know they are zero. */
566 else if (ft
== FMT_EN
)
581 /* Calculate the format of the exponent field. */
585 for (i
= abs (e
); i
>= 10; i
/= 10)
590 /* Width not specified. Must be no more than 3 digits. */
591 if (e
> 999 || e
< -999)
596 if (e
> 99 || e
< -99)
602 /* Exponent width specified, check it is wide enough. */
603 if (edigits
> f
->u
.real
.e
)
606 edigits
= f
->u
.real
.e
+ 2;
612 /* Pick a field size if none was specified. */
614 w
= nbefore
+ nzero
+ nafter
+ (sign
!= SIGN_NONE
? 2 : 1);
616 /* Create the ouput buffer. */
617 out
= write_block (w
);
621 /* Zero values always output as positive, even if the value was negative
623 for (i
= 0; i
< ndigits
; i
++)
625 if (digits
[i
] != '0')
629 sign
= calculate_sign (0);
631 /* Work out how much padding is needed. */
632 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
633 if (sign
!= SIGN_NONE
)
636 /* Check the value fits in the specified field width. */
637 if (nblanks
< 0 || edigits
== -1)
643 /* See if we have space for a zero before the decimal point. */
644 if (nbefore
== 0 && nblanks
> 0)
652 /* Padd to full field width. */
655 if ( ( nblanks
> 0 ) && !no_leading_blank
)
657 memset (out
, ' ', nblanks
);
661 /* Output the initial sign (if any). */
662 if (sign
== SIGN_PLUS
)
664 else if (sign
== SIGN_MINUS
)
667 /* Output an optional leading zero. */
671 /* Output the part before the decimal point, padding with zeros. */
674 if (nbefore
> ndigits
)
679 memcpy (out
, digits
, i
);
687 /* Output the decimal point. */
690 /* Output leading zeros after the decimal point. */
693 for (i
= 0; i
< nzero
; i
++)
697 /* Output digits after the decimal point, padding with zeros. */
700 if (nafter
> ndigits
)
705 memcpy (out
, digits
, i
);
714 /* Output the exponent. */
723 snprintf (buffer
, 32, "%+0*d", edigits
, e
);
725 sprintf (buffer
, "%+0*d", edigits
, e
);
727 memcpy (out
, buffer
, edigits
);
730 if ( no_leading_blank
)
733 memset( out
, ' ' , nblanks
);
734 no_leading_blank
= 0;
740 write_l (fnode
* f
, char *source
, int len
)
743 GFC_INTEGER_LARGEST n
;
745 p
= write_block (f
->u
.w
);
749 memset (p
, ' ', f
->u
.w
- 1);
750 n
= extract_int (source
, len
);
751 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
754 /* Output a real number according to its format. */
757 write_float (fnode
*f
, const char *source
, int len
)
760 int nb
=0, res
, save_scale_factor
;
764 n
= extract_real (source
, len
);
766 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
768 /* TODO: there are some systems where isfinite is not able to work
769 with long double variables. We should detect this case and
770 provide our own version for isfinite. */
775 p
= write_block (nb
);
792 memcpy(p
+ nb
- 8, "Infinity", 8);
794 memcpy(p
+ nb
- 3, "Inf", 3);
795 if (nb
< 8 && nb
> 3)
801 memcpy(p
+ nb
- 3, "NaN", 3);
806 if (f
->format
!= FMT_G
)
812 save_scale_factor
= g
.scale_factor
;
813 f2
= calculate_G_format(f
, n
, &nb
);
814 output_float (f2
, n
);
815 g
.scale_factor
= save_scale_factor
;
821 p
= write_block (nb
);
829 write_int (fnode
*f
, const char *source
, int len
,
830 char *(*conv
) (GFC_UINTEGER_LARGEST
))
832 GFC_UINTEGER_LARGEST n
= 0;
833 int w
, m
, digits
, nzero
, nblank
;
839 n
= extract_uint (source
, len
);
843 if (m
== 0 && n
== 0)
859 /* Select a width if none was specified. The idea here is to always
863 w
= ((digits
< m
) ? m
: digits
);
873 /* See if things will work. */
875 nblank
= w
- (nzero
+ digits
);
884 if (!no_leading_blank
)
886 memset (p
, ' ', nblank
);
888 memset (p
, '0', nzero
);
890 memcpy (p
, q
, digits
);
894 memset (p
, '0', nzero
);
896 memcpy (p
, q
, digits
);
898 memset (p
, ' ', nblank
);
899 no_leading_blank
= 0;
907 write_decimal (fnode
*f
, const char *source
, int len
,
908 char *(*conv
) (GFC_INTEGER_LARGEST
))
910 GFC_INTEGER_LARGEST n
= 0;
911 int w
, m
, digits
, nsign
, nzero
, nblank
;
918 n
= extract_int (source
, len
);
922 if (m
== 0 && n
== 0)
935 sign
= calculate_sign (n
< 0);
939 nsign
= sign
== SIGN_NONE
? 0 : 1;
944 /* Select a width if none was specified. The idea here is to always
948 w
= ((digits
< m
) ? m
: digits
) + nsign
;
958 /* See if things will work. */
960 nblank
= w
- (nsign
+ nzero
+ digits
);
968 memset (p
, ' ', nblank
);
983 memset (p
, '0', nzero
);
986 memcpy (p
, q
, digits
);
993 /* Convert unsigned octal to ascii. */
996 otoa (GFC_UINTEGER_LARGEST n
)
1007 p
= scratch
+ SCRATCH_SIZE
- 1;
1021 /* Convert unsigned binary to ascii. */
1024 btoa (GFC_UINTEGER_LARGEST n
)
1035 p
= scratch
+ SCRATCH_SIZE
- 1;
1040 *p
-- = '0' + (n
& 1);
1049 write_i (fnode
* f
, const char *p
, int len
)
1051 write_decimal (f
, p
, len
, (void *) gfc_itoa
);
1056 write_b (fnode
* f
, const char *p
, int len
)
1058 write_int (f
, p
, len
, btoa
);
1063 write_o (fnode
* f
, const char *p
, int len
)
1065 write_int (f
, p
, len
, otoa
);
1069 write_z (fnode
* f
, const char *p
, int len
)
1071 write_int (f
, p
, len
, xtoa
);
1076 write_d (fnode
*f
, const char *p
, int len
)
1078 write_float (f
, p
, len
);
1083 write_e (fnode
*f
, const char *p
, int len
)
1085 write_float (f
, p
, len
);
1090 write_f (fnode
*f
, const char *p
, int len
)
1092 write_float (f
, p
, len
);
1097 write_en (fnode
*f
, const char *p
, int len
)
1099 write_float (f
, p
, len
);
1104 write_es (fnode
*f
, const char *p
, int len
)
1106 write_float (f
, p
, len
);
1110 /* Take care of the X/TR descriptor. */
1113 write_x (int len
, int nspaces
)
1117 p
= write_block (len
);
1122 memset (&p
[len
- nspaces
], ' ', nspaces
);
1126 /* List-directed writing. */
1129 /* Write a single character to the output. Returns nonzero if
1130 something goes wrong. */
1137 p
= write_block (1);
1147 /* Write a list-directed logical value. */
1150 write_logical (const char *source
, int length
)
1152 write_char (extract_int (source
, length
) ? 'T' : 'F');
1156 /* Write a list-directed integer value. */
1159 write_integer (const char *source
, int length
)
1166 q
= gfc_itoa (extract_int (source
, length
));
1191 digits
= strlen (q
);
1195 p
= write_block (width
) ;
1196 if (no_leading_blank
)
1198 memcpy (p
, q
, digits
);
1199 memset(p
+ digits
,' ', width
- digits
) ;
1203 memset(p
,' ', width
- digits
) ;
1204 memcpy (p
+ width
- digits
, q
, digits
);
1209 /* Write a list-directed string. We have to worry about delimiting
1210 the strings if the file has been opened in that mode. */
1213 write_character (const char *source
, int length
)
1218 switch (current_unit
->flags
.delim
)
1220 case DELIM_APOSTROPHE
:
1237 for (i
= 0; i
< length
; i
++)
1242 p
= write_block (length
+ extra
);
1247 memcpy (p
, source
, length
);
1252 for (i
= 0; i
< length
; i
++)
1264 /* Output a real number with default format.
1265 This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8). */
1268 write_real (const char *source
, int length
)
1271 int org_scale
= g
.scale_factor
;
1286 write_float (&f
, source
, length
);
1287 g
.scale_factor
= org_scale
;
1292 write_complex (const char *source
, int len
)
1294 if (write_char ('('))
1296 write_real (source
, len
);
1298 if (write_char (','))
1300 write_real (source
+ len
, len
);
1306 /* Write the separator between items. */
1309 write_separator (void)
1313 p
= write_block (options
.separator_len
);
1317 memcpy (p
, options
.separator
, options
.separator_len
);
1321 /* Write an item with list formatting.
1322 TODO: handle skipping to the next record correctly, particularly
1326 list_formatted_write (bt type
, void *p
, int len
)
1328 static int char_flag
;
1330 if (current_unit
== NULL
)
1341 if (type
!= BT_CHARACTER
|| !char_flag
||
1342 current_unit
->flags
.delim
!= DELIM_NONE
)
1349 write_integer (p
, len
);
1352 write_logical (p
, len
);
1355 write_character (p
, len
);
1358 write_real (p
, len
);
1361 write_complex (p
, len
);
1364 internal_error ("list_formatted_write(): Bad type");
1367 char_flag
= (type
== BT_CHARACTER
);
1372 nml_write_obj writes a namelist object to the output stream. It is called
1373 recursively for derived type components:
1374 obj = is the namelist_info for the current object.
1375 offset = the offset relative to the address held by the object for
1376 derived type arrays.
1377 base = is the namelist_info of the derived type, when obj is a
1379 base_name = the full name for a derived type, including qualifiers
1381 The returned value is a pointer to the object beyond the last one
1382 accessed, including nested derived types. Notice that the namelist is
1383 a linear linked list of objects, including derived types and their
1384 components. A tree, of sorts, is implied by the compound names of
1385 the derived type components and this is how this function recurses through
1388 /* A generous estimate of the number of characters needed to print
1389 repeat counts and indices, including commas, asterices and brackets. */
1391 #define NML_DIGITS 20
1393 /* Stores the delimiter to be used for character objects. */
1395 static const char * nml_delim
;
1397 static namelist_info
*
1398 nml_write_obj (namelist_info
* obj
, index_type offset
,
1399 namelist_info
* base
, char * base_name
)
1405 index_type obj_size
;
1409 index_type elem_ctr
;
1410 index_type obj_name_len
;
1415 char rep_buff
[NML_DIGITS
];
1416 namelist_info
* cmp
;
1417 namelist_info
* retval
= obj
->next
;
1419 /* Write namelist variable names in upper case. If a derived type,
1420 nothing is output. If a component, base and base_name are set. */
1422 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1424 write_character ("\n ", 2);
1428 len
=strlen (base
->var_name
);
1429 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1431 cup
= toupper (base_name
[dim_i
]);
1432 write_character (&cup
, 1);
1435 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1437 cup
= toupper (obj
->var_name
[dim_i
]);
1438 write_character (&cup
, 1);
1440 write_character ("=", 1);
1443 /* Counts the number of data output on a line, including names. */
1449 if (obj
->type
== GFC_DTYPE_COMPLEX
)
1451 if (obj
->type
== GFC_DTYPE_CHARACTER
)
1452 obj_size
= obj
->string_length
;
1454 obj_size
= obj
->size
;
1456 /* Set the index vector and count the number of elements. */
1459 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1461 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1462 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1465 /* Main loop to output the data held in the object. */
1468 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1471 /* Build the pointer to the data value. The offset is passed by
1472 recursive calls to this function for arrays of derived types.
1473 Is NULL otherwise. */
1475 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1478 /* Check for repeat counts of intrinsic types. */
1480 if ((elem_ctr
< (nelem
- 1)) &&
1481 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1482 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1487 /* Execute a repeated output. Note the flag no_leading_blank that
1488 is used in the functions used to output the intrinsic types. */
1494 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1495 write_character (rep_buff
, strlen (rep_buff
));
1496 no_leading_blank
= 1;
1500 /* Output the data, if an intrinsic type, or recurse into this
1501 routine to treat derived types. */
1506 case GFC_DTYPE_INTEGER
:
1507 write_integer (p
, len
);
1510 case GFC_DTYPE_LOGICAL
:
1511 write_logical (p
, len
);
1514 case GFC_DTYPE_CHARACTER
:
1516 write_character (nml_delim
, 1);
1517 write_character (p
, obj
->string_length
);
1519 write_character (nml_delim
, 1);
1522 case GFC_DTYPE_REAL
:
1523 write_real (p
, len
);
1526 case GFC_DTYPE_COMPLEX
:
1527 no_leading_blank
= 0;
1529 write_complex (p
, len
);
1532 case GFC_DTYPE_DERIVED
:
1534 /* To treat a derived type, we need to build two strings:
1535 ext_name = the name, including qualifiers that prepends
1536 component names in the output - passed to
1538 obj_name = the derived type name with no qualifiers but %
1539 appended. This is used to identify the
1542 /* First ext_name => get length of all possible components */
1544 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1545 + (base
? strlen (base
->var_name
) : 0)
1546 + strlen (obj
->var_name
)
1547 + obj
->var_rank
* NML_DIGITS
1550 strcpy(ext_name
, base_name
? base_name
: "");
1551 clen
= base
? strlen (base
->var_name
) : 0;
1552 strcat (ext_name
, obj
->var_name
+ clen
);
1554 /* Append the qualifier. */
1556 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1558 strcat (ext_name
, dim_i
? "" : "(");
1559 clen
= strlen (ext_name
);
1560 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1561 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1566 obj_name_len
= strlen (obj
->var_name
) + 1;
1567 obj_name
= get_mem (obj_name_len
+1);
1568 strcpy (obj_name
, obj
->var_name
);
1569 strcat (obj_name
, "%");
1571 /* Now loop over the components. Update the component pointer
1572 with the return value from nml_write_obj => this loop jumps
1573 past nested derived types. */
1575 for (cmp
= obj
->next
;
1576 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1579 retval
= nml_write_obj (cmp
, (index_type
)(p
- obj
->mem_pos
),
1583 free_mem (obj_name
);
1584 free_mem (ext_name
);
1588 internal_error ("Bad type for namelist write");
1591 /* Reset the leading blank suppression, write a comma and, if 5
1592 values have been output, write a newline and advance to column
1593 2. Reset the repeat counter. */
1595 no_leading_blank
= 0;
1596 write_character (",", 1);
1600 write_character ("\n ", 2);
1605 /* Cycle through and increment the index vector. */
1610 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1612 obj
->ls
[dim_i
].idx
+= nml_carry
;
1614 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1616 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1622 /* Return a pointer beyond the furthest object accessed. */
1627 /* This is the entry function for namelist writes. It outputs the name
1628 of the namelist and iterates through the namelist by calls to
1629 nml_write_obj. The call below has dummys in the arguments used in
1630 the treatment of derived types. */
1633 namelist_write (void)
1635 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1637 index_type dummy_offset
= 0;
1639 char * dummy_name
= NULL
;
1640 unit_delim tmp_delim
;
1642 /* Set the delimiter for namelist output. */
1644 tmp_delim
= current_unit
->flags
.delim
;
1645 current_unit
->flags
.delim
= DELIM_NONE
;
1652 case (DELIM_APOSTROPHE
):
1660 write_character ("&",1);
1662 /* Write namelist name in upper case - f95 std. */
1664 for (i
= 0 ;i
< ioparm
.namelist_name_len
;i
++ )
1666 c
= toupper (ioparm
.namelist_name
[i
]);
1667 write_character (&c
,1);
1676 t1
= nml_write_obj (t2
, dummy_offset
, dummy
, dummy_name
);
1679 write_character (" /\n", 4);
1681 /* Recover the original delimiter. */
1683 current_unit
->flags
.delim
= tmp_delim
;