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 /* Pad 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. */
776 /* If the field width is zero, the processor must select a width
777 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
780 p
= write_block (nb
);
794 /* If the sign is negative and the width is 3, there is
795 insufficient room to output '-Inf', so output asterisks */
803 /* The negative sign is mandatory */
809 /* The positive sign is optional, but we output it for
816 /* We have room, so output 'Infinity' */
818 memcpy(p
+ nb
- 8, "Infinity", 8);
821 /* For the case of width equals 8, there is not enough room
822 for the sign and 'Infinity' so we go with 'Inf' */
824 memcpy(p
+ nb
- 3, "Inf", 3);
825 if (nb
< 9 && nb
> 3)
826 p
[nb
- 4] = fin
; /* Put the sign in front of Inf */
828 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity */
831 memcpy(p
+ nb
- 3, "NaN", 3);
836 if (f
->format
!= FMT_G
)
842 save_scale_factor
= g
.scale_factor
;
843 f2
= calculate_G_format(f
, n
, &nb
);
844 output_float (f2
, n
);
845 g
.scale_factor
= save_scale_factor
;
851 p
= write_block (nb
);
859 write_int (fnode
*f
, const char *source
, int len
,
860 char *(*conv
) (GFC_UINTEGER_LARGEST
))
862 GFC_UINTEGER_LARGEST n
= 0;
863 int w
, m
, digits
, nzero
, nblank
;
869 n
= extract_uint (source
, len
);
873 if (m
== 0 && n
== 0)
889 /* Select a width if none was specified. The idea here is to always
893 w
= ((digits
< m
) ? m
: digits
);
903 /* See if things will work. */
905 nblank
= w
- (nzero
+ digits
);
914 if (!no_leading_blank
)
916 memset (p
, ' ', nblank
);
918 memset (p
, '0', nzero
);
920 memcpy (p
, q
, digits
);
924 memset (p
, '0', nzero
);
926 memcpy (p
, q
, digits
);
928 memset (p
, ' ', nblank
);
929 no_leading_blank
= 0;
937 write_decimal (fnode
*f
, const char *source
, int len
,
938 char *(*conv
) (GFC_INTEGER_LARGEST
))
940 GFC_INTEGER_LARGEST n
= 0;
941 int w
, m
, digits
, nsign
, nzero
, nblank
;
948 n
= extract_int (source
, len
);
952 if (m
== 0 && n
== 0)
965 sign
= calculate_sign (n
< 0);
969 nsign
= sign
== SIGN_NONE
? 0 : 1;
974 /* Select a width if none was specified. The idea here is to always
978 w
= ((digits
< m
) ? m
: digits
) + nsign
;
988 /* See if things will work. */
990 nblank
= w
- (nsign
+ nzero
+ digits
);
998 memset (p
, ' ', nblank
);
1013 memset (p
, '0', nzero
);
1016 memcpy (p
, q
, digits
);
1023 /* Convert unsigned octal to ascii. */
1026 otoa (GFC_UINTEGER_LARGEST n
)
1037 p
= scratch
+ SCRATCH_SIZE
- 1;
1051 /* Convert unsigned binary to ascii. */
1054 btoa (GFC_UINTEGER_LARGEST n
)
1065 p
= scratch
+ SCRATCH_SIZE
- 1;
1070 *p
-- = '0' + (n
& 1);
1079 write_i (fnode
* f
, const char *p
, int len
)
1081 write_decimal (f
, p
, len
, (void *) gfc_itoa
);
1086 write_b (fnode
* f
, const char *p
, int len
)
1088 write_int (f
, p
, len
, btoa
);
1093 write_o (fnode
* f
, const char *p
, int len
)
1095 write_int (f
, p
, len
, otoa
);
1099 write_z (fnode
* f
, const char *p
, int len
)
1101 write_int (f
, p
, len
, xtoa
);
1106 write_d (fnode
*f
, const char *p
, int len
)
1108 write_float (f
, p
, len
);
1113 write_e (fnode
*f
, const char *p
, int len
)
1115 write_float (f
, p
, len
);
1120 write_f (fnode
*f
, const char *p
, int len
)
1122 write_float (f
, p
, len
);
1127 write_en (fnode
*f
, const char *p
, int len
)
1129 write_float (f
, p
, len
);
1134 write_es (fnode
*f
, const char *p
, int len
)
1136 write_float (f
, p
, len
);
1140 /* Take care of the X/TR descriptor. */
1143 write_x (int len
, int nspaces
)
1147 p
= write_block (len
);
1152 memset (&p
[len
- nspaces
], ' ', nspaces
);
1156 /* List-directed writing. */
1159 /* Write a single character to the output. Returns nonzero if
1160 something goes wrong. */
1167 p
= write_block (1);
1177 /* Write a list-directed logical value. */
1180 write_logical (const char *source
, int length
)
1182 write_char (extract_int (source
, length
) ? 'T' : 'F');
1186 /* Write a list-directed integer value. */
1189 write_integer (const char *source
, int length
)
1196 q
= gfc_itoa (extract_int (source
, length
));
1221 digits
= strlen (q
);
1225 p
= write_block (width
) ;
1226 if (no_leading_blank
)
1228 memcpy (p
, q
, digits
);
1229 memset(p
+ digits
,' ', width
- digits
) ;
1233 memset(p
,' ', width
- digits
) ;
1234 memcpy (p
+ width
- digits
, q
, digits
);
1239 /* Write a list-directed string. We have to worry about delimiting
1240 the strings if the file has been opened in that mode. */
1243 write_character (const char *source
, int length
)
1248 switch (current_unit
->flags
.delim
)
1250 case DELIM_APOSTROPHE
:
1267 for (i
= 0; i
< length
; i
++)
1272 p
= write_block (length
+ extra
);
1277 memcpy (p
, source
, length
);
1282 for (i
= 0; i
< length
; i
++)
1294 /* Output a real number with default format.
1295 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1296 1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
1299 write_real (const char *source
, int length
)
1302 int org_scale
= g
.scale_factor
;
1328 internal_error ("bad real kind");
1331 write_float (&f
, source
, length
);
1332 g
.scale_factor
= org_scale
;
1337 write_complex (const char *source
, int len
)
1339 if (write_char ('('))
1341 write_real (source
, len
);
1343 if (write_char (','))
1345 write_real (source
+ len
, len
);
1351 /* Write the separator between items. */
1354 write_separator (void)
1358 p
= write_block (options
.separator_len
);
1362 memcpy (p
, options
.separator
, options
.separator_len
);
1366 /* Write an item with list formatting.
1367 TODO: handle skipping to the next record correctly, particularly
1371 list_formatted_write (bt type
, void *p
, int len
)
1373 static int char_flag
;
1375 if (current_unit
== NULL
)
1386 if (type
!= BT_CHARACTER
|| !char_flag
||
1387 current_unit
->flags
.delim
!= DELIM_NONE
)
1394 write_integer (p
, len
);
1397 write_logical (p
, len
);
1400 write_character (p
, len
);
1403 write_real (p
, len
);
1406 write_complex (p
, len
);
1409 internal_error ("list_formatted_write(): Bad type");
1412 char_flag
= (type
== BT_CHARACTER
);
1417 nml_write_obj writes a namelist object to the output stream. It is called
1418 recursively for derived type components:
1419 obj = is the namelist_info for the current object.
1420 offset = the offset relative to the address held by the object for
1421 derived type arrays.
1422 base = is the namelist_info of the derived type, when obj is a
1424 base_name = the full name for a derived type, including qualifiers
1426 The returned value is a pointer to the object beyond the last one
1427 accessed, including nested derived types. Notice that the namelist is
1428 a linear linked list of objects, including derived types and their
1429 components. A tree, of sorts, is implied by the compound names of
1430 the derived type components and this is how this function recurses through
1433 /* A generous estimate of the number of characters needed to print
1434 repeat counts and indices, including commas, asterices and brackets. */
1436 #define NML_DIGITS 20
1438 /* Stores the delimiter to be used for character objects. */
1440 static const char * nml_delim
;
1442 static namelist_info
*
1443 nml_write_obj (namelist_info
* obj
, index_type offset
,
1444 namelist_info
* base
, char * base_name
)
1450 index_type obj_size
;
1454 index_type elem_ctr
;
1455 index_type obj_name_len
;
1460 char rep_buff
[NML_DIGITS
];
1461 namelist_info
* cmp
;
1462 namelist_info
* retval
= obj
->next
;
1464 /* Write namelist variable names in upper case. If a derived type,
1465 nothing is output. If a component, base and base_name are set. */
1467 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1469 write_character ("\n ", 2);
1473 len
=strlen (base
->var_name
);
1474 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1476 cup
= toupper (base_name
[dim_i
]);
1477 write_character (&cup
, 1);
1480 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1482 cup
= toupper (obj
->var_name
[dim_i
]);
1483 write_character (&cup
, 1);
1485 write_character ("=", 1);
1488 /* Counts the number of data output on a line, including names. */
1494 if (obj
->type
== GFC_DTYPE_COMPLEX
)
1496 if (obj
->type
== GFC_DTYPE_CHARACTER
)
1497 obj_size
= obj
->string_length
;
1499 obj_size
= obj
->size
;
1501 /* Set the index vector and count the number of elements. */
1504 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1506 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1507 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1510 /* Main loop to output the data held in the object. */
1513 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1516 /* Build the pointer to the data value. The offset is passed by
1517 recursive calls to this function for arrays of derived types.
1518 Is NULL otherwise. */
1520 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1523 /* Check for repeat counts of intrinsic types. */
1525 if ((elem_ctr
< (nelem
- 1)) &&
1526 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1527 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1532 /* Execute a repeated output. Note the flag no_leading_blank that
1533 is used in the functions used to output the intrinsic types. */
1539 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1540 write_character (rep_buff
, strlen (rep_buff
));
1541 no_leading_blank
= 1;
1545 /* Output the data, if an intrinsic type, or recurse into this
1546 routine to treat derived types. */
1551 case GFC_DTYPE_INTEGER
:
1552 write_integer (p
, len
);
1555 case GFC_DTYPE_LOGICAL
:
1556 write_logical (p
, len
);
1559 case GFC_DTYPE_CHARACTER
:
1561 write_character (nml_delim
, 1);
1562 write_character (p
, obj
->string_length
);
1564 write_character (nml_delim
, 1);
1567 case GFC_DTYPE_REAL
:
1568 write_real (p
, len
);
1571 case GFC_DTYPE_COMPLEX
:
1572 no_leading_blank
= 0;
1574 write_complex (p
, len
);
1577 case GFC_DTYPE_DERIVED
:
1579 /* To treat a derived type, we need to build two strings:
1580 ext_name = the name, including qualifiers that prepends
1581 component names in the output - passed to
1583 obj_name = the derived type name with no qualifiers but %
1584 appended. This is used to identify the
1587 /* First ext_name => get length of all possible components */
1589 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1590 + (base
? strlen (base
->var_name
) : 0)
1591 + strlen (obj
->var_name
)
1592 + obj
->var_rank
* NML_DIGITS
1595 strcpy(ext_name
, base_name
? base_name
: "");
1596 clen
= base
? strlen (base
->var_name
) : 0;
1597 strcat (ext_name
, obj
->var_name
+ clen
);
1599 /* Append the qualifier. */
1601 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1603 strcat (ext_name
, dim_i
? "" : "(");
1604 clen
= strlen (ext_name
);
1605 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1606 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1611 obj_name_len
= strlen (obj
->var_name
) + 1;
1612 obj_name
= get_mem (obj_name_len
+1);
1613 strcpy (obj_name
, obj
->var_name
);
1614 strcat (obj_name
, "%");
1616 /* Now loop over the components. Update the component pointer
1617 with the return value from nml_write_obj => this loop jumps
1618 past nested derived types. */
1620 for (cmp
= obj
->next
;
1621 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1624 retval
= nml_write_obj (cmp
, (index_type
)(p
- obj
->mem_pos
),
1628 free_mem (obj_name
);
1629 free_mem (ext_name
);
1633 internal_error ("Bad type for namelist write");
1636 /* Reset the leading blank suppression, write a comma and, if 5
1637 values have been output, write a newline and advance to column
1638 2. Reset the repeat counter. */
1640 no_leading_blank
= 0;
1641 write_character (",", 1);
1645 write_character ("\n ", 2);
1650 /* Cycle through and increment the index vector. */
1655 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1657 obj
->ls
[dim_i
].idx
+= nml_carry
;
1659 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1661 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1667 /* Return a pointer beyond the furthest object accessed. */
1672 /* This is the entry function for namelist writes. It outputs the name
1673 of the namelist and iterates through the namelist by calls to
1674 nml_write_obj. The call below has dummys in the arguments used in
1675 the treatment of derived types. */
1678 namelist_write (void)
1680 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1682 index_type dummy_offset
= 0;
1684 char * dummy_name
= NULL
;
1685 unit_delim tmp_delim
;
1687 /* Set the delimiter for namelist output. */
1689 tmp_delim
= current_unit
->flags
.delim
;
1690 current_unit
->flags
.delim
= DELIM_NONE
;
1697 case (DELIM_APOSTROPHE
):
1705 write_character ("&",1);
1707 /* Write namelist name in upper case - f95 std. */
1709 for (i
= 0 ;i
< ioparm
.namelist_name_len
;i
++ )
1711 c
= toupper (ioparm
.namelist_name
[i
]);
1712 write_character (&c
,1);
1721 t1
= nml_write_obj (t2
, dummy_offset
, dummy
, dummy_name
);
1724 write_character (" /\n", 4);
1726 /* Recover the original delimiter. */
1728 current_unit
->flags
.delim
= tmp_delim
;