1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist output contributed 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. */
38 #include "libgfortran.h"
41 #define star_fill(p, n) memset(p, '*', n)
45 { SIGN_NONE
, SIGN_MINUS
, SIGN_PLUS
}
50 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
55 wlen
= f
->u
.string
.length
< 0 ? len
: f
->u
.string
.length
;
57 p
= write_block (dtp
, wlen
);
62 memcpy (p
, source
, wlen
);
65 memset (p
, ' ', wlen
- len
);
66 memcpy (p
+ wlen
- len
, source
, len
);
70 static GFC_INTEGER_LARGEST
71 extract_int (const void *p
, int len
)
73 GFC_INTEGER_LARGEST i
= 0;
83 memcpy ((void *) &tmp
, p
, len
);
90 memcpy ((void *) &tmp
, p
, len
);
97 memcpy ((void *) &tmp
, p
, len
);
104 memcpy ((void *) &tmp
, p
, len
);
108 #ifdef HAVE_GFC_INTEGER_16
112 memcpy ((void *) &tmp
, p
, len
);
118 internal_error (NULL
, "bad integer kind");
124 static GFC_UINTEGER_LARGEST
125 extract_uint (const void *p
, int len
)
127 GFC_UINTEGER_LARGEST i
= 0;
137 memcpy ((void *) &tmp
, p
, len
);
138 i
= (GFC_UINTEGER_1
) tmp
;
144 memcpy ((void *) &tmp
, p
, len
);
145 i
= (GFC_UINTEGER_2
) tmp
;
151 memcpy ((void *) &tmp
, p
, len
);
152 i
= (GFC_UINTEGER_4
) tmp
;
158 memcpy ((void *) &tmp
, p
, len
);
159 i
= (GFC_UINTEGER_8
) tmp
;
162 #ifdef HAVE_GFC_INTEGER_16
166 memcpy ((void *) &tmp
, p
, len
);
167 i
= (GFC_UINTEGER_16
) tmp
;
172 internal_error (NULL
, "bad integer kind");
178 static GFC_REAL_LARGEST
179 extract_real (const void *p
, int len
)
181 GFC_REAL_LARGEST i
= 0;
187 memcpy ((void *) &tmp
, p
, len
);
194 memcpy ((void *) &tmp
, p
, len
);
198 #ifdef HAVE_GFC_REAL_10
202 memcpy ((void *) &tmp
, p
, len
);
207 #ifdef HAVE_GFC_REAL_16
211 memcpy ((void *) &tmp
, p
, len
);
217 internal_error (NULL
, "bad real kind");
223 /* Given a flag that indicate if a value is negative or not, return a
224 sign_t that gives the sign that we need to produce. */
227 calculate_sign (st_parameter_dt
*dtp
, int negative_flag
)
229 sign_t s
= SIGN_NONE
;
234 switch (dtp
->u
.p
.sign_status
)
243 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
251 /* Returns the value of 10**d. */
253 static GFC_REAL_LARGEST
254 calculate_exp (int d
)
257 GFC_REAL_LARGEST r
= 1.0;
259 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
262 r
= (d
>= 0) ? r
: 1.0 / r
;
268 /* Generate corresponding I/O format for FMT_G output.
269 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
270 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
272 Data Magnitude Equivalent Conversion
273 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
274 m = 0 F(w-n).(d-1), n' '
275 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
276 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
277 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
278 ................ ..........
279 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
280 m >= 10**d-0.5 Ew.d[Ee]
282 notes: for Gw.d , n' ' means 4 blanks
283 for Gw.dEe, n' ' means e+2 blanks */
286 calculate_G_format (st_parameter_dt
*dtp
, const fnode
*f
,
287 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 ) ||
306 ((m
== 0.0) && !(compile_options
.allow_std
& GFC_STD_F2003
)))
308 newf
->format
= FMT_E
;
316 /* Use binary search to find the data magnitude range. */
325 GFC_REAL_LARGEST temp
;
326 mid
= (low
+ high
) / 2;
328 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
329 temp
= 0.1 * calculate_exp (mid
) - 0.5 * calculate_exp (mid
- d
- 1);
334 if (ubound
== lbound
+ 1)
341 if (ubound
== lbound
+ 1)
352 /* Pad with blanks where the exponent would be. */
358 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
359 newf
->format
= FMT_F
;
360 newf
->u
.real
.w
= f
->u
.real
.w
- *num_blank
;
364 newf
->u
.real
.d
= d
- 1;
366 newf
->u
.real
.d
= - (mid
- d
- 1);
368 /* For F editing, the scale factor is ignored. */
369 dtp
->u
.p
.scale_factor
= 0;
374 /* Output a real number according to its format which is FMT_G free. */
377 output_float (st_parameter_dt
*dtp
, const fnode
*f
, GFC_REAL_LARGEST value
)
379 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
380 # define MIN_FIELD_WIDTH 46
382 # define MIN_FIELD_WIDTH 31
384 #define STR(x) STR1(x)
386 /* This must be large enough to accurately hold any value. */
387 char buffer
[MIN_FIELD_WIDTH
+1];
397 /* Number of digits before the decimal point. */
399 /* Number of zeros after the decimal point. */
401 /* Number of digits after the decimal point. */
403 /* Number of zeros after the decimal point, whatever the precision. */
418 /* We should always know the field width and precision. */
420 internal_error (&dtp
->common
, "Unspecified precision");
422 /* Use sprintf to print the number in the format +D.DDDDe+ddd
423 For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits
424 after the decimal point, plus another one before the decimal point. */
425 sign
= calculate_sign (dtp
, value
< 0.0);
429 /* Special case when format specifies no digits after the decimal point. */
434 else if (value
< 1.0)
438 /* Printf always prints at least two exponent digits. */
443 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
444 abslog
= fabs((double) log10l(value
));
446 abslog
= fabs(log10(value
));
451 edigits
= 1 + (int) log10(abslog
);
454 if (ft
== FMT_F
|| ft
== FMT_EN
455 || ((ft
== FMT_D
|| ft
== FMT_E
) && dtp
->u
.p
.scale_factor
!= 0))
457 /* Always convert at full precision to avoid double rounding. */
458 ndigits
= MIN_FIELD_WIDTH
- 4 - edigits
;
462 /* We know the number of digits, so can let printf do the rounding
468 if (ndigits
> MIN_FIELD_WIDTH
- 4 - edigits
)
469 ndigits
= MIN_FIELD_WIDTH
- 4 - edigits
;
472 /* # The result will always contain a decimal point, even if no
475 * - The converted value is to be left adjusted on the field boundary
477 * + A sign (+ or -) always be placed before a number
479 * MIN_FIELD_WIDTH minimum field width
481 * * (ndigits-1) is used as the precision
483 * e format: [-]d.ddde±dd where there is one digit before the
484 * decimal-point character and the number of digits after it is
485 * equal to the precision. The exponent always contains at least two
486 * digits; if the value is zero, the exponent is 00.
488 sprintf (buffer
, "%+-#" STR(MIN_FIELD_WIDTH
) ".*"
489 GFC_REAL_LARGEST_FORMAT
"e", ndigits
- 1, value
);
491 /* Check the resulting string has punctuation in the correct places. */
492 if (d
!= 0 && (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e'))
493 internal_error (&dtp
->common
, "printf is broken");
495 /* Read the exponent back in. */
496 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
498 /* Make sure zero comes out as 0.0e0. */
502 /* Normalize the fractional component. */
503 buffer
[2] = buffer
[1];
506 /* Figure out where to place the decimal point. */
510 nbefore
= e
+ dtp
->u
.p
.scale_factor
;
530 i
= dtp
->u
.p
.scale_factor
;
543 nafter
= (d
- i
) + 1;
559 /* The exponent must be a multiple of three, with 1-3 digits before
560 the decimal point. */
569 nbefore
= 3 - nbefore
;
588 /* Should never happen. */
589 internal_error (&dtp
->common
, "Unexpected format token");
592 /* Round the value. */
593 if (nbefore
+ nafter
== 0)
596 if (nzero_real
== d
&& digits
[0] >= '5')
598 /* We rounded to zero but shouldn't have */
605 else if (nbefore
+ nafter
< ndigits
)
607 ndigits
= nbefore
+ nafter
;
609 if (digits
[i
] >= '5')
611 /* Propagate the carry. */
612 for (i
--; i
>= 0; i
--)
614 if (digits
[i
] != '9')
624 /* The carry overflowed. Fortunately we have some spare space
625 at the start of the buffer. We may discard some digits, but
626 this is ok because we already know they are zero. */
639 else if (ft
== FMT_EN
)
654 /* Calculate the format of the exponent field. */
658 for (i
= abs (e
); i
>= 10; i
/= 10)
663 /* Width not specified. Must be no more than 3 digits. */
664 if (e
> 999 || e
< -999)
669 if (e
> 99 || e
< -99)
675 /* Exponent width specified, check it is wide enough. */
676 if (edigits
> f
->u
.real
.e
)
679 edigits
= f
->u
.real
.e
+ 2;
685 /* Pick a field size if none was specified. */
687 w
= nbefore
+ nzero
+ nafter
+ (sign
!= SIGN_NONE
? 2 : 1);
689 /* Create the ouput buffer. */
690 out
= write_block (dtp
, w
);
694 /* Zero values always output as positive, even if the value was negative
696 for (i
= 0; i
< ndigits
; i
++)
698 if (digits
[i
] != '0')
702 sign
= calculate_sign (dtp
, 0);
704 /* Work out how much padding is needed. */
705 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
706 if (sign
!= SIGN_NONE
)
709 /* Check the value fits in the specified field width. */
710 if (nblanks
< 0 || edigits
== -1)
716 /* See if we have space for a zero before the decimal point. */
717 if (nbefore
== 0 && nblanks
> 0)
725 /* Pad to full field width. */
728 if ( ( nblanks
> 0 ) && !dtp
->u
.p
.no_leading_blank
)
730 memset (out
, ' ', nblanks
);
734 /* Output the initial sign (if any). */
735 if (sign
== SIGN_PLUS
)
737 else if (sign
== SIGN_MINUS
)
740 /* Output an optional leading zero. */
744 /* Output the part before the decimal point, padding with zeros. */
747 if (nbefore
> ndigits
)
752 memcpy (out
, digits
, i
);
760 /* Output the decimal point. */
763 /* Output leading zeros after the decimal point. */
766 for (i
= 0; i
< nzero
; i
++)
770 /* Output digits after the decimal point, padding with zeros. */
773 if (nafter
> ndigits
)
778 memcpy (out
, digits
, i
);
787 /* Output the exponent. */
796 snprintf (buffer
, sizeof (buffer
), "%+0*d", edigits
, e
);
798 sprintf (buffer
, "%+0*d", edigits
, e
);
800 memcpy (out
, buffer
, edigits
);
803 if (dtp
->u
.p
.no_leading_blank
)
806 memset( out
, ' ' , nblanks
);
807 dtp
->u
.p
.no_leading_blank
= 0;
811 #undef MIN_FIELD_WIDTH
816 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
819 GFC_INTEGER_LARGEST n
;
821 p
= write_block (dtp
, f
->u
.w
);
825 memset (p
, ' ', f
->u
.w
- 1);
826 n
= extract_int (source
, len
);
827 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
830 /* Output a real number according to its format. */
833 write_float (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
836 int nb
=0, res
, save_scale_factor
;
840 n
= extract_real (source
, len
);
842 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
849 /* If the field width is zero, the processor must select a width
850 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
853 p
= write_block (dtp
, nb
);
869 /* If the sign is negative and the width is 3, there is
870 insufficient room to output '-Inf', so output asterisks */
878 /* The negative sign is mandatory */
884 /* The positive sign is optional, but we output it for
891 /* We have room, so output 'Infinity' */
893 memcpy(p
+ nb
- 8, "Infinity", 8);
896 /* For the case of width equals 8, there is not enough room
897 for the sign and 'Infinity' so we go with 'Inf' */
899 memcpy(p
+ nb
- 3, "Inf", 3);
900 if (nb
< 9 && nb
> 3)
901 p
[nb
- 4] = fin
; /* Put the sign in front of Inf */
903 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity */
906 memcpy(p
+ nb
- 3, "NaN", 3);
911 if (f
->format
!= FMT_G
)
912 output_float (dtp
, f
, n
);
915 save_scale_factor
= dtp
->u
.p
.scale_factor
;
916 f2
= calculate_G_format (dtp
, f
, n
, &nb
);
917 output_float (dtp
, f2
, n
);
918 dtp
->u
.p
.scale_factor
= save_scale_factor
;
924 p
= write_block (dtp
, nb
);
934 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
935 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
937 GFC_UINTEGER_LARGEST n
= 0;
938 int w
, m
, digits
, nzero
, nblank
;
941 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
946 n
= extract_uint (source
, len
);
950 if (m
== 0 && n
== 0)
955 p
= write_block (dtp
, w
);
963 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
966 /* Select a width if none was specified. The idea here is to always
970 w
= ((digits
< m
) ? m
: digits
);
972 p
= write_block (dtp
, w
);
980 /* See if things will work. */
982 nblank
= w
- (nzero
+ digits
);
991 if (!dtp
->u
.p
.no_leading_blank
)
993 memset (p
, ' ', nblank
);
995 memset (p
, '0', nzero
);
997 memcpy (p
, q
, digits
);
1001 memset (p
, '0', nzero
);
1003 memcpy (p
, q
, digits
);
1005 memset (p
, ' ', nblank
);
1006 dtp
->u
.p
.no_leading_blank
= 0;
1014 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
1016 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
1018 GFC_INTEGER_LARGEST n
= 0;
1019 int w
, m
, digits
, nsign
, nzero
, nblank
;
1023 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1028 n
= extract_int (source
, len
);
1032 if (m
== 0 && n
== 0)
1037 p
= write_block (dtp
, w
);
1045 sign
= calculate_sign (dtp
, n
< 0);
1049 nsign
= sign
== SIGN_NONE
? 0 : 1;
1050 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
1052 digits
= strlen (q
);
1054 /* Select a width if none was specified. The idea here is to always
1058 w
= ((digits
< m
) ? m
: digits
) + nsign
;
1060 p
= write_block (dtp
, w
);
1068 /* See if things will work. */
1070 nblank
= w
- (nsign
+ nzero
+ digits
);
1078 memset (p
, ' ', nblank
);
1093 memset (p
, '0', nzero
);
1096 memcpy (p
, q
, digits
);
1103 /* Convert unsigned octal to ascii. */
1106 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1110 assert (len
>= GFC_OTOA_BUF_SIZE
);
1115 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1120 *--p
= '0' + (n
& 7);
1128 /* Convert unsigned binary to ascii. */
1131 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1135 assert (len
>= GFC_BTOA_BUF_SIZE
);
1140 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
1145 *--p
= '0' + (n
& 1);
1154 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1156 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1161 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1163 write_int (dtp
, f
, p
, len
, btoa
);
1168 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1170 write_int (dtp
, f
, p
, len
, otoa
);
1174 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1176 write_int (dtp
, f
, p
, len
, xtoa
);
1181 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1183 write_float (dtp
, f
, p
, len
);
1188 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1190 write_float (dtp
, f
, p
, len
);
1195 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1197 write_float (dtp
, f
, p
, len
);
1202 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1204 write_float (dtp
, f
, p
, len
);
1209 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1211 write_float (dtp
, f
, p
, len
);
1215 /* Take care of the X/TR descriptor. */
1218 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1222 p
= write_block (dtp
, len
);
1227 memset (&p
[len
- nspaces
], ' ', nspaces
);
1231 /* List-directed writing. */
1234 /* Write a single character to the output. Returns nonzero if
1235 something goes wrong. */
1238 write_char (st_parameter_dt
*dtp
, char c
)
1242 p
= write_block (dtp
, 1);
1252 /* Write a list-directed logical value. */
1255 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1257 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1261 /* Write a list-directed integer value. */
1264 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1270 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1272 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1297 digits
= strlen (q
);
1301 p
= write_block (dtp
, width
);
1304 if (dtp
->u
.p
.no_leading_blank
)
1306 memcpy (p
, q
, digits
);
1307 memset (p
+ digits
, ' ', width
- digits
);
1311 memset (p
, ' ', width
- digits
);
1312 memcpy (p
+ width
- digits
, q
, digits
);
1317 /* Write a list-directed string. We have to worry about delimiting
1318 the strings if the file has been opened in that mode. */
1321 write_character (st_parameter_dt
*dtp
, const char *source
, int length
)
1326 switch (dtp
->u
.p
.current_unit
->flags
.delim
)
1328 case DELIM_APOSTROPHE
:
1345 for (i
= 0; i
< length
; i
++)
1350 p
= write_block (dtp
, length
+ extra
);
1355 memcpy (p
, source
, length
);
1360 for (i
= 0; i
< length
; i
++)
1372 /* Output a real number with default format.
1373 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1374 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
1377 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1380 int org_scale
= dtp
->u
.p
.scale_factor
;
1382 dtp
->u
.p
.scale_factor
= 1;
1406 internal_error (&dtp
->common
, "bad real kind");
1409 write_float (dtp
, &f
, source
, length
);
1410 dtp
->u
.p
.scale_factor
= org_scale
;
1415 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1417 if (write_char (dtp
, '('))
1419 write_real (dtp
, source
, kind
);
1421 if (write_char (dtp
, ','))
1423 write_real (dtp
, source
+ size
/ 2, kind
);
1425 write_char (dtp
, ')');
1429 /* Write the separator between items. */
1432 write_separator (st_parameter_dt
*dtp
)
1436 p
= write_block (dtp
, options
.separator_len
);
1440 memcpy (p
, options
.separator
, options
.separator_len
);
1444 /* Write an item with list formatting.
1445 TODO: handle skipping to the next record correctly, particularly
1449 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1452 if (dtp
->u
.p
.current_unit
== NULL
)
1455 if (dtp
->u
.p
.first_item
)
1457 dtp
->u
.p
.first_item
= 0;
1458 write_char (dtp
, ' ');
1462 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1463 dtp
->u
.p
.current_unit
->flags
.delim
!= DELIM_NONE
)
1464 write_separator (dtp
);
1470 write_integer (dtp
, p
, kind
);
1473 write_logical (dtp
, p
, kind
);
1476 write_character (dtp
, p
, kind
);
1479 write_real (dtp
, p
, kind
);
1482 write_complex (dtp
, p
, kind
, size
);
1485 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1488 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1493 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1494 size_t size
, size_t nelems
)
1501 /* Big loop over all the elements. */
1502 for (elem
= 0; elem
< nelems
; elem
++)
1504 dtp
->u
.p
.item_count
++;
1505 list_formatted_write_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1511 nml_write_obj writes a namelist object to the output stream. It is called
1512 recursively for derived type components:
1513 obj = is the namelist_info for the current object.
1514 offset = the offset relative to the address held by the object for
1515 derived type arrays.
1516 base = is the namelist_info of the derived type, when obj is a
1518 base_name = the full name for a derived type, including qualifiers
1520 The returned value is a pointer to the object beyond the last one
1521 accessed, including nested derived types. Notice that the namelist is
1522 a linear linked list of objects, including derived types and their
1523 components. A tree, of sorts, is implied by the compound names of
1524 the derived type components and this is how this function recurses through
1527 /* A generous estimate of the number of characters needed to print
1528 repeat counts and indices, including commas, asterices and brackets. */
1530 #define NML_DIGITS 20
1532 static namelist_info
*
1533 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1534 namelist_info
* base
, char * base_name
)
1540 index_type obj_size
;
1544 index_type elem_ctr
;
1545 index_type obj_name_len
;
1550 char rep_buff
[NML_DIGITS
];
1551 namelist_info
* cmp
;
1552 namelist_info
* retval
= obj
->next
;
1554 /* Write namelist variable names in upper case. If a derived type,
1555 nothing is output. If a component, base and base_name are set. */
1557 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1560 write_character (dtp
, "\r\n ", 3);
1562 write_character (dtp
, "\n ", 2);
1567 len
=strlen (base
->var_name
);
1568 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1570 cup
= toupper (base_name
[dim_i
]);
1571 write_character (dtp
, &cup
, 1);
1574 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1576 cup
= toupper (obj
->var_name
[dim_i
]);
1577 write_character (dtp
, &cup
, 1);
1579 write_character (dtp
, "=", 1);
1582 /* Counts the number of data output on a line, including names. */
1591 case GFC_DTYPE_REAL
:
1592 obj_size
= size_from_real_kind (len
);
1595 case GFC_DTYPE_COMPLEX
:
1596 obj_size
= size_from_complex_kind (len
);
1599 case GFC_DTYPE_CHARACTER
:
1600 obj_size
= obj
->string_length
;
1608 obj_size
= obj
->size
;
1610 /* Set the index vector and count the number of elements. */
1613 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1615 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1616 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1619 /* Main loop to output the data held in the object. */
1622 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1625 /* Build the pointer to the data value. The offset is passed by
1626 recursive calls to this function for arrays of derived types.
1627 Is NULL otherwise. */
1629 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1632 /* Check for repeat counts of intrinsic types. */
1634 if ((elem_ctr
< (nelem
- 1)) &&
1635 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1636 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1641 /* Execute a repeated output. Note the flag no_leading_blank that
1642 is used in the functions used to output the intrinsic types. */
1648 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1649 write_character (dtp
, rep_buff
, strlen (rep_buff
));
1650 dtp
->u
.p
.no_leading_blank
= 1;
1654 /* Output the data, if an intrinsic type, or recurse into this
1655 routine to treat derived types. */
1660 case GFC_DTYPE_INTEGER
:
1661 write_integer (dtp
, p
, len
);
1664 case GFC_DTYPE_LOGICAL
:
1665 write_logical (dtp
, p
, len
);
1668 case GFC_DTYPE_CHARACTER
:
1669 if (dtp
->u
.p
.nml_delim
)
1670 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1671 write_character (dtp
, p
, obj
->string_length
);
1672 if (dtp
->u
.p
.nml_delim
)
1673 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1676 case GFC_DTYPE_REAL
:
1677 write_real (dtp
, p
, len
);
1680 case GFC_DTYPE_COMPLEX
:
1681 dtp
->u
.p
.no_leading_blank
= 0;
1683 write_complex (dtp
, p
, len
, obj_size
);
1686 case GFC_DTYPE_DERIVED
:
1688 /* To treat a derived type, we need to build two strings:
1689 ext_name = the name, including qualifiers that prepends
1690 component names in the output - passed to
1692 obj_name = the derived type name with no qualifiers but %
1693 appended. This is used to identify the
1696 /* First ext_name => get length of all possible components */
1698 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1699 + (base
? strlen (base
->var_name
) : 0)
1700 + strlen (obj
->var_name
)
1701 + obj
->var_rank
* NML_DIGITS
1704 strcpy(ext_name
, base_name
? base_name
: "");
1705 clen
= base
? strlen (base
->var_name
) : 0;
1706 strcat (ext_name
, obj
->var_name
+ clen
);
1708 /* Append the qualifier. */
1710 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1712 strcat (ext_name
, dim_i
? "" : "(");
1713 clen
= strlen (ext_name
);
1714 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1715 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1720 obj_name_len
= strlen (obj
->var_name
) + 1;
1721 obj_name
= get_mem (obj_name_len
+1);
1722 strcpy (obj_name
, obj
->var_name
);
1723 strcat (obj_name
, "%");
1725 /* Now loop over the components. Update the component pointer
1726 with the return value from nml_write_obj => this loop jumps
1727 past nested derived types. */
1729 for (cmp
= obj
->next
;
1730 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1733 retval
= nml_write_obj (dtp
, cmp
,
1734 (index_type
)(p
- obj
->mem_pos
),
1738 free_mem (obj_name
);
1739 free_mem (ext_name
);
1743 internal_error (&dtp
->common
, "Bad type for namelist write");
1746 /* Reset the leading blank suppression, write a comma and, if 5
1747 values have been output, write a newline and advance to column
1748 2. Reset the repeat counter. */
1750 dtp
->u
.p
.no_leading_blank
= 0;
1751 write_character (dtp
, ",", 1);
1756 write_character (dtp
, "\r\n ", 3);
1758 write_character (dtp
, "\n ", 2);
1764 /* Cycle through and increment the index vector. */
1769 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1771 obj
->ls
[dim_i
].idx
+= nml_carry
;
1773 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1775 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1781 /* Return a pointer beyond the furthest object accessed. */
1786 /* This is the entry function for namelist writes. It outputs the name
1787 of the namelist and iterates through the namelist by calls to
1788 nml_write_obj. The call below has dummys in the arguments used in
1789 the treatment of derived types. */
1792 namelist_write (st_parameter_dt
*dtp
)
1794 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1796 index_type dummy_offset
= 0;
1798 char * dummy_name
= NULL
;
1799 unit_delim tmp_delim
;
1801 /* Set the delimiter for namelist output. */
1803 tmp_delim
= dtp
->u
.p
.current_unit
->flags
.delim
;
1804 dtp
->u
.p
.current_unit
->flags
.delim
= DELIM_NONE
;
1808 dtp
->u
.p
.nml_delim
= '"';
1811 case (DELIM_APOSTROPHE
):
1812 dtp
->u
.p
.nml_delim
= '\'';
1816 dtp
->u
.p
.nml_delim
= '\0';
1820 write_character (dtp
, "&", 1);
1822 /* Write namelist name in upper case - f95 std. */
1824 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1826 c
= toupper (dtp
->namelist_name
[i
]);
1827 write_character (dtp
, &c
,1);
1830 if (dtp
->u
.p
.ionml
!= NULL
)
1832 t1
= dtp
->u
.p
.ionml
;
1836 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1840 write_character (dtp
, " /\r\n", 5);
1842 write_character (dtp
, " /\n", 4);
1845 /* Recover the original delimiter. */
1847 dtp
->u
.p
.current_unit
->flags
.delim
= tmp_delim
;