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, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, 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;
84 memcpy ((void *) &tmp
, p
, len
);
91 memcpy ((void *) &tmp
, p
, len
);
98 memcpy ((void *) &tmp
, p
, len
);
105 memcpy ((void *) &tmp
, p
, len
);
109 #ifdef HAVE_GFC_INTEGER_16
113 memcpy ((void *) &tmp
, p
, len
);
119 internal_error ("bad integer kind");
125 static GFC_UINTEGER_LARGEST
126 extract_uint (const void *p
, int len
)
128 GFC_UINTEGER_LARGEST i
= 0;
138 memcpy ((void *) &tmp
, p
, len
);
139 i
= (GFC_UINTEGER_1
) tmp
;
145 memcpy ((void *) &tmp
, p
, len
);
146 i
= (GFC_UINTEGER_2
) tmp
;
152 memcpy ((void *) &tmp
, p
, len
);
153 i
= (GFC_UINTEGER_4
) tmp
;
159 memcpy ((void *) &tmp
, p
, len
);
160 i
= (GFC_UINTEGER_8
) tmp
;
163 #ifdef HAVE_GFC_INTEGER_16
167 memcpy ((void *) &tmp
, p
, len
);
168 i
= (GFC_UINTEGER_16
) tmp
;
173 internal_error ("bad integer kind");
179 static GFC_REAL_LARGEST
180 extract_real (const void *p
, int len
)
182 GFC_REAL_LARGEST i
= 0;
188 memcpy ((void *) &tmp
, p
, len
);
195 memcpy ((void *) &tmp
, p
, len
);
199 #ifdef HAVE_GFC_REAL_10
203 memcpy ((void *) &tmp
, p
, len
);
208 #ifdef HAVE_GFC_REAL_16
212 memcpy ((void *) &tmp
, p
, len
);
218 internal_error ("bad real kind");
224 /* Given a flag that indicate if a value is negative or not, return a
225 sign_t that gives the sign that we need to produce. */
228 calculate_sign (int negative_flag
)
230 sign_t s
= SIGN_NONE
;
235 switch (g
.sign_status
)
244 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
252 /* Returns the value of 10**d. */
254 static GFC_REAL_LARGEST
255 calculate_exp (int d
)
258 GFC_REAL_LARGEST r
= 1.0;
260 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
263 r
= (d
>= 0) ? r
: 1.0 / r
;
269 /* Generate corresponding I/O format for FMT_G output.
270 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
271 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
273 Data Magnitude Equivalent Conversion
274 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
275 m = 0 F(w-n).(d-1), n' '
276 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
277 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
278 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
279 ................ ..........
280 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
281 m >= 10**d-0.5 Ew.d[Ee]
283 notes: for Gw.d , n' ' means 4 blanks
284 for Gw.dEe, n' ' means e+2 blanks */
287 calculate_G_format (fnode
*f
, GFC_REAL_LARGEST value
, int *num_blank
)
293 GFC_REAL_LARGEST m
, exp_d
;
297 newf
= get_mem (sizeof (fnode
));
299 /* Absolute value. */
300 m
= (value
> 0.0) ? value
: -value
;
302 /* In case of the two data magnitude ranges,
303 generate E editing, Ew.d[Ee]. */
304 exp_d
= calculate_exp (d
);
305 if ((m
> 0.0 && m
< 0.1 - 0.05 / exp_d
) || (m
>= exp_d
- 0.5 ))
307 newf
->format
= FMT_E
;
315 /* Use binary search to find the data magnitude range. */
324 GFC_REAL_LARGEST temp
;
325 mid
= (low
+ high
) / 2;
327 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
328 temp
= 0.1 * calculate_exp (mid
) - 0.5 * calculate_exp (mid
- d
- 1);
333 if (ubound
== lbound
+ 1)
340 if (ubound
== lbound
+ 1)
351 /* Pad with blanks where the exponent would be. */
357 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
358 newf
->format
= FMT_F
;
359 newf
->u
.real
.w
= f
->u
.real
.w
- *num_blank
;
363 newf
->u
.real
.d
= d
- 1;
365 newf
->u
.real
.d
= - (mid
- d
- 1);
367 /* For F editing, the scale factor is ignored. */
373 /* Output a real number according to its format which is FMT_G free. */
376 output_float (fnode
*f
, GFC_REAL_LARGEST value
)
378 /* This must be large enough to accurately hold any value. */
389 /* Number of digits before the decimal point. */
391 /* Number of zeros after the decimal point. */
393 /* Number of digits after the decimal point. */
395 /* Number of zeros after the decimal point, whatever the precision. */
410 /* We should always know the field width and precision. */
412 internal_error ("Unspecified precision");
414 /* Use sprintf to print the number in the format +D.DDDDe+ddd
415 For an N digit exponent, this gives us (32-6)-N digits after the
416 decimal point, plus another one before the decimal point. */
417 sign
= calculate_sign (value
< 0.0);
421 /* Printf always prints at least two exponent digits. */
426 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
427 abslog
= fabs((double) log10l(value
));
429 abslog
= fabs(log10(value
));
434 edigits
= 1 + (int) log10(abslog
);
437 if (ft
== FMT_F
|| ft
== FMT_EN
438 || ((ft
== FMT_D
|| ft
== FMT_E
) && g
.scale_factor
!= 0))
440 /* Always convert at full precision to avoid double rounding. */
441 ndigits
= 27 - edigits
;
445 /* We know the number of digits, so can let printf do the rounding
451 if (ndigits
> 27 - edigits
)
452 ndigits
= 27 - edigits
;
455 /* # The result will always contain a decimal point, even if no
458 * - The converted value is to be left adjusted on the field boundary
460 * + A sign (+ or -) always be placed before a number
462 * 31 minimum field width
464 * * (ndigits-1) is used as the precision
466 * e format: [-]d.ddde±dd where there is one digit before the
467 * decimal-point character and the number of digits after it is
468 * equal to the precision. The exponent always contains at least two
469 * digits; if the value is zero, the exponent is 00.
471 sprintf (buffer
, "%+-#31.*" GFC_REAL_LARGEST_FORMAT
"e",
474 /* Check the resulting string has punctuation in the correct places. */
475 if (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e')
476 internal_error ("printf is broken");
478 /* Read the exponent back in. */
479 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
481 /* Make sure zero comes out as 0.0e0. */
485 /* Normalize the fractional component. */
486 buffer
[2] = buffer
[1];
489 /* Figure out where to place the decimal point. */
493 nbefore
= e
+ g
.scale_factor
;
526 nafter
= (d
- i
) + 1;
542 /* The exponent must be a multiple of three, with 1-3 digits before
543 the decimal point. */
552 nbefore
= 3 - nbefore
;
571 /* Should never happen. */
572 internal_error ("Unexpected format token");
575 /* Round the value. */
576 if (nbefore
+ nafter
== 0)
579 if (nzero_real
== d
&& digits
[0] >= '5')
581 /* We rounded to zero but shouldn't have */
588 else if (nbefore
+ nafter
< ndigits
)
590 ndigits
= nbefore
+ nafter
;
592 if (digits
[i
] >= '5')
594 /* Propagate the carry. */
595 for (i
--; i
>= 0; i
--)
597 if (digits
[i
] != '9')
607 /* The carry overflowed. Fortunately we have some spare space
608 at the start of the buffer. We may discard some digits, but
609 this is ok because we already know they are zero. */
622 else if (ft
== FMT_EN
)
637 /* Calculate the format of the exponent field. */
641 for (i
= abs (e
); i
>= 10; i
/= 10)
646 /* Width not specified. Must be no more than 3 digits. */
647 if (e
> 999 || e
< -999)
652 if (e
> 99 || e
< -99)
658 /* Exponent width specified, check it is wide enough. */
659 if (edigits
> f
->u
.real
.e
)
662 edigits
= f
->u
.real
.e
+ 2;
668 /* Pick a field size if none was specified. */
670 w
= nbefore
+ nzero
+ nafter
+ (sign
!= SIGN_NONE
? 2 : 1);
672 /* Create the ouput buffer. */
673 out
= write_block (w
);
677 /* Zero values always output as positive, even if the value was negative
679 for (i
= 0; i
< ndigits
; i
++)
681 if (digits
[i
] != '0')
685 sign
= calculate_sign (0);
687 /* Work out how much padding is needed. */
688 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
689 if (sign
!= SIGN_NONE
)
692 /* Check the value fits in the specified field width. */
693 if (nblanks
< 0 || edigits
== -1)
699 /* See if we have space for a zero before the decimal point. */
700 if (nbefore
== 0 && nblanks
> 0)
708 /* Pad to full field width. */
711 if ( ( nblanks
> 0 ) && !no_leading_blank
)
713 memset (out
, ' ', nblanks
);
717 /* Output the initial sign (if any). */
718 if (sign
== SIGN_PLUS
)
720 else if (sign
== SIGN_MINUS
)
723 /* Output an optional leading zero. */
727 /* Output the part before the decimal point, padding with zeros. */
730 if (nbefore
> ndigits
)
735 memcpy (out
, digits
, i
);
743 /* Output the decimal point. */
746 /* Output leading zeros after the decimal point. */
749 for (i
= 0; i
< nzero
; i
++)
753 /* Output digits after the decimal point, padding with zeros. */
756 if (nafter
> ndigits
)
761 memcpy (out
, digits
, i
);
770 /* Output the exponent. */
779 snprintf (buffer
, 32, "%+0*d", edigits
, e
);
781 sprintf (buffer
, "%+0*d", edigits
, e
);
783 memcpy (out
, buffer
, edigits
);
786 if ( no_leading_blank
)
789 memset( out
, ' ' , nblanks
);
790 no_leading_blank
= 0;
796 write_l (fnode
* f
, char *source
, int len
)
799 GFC_INTEGER_LARGEST n
;
801 p
= write_block (f
->u
.w
);
805 memset (p
, ' ', f
->u
.w
- 1);
806 n
= extract_int (source
, len
);
807 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
810 /* Output a real number according to its format. */
813 write_float (fnode
*f
, const char *source
, int len
)
816 int nb
=0, res
, save_scale_factor
;
820 n
= extract_real (source
, len
);
822 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
829 /* If the field width is zero, the processor must select a width
830 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
833 p
= write_block (nb
);
847 /* If the sign is negative and the width is 3, there is
848 insufficient room to output '-Inf', so output asterisks */
856 /* The negative sign is mandatory */
862 /* The positive sign is optional, but we output it for
869 /* We have room, so output 'Infinity' */
871 memcpy(p
+ nb
- 8, "Infinity", 8);
874 /* For the case of width equals 8, there is not enough room
875 for the sign and 'Infinity' so we go with 'Inf' */
877 memcpy(p
+ nb
- 3, "Inf", 3);
878 if (nb
< 9 && nb
> 3)
879 p
[nb
- 4] = fin
; /* Put the sign in front of Inf */
881 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity */
884 memcpy(p
+ nb
- 3, "NaN", 3);
889 if (f
->format
!= FMT_G
)
895 save_scale_factor
= g
.scale_factor
;
896 f2
= calculate_G_format(f
, n
, &nb
);
897 output_float (f2
, n
);
898 g
.scale_factor
= save_scale_factor
;
904 p
= write_block (nb
);
912 write_int (fnode
*f
, const char *source
, int len
,
913 char *(*conv
) (GFC_UINTEGER_LARGEST
))
915 GFC_UINTEGER_LARGEST n
= 0;
916 int w
, m
, digits
, nzero
, nblank
;
922 n
= extract_uint (source
, len
);
926 if (m
== 0 && n
== 0)
942 /* Select a width if none was specified. The idea here is to always
946 w
= ((digits
< m
) ? m
: digits
);
956 /* See if things will work. */
958 nblank
= w
- (nzero
+ digits
);
967 if (!no_leading_blank
)
969 memset (p
, ' ', nblank
);
971 memset (p
, '0', nzero
);
973 memcpy (p
, q
, digits
);
977 memset (p
, '0', nzero
);
979 memcpy (p
, q
, digits
);
981 memset (p
, ' ', nblank
);
982 no_leading_blank
= 0;
990 write_decimal (fnode
*f
, const char *source
, int len
,
991 char *(*conv
) (GFC_INTEGER_LARGEST
))
993 GFC_INTEGER_LARGEST n
= 0;
994 int w
, m
, digits
, nsign
, nzero
, nblank
;
1001 n
= extract_int (source
, len
);
1005 if (m
== 0 && n
== 0)
1010 p
= write_block (w
);
1018 sign
= calculate_sign (n
< 0);
1022 nsign
= sign
== SIGN_NONE
? 0 : 1;
1025 digits
= strlen (q
);
1027 /* Select a width if none was specified. The idea here is to always
1031 w
= ((digits
< m
) ? m
: digits
) + nsign
;
1033 p
= write_block (w
);
1041 /* See if things will work. */
1043 nblank
= w
- (nsign
+ nzero
+ digits
);
1051 memset (p
, ' ', nblank
);
1066 memset (p
, '0', nzero
);
1069 memcpy (p
, q
, digits
);
1076 /* Convert unsigned octal to ascii. */
1079 otoa (GFC_UINTEGER_LARGEST n
)
1090 p
= scratch
+ SCRATCH_SIZE
- 1;
1104 /* Convert unsigned binary to ascii. */
1107 btoa (GFC_UINTEGER_LARGEST n
)
1118 p
= scratch
+ SCRATCH_SIZE
- 1;
1123 *p
-- = '0' + (n
& 1);
1132 write_i (fnode
* f
, const char *p
, int len
)
1134 write_decimal (f
, p
, len
, (void *) gfc_itoa
);
1139 write_b (fnode
* f
, const char *p
, int len
)
1141 write_int (f
, p
, len
, btoa
);
1146 write_o (fnode
* f
, const char *p
, int len
)
1148 write_int (f
, p
, len
, otoa
);
1152 write_z (fnode
* f
, const char *p
, int len
)
1154 write_int (f
, p
, len
, xtoa
);
1159 write_d (fnode
*f
, const char *p
, int len
)
1161 write_float (f
, p
, len
);
1166 write_e (fnode
*f
, const char *p
, int len
)
1168 write_float (f
, p
, len
);
1173 write_f (fnode
*f
, const char *p
, int len
)
1175 write_float (f
, p
, len
);
1180 write_en (fnode
*f
, const char *p
, int len
)
1182 write_float (f
, p
, len
);
1187 write_es (fnode
*f
, const char *p
, int len
)
1189 write_float (f
, p
, len
);
1193 /* Take care of the X/TR descriptor. */
1196 write_x (int len
, int nspaces
)
1200 p
= write_block (len
);
1205 memset (&p
[len
- nspaces
], ' ', nspaces
);
1209 /* List-directed writing. */
1212 /* Write a single character to the output. Returns nonzero if
1213 something goes wrong. */
1220 p
= write_block (1);
1230 /* Write a list-directed logical value. */
1233 write_logical (const char *source
, int length
)
1235 write_char (extract_int (source
, length
) ? 'T' : 'F');
1239 /* Write a list-directed integer value. */
1242 write_integer (const char *source
, int length
)
1249 q
= gfc_itoa (extract_int (source
, length
));
1274 digits
= strlen (q
);
1278 p
= write_block (width
) ;
1279 if (no_leading_blank
)
1281 memcpy (p
, q
, digits
);
1282 memset(p
+ digits
,' ', width
- digits
) ;
1286 memset(p
,' ', width
- digits
) ;
1287 memcpy (p
+ width
- digits
, q
, digits
);
1292 /* Write a list-directed string. We have to worry about delimiting
1293 the strings if the file has been opened in that mode. */
1296 write_character (const char *source
, int length
)
1301 switch (current_unit
->flags
.delim
)
1303 case DELIM_APOSTROPHE
:
1320 for (i
= 0; i
< length
; i
++)
1325 p
= write_block (length
+ extra
);
1330 memcpy (p
, source
, length
);
1335 for (i
= 0; i
< length
; i
++)
1347 /* Output a real number with default format.
1348 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1349 1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
1352 write_real (const char *source
, int length
)
1355 int org_scale
= g
.scale_factor
;
1381 internal_error ("bad real kind");
1384 write_float (&f
, source
, length
);
1385 g
.scale_factor
= org_scale
;
1390 write_complex (const char *source
, int len
)
1392 if (write_char ('('))
1394 write_real (source
, len
);
1396 if (write_char (','))
1398 write_real (source
+ len
, len
);
1404 /* Write the separator between items. */
1407 write_separator (void)
1411 p
= write_block (options
.separator_len
);
1415 memcpy (p
, options
.separator
, options
.separator_len
);
1419 /* Write an item with list formatting.
1420 TODO: handle skipping to the next record correctly, particularly
1424 list_formatted_write_scalar (bt type
, void *p
, int len
)
1426 static int char_flag
;
1428 if (current_unit
== NULL
)
1439 if (type
!= BT_CHARACTER
|| !char_flag
||
1440 current_unit
->flags
.delim
!= DELIM_NONE
)
1447 write_integer (p
, len
);
1450 write_logical (p
, len
);
1453 write_character (p
, len
);
1456 write_real (p
, len
);
1459 write_complex (p
, len
);
1462 internal_error ("list_formatted_write(): Bad type");
1465 char_flag
= (type
== BT_CHARACTER
);
1470 list_formatted_write (bt type
, void *p
, int len
, size_t nelems
)
1478 if (type
== BT_COMPLEX
)
1483 /* Big loop over all the elements. */
1484 for (elem
= 0; elem
< nelems
; elem
++)
1487 list_formatted_write_scalar (type
, tmp
+ size
*elem
, len
);
1493 nml_write_obj writes a namelist object to the output stream. It is called
1494 recursively for derived type components:
1495 obj = is the namelist_info for the current object.
1496 offset = the offset relative to the address held by the object for
1497 derived type arrays.
1498 base = is the namelist_info of the derived type, when obj is a
1500 base_name = the full name for a derived type, including qualifiers
1502 The returned value is a pointer to the object beyond the last one
1503 accessed, including nested derived types. Notice that the namelist is
1504 a linear linked list of objects, including derived types and their
1505 components. A tree, of sorts, is implied by the compound names of
1506 the derived type components and this is how this function recurses through
1509 /* A generous estimate of the number of characters needed to print
1510 repeat counts and indices, including commas, asterices and brackets. */
1512 #define NML_DIGITS 20
1514 /* Stores the delimiter to be used for character objects. */
1516 static const char * nml_delim
;
1518 static namelist_info
*
1519 nml_write_obj (namelist_info
* obj
, index_type offset
,
1520 namelist_info
* base
, char * base_name
)
1526 index_type obj_size
;
1530 index_type elem_ctr
;
1531 index_type obj_name_len
;
1536 char rep_buff
[NML_DIGITS
];
1537 namelist_info
* cmp
;
1538 namelist_info
* retval
= obj
->next
;
1540 /* Write namelist variable names in upper case. If a derived type,
1541 nothing is output. If a component, base and base_name are set. */
1543 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1545 write_character ("\n ", 2);
1549 len
=strlen (base
->var_name
);
1550 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1552 cup
= toupper (base_name
[dim_i
]);
1553 write_character (&cup
, 1);
1556 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1558 cup
= toupper (obj
->var_name
[dim_i
]);
1559 write_character (&cup
, 1);
1561 write_character ("=", 1);
1564 /* Counts the number of data output on a line, including names. */
1570 if (obj
->type
== GFC_DTYPE_COMPLEX
)
1572 if (obj
->type
== GFC_DTYPE_CHARACTER
)
1573 obj_size
= obj
->string_length
;
1575 obj_size
= obj
->size
;
1577 /* Set the index vector and count the number of elements. */
1580 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1582 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1583 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1586 /* Main loop to output the data held in the object. */
1589 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1592 /* Build the pointer to the data value. The offset is passed by
1593 recursive calls to this function for arrays of derived types.
1594 Is NULL otherwise. */
1596 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1599 /* Check for repeat counts of intrinsic types. */
1601 if ((elem_ctr
< (nelem
- 1)) &&
1602 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1603 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1608 /* Execute a repeated output. Note the flag no_leading_blank that
1609 is used in the functions used to output the intrinsic types. */
1615 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1616 write_character (rep_buff
, strlen (rep_buff
));
1617 no_leading_blank
= 1;
1621 /* Output the data, if an intrinsic type, or recurse into this
1622 routine to treat derived types. */
1627 case GFC_DTYPE_INTEGER
:
1628 write_integer (p
, len
);
1631 case GFC_DTYPE_LOGICAL
:
1632 write_logical (p
, len
);
1635 case GFC_DTYPE_CHARACTER
:
1637 write_character (nml_delim
, 1);
1638 write_character (p
, obj
->string_length
);
1640 write_character (nml_delim
, 1);
1643 case GFC_DTYPE_REAL
:
1644 write_real (p
, len
);
1647 case GFC_DTYPE_COMPLEX
:
1648 no_leading_blank
= 0;
1650 write_complex (p
, len
);
1653 case GFC_DTYPE_DERIVED
:
1655 /* To treat a derived type, we need to build two strings:
1656 ext_name = the name, including qualifiers that prepends
1657 component names in the output - passed to
1659 obj_name = the derived type name with no qualifiers but %
1660 appended. This is used to identify the
1663 /* First ext_name => get length of all possible components */
1665 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1666 + (base
? strlen (base
->var_name
) : 0)
1667 + strlen (obj
->var_name
)
1668 + obj
->var_rank
* NML_DIGITS
1671 strcpy(ext_name
, base_name
? base_name
: "");
1672 clen
= base
? strlen (base
->var_name
) : 0;
1673 strcat (ext_name
, obj
->var_name
+ clen
);
1675 /* Append the qualifier. */
1677 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1679 strcat (ext_name
, dim_i
? "" : "(");
1680 clen
= strlen (ext_name
);
1681 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1682 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1687 obj_name_len
= strlen (obj
->var_name
) + 1;
1688 obj_name
= get_mem (obj_name_len
+1);
1689 strcpy (obj_name
, obj
->var_name
);
1690 strcat (obj_name
, "%");
1692 /* Now loop over the components. Update the component pointer
1693 with the return value from nml_write_obj => this loop jumps
1694 past nested derived types. */
1696 for (cmp
= obj
->next
;
1697 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1700 retval
= nml_write_obj (cmp
, (index_type
)(p
- obj
->mem_pos
),
1704 free_mem (obj_name
);
1705 free_mem (ext_name
);
1709 internal_error ("Bad type for namelist write");
1712 /* Reset the leading blank suppression, write a comma and, if 5
1713 values have been output, write a newline and advance to column
1714 2. Reset the repeat counter. */
1716 no_leading_blank
= 0;
1717 write_character (",", 1);
1721 write_character ("\n ", 2);
1726 /* Cycle through and increment the index vector. */
1731 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1733 obj
->ls
[dim_i
].idx
+= nml_carry
;
1735 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1737 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1743 /* Return a pointer beyond the furthest object accessed. */
1748 /* This is the entry function for namelist writes. It outputs the name
1749 of the namelist and iterates through the namelist by calls to
1750 nml_write_obj. The call below has dummys in the arguments used in
1751 the treatment of derived types. */
1754 namelist_write (void)
1756 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1758 index_type dummy_offset
= 0;
1760 char * dummy_name
= NULL
;
1761 unit_delim tmp_delim
;
1763 /* Set the delimiter for namelist output. */
1765 tmp_delim
= current_unit
->flags
.delim
;
1766 current_unit
->flags
.delim
= DELIM_NONE
;
1773 case (DELIM_APOSTROPHE
):
1781 write_character ("&",1);
1783 /* Write namelist name in upper case - f95 std. */
1785 for (i
= 0 ;i
< ioparm
.namelist_name_len
;i
++ )
1787 c
= toupper (ioparm
.namelist_name
[i
]);
1788 write_character (&c
,1);
1797 t1
= nml_write_obj (t2
, dummy_offset
, dummy
, dummy_name
);
1800 write_character (" /\n", 4);
1802 /* Recover the original delimiter. */
1804 current_unit
->flags
.delim
= tmp_delim
;