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
;
58 /* If this is formatted STREAM IO convert any embedded line feed characters
59 to CR_LF on systems that use that sequence for newlines. See F2003
60 Standard sections 10.6.3 and 9.9 for further information. */
61 if (is_stream_io (dtp
))
63 const char crlf
[] = "\r\n";
67 /* Write out any padding if needed. */
70 p
= write_block (dtp
, wlen
- len
);
73 memset (p
, ' ', wlen
- len
);
76 /* Scan the source string looking for '\n' and convert it if found. */
77 for (i
= 0; i
< wlen
; i
++)
79 if (source
[i
] == '\n')
81 /* Write out the previously scanned characters in the string. */
84 p
= write_block (dtp
, bytes
);
87 memcpy (p
, &source
[q
], bytes
);
92 /* Write out the CR_LF sequence. */
94 p
= write_block (dtp
, 2);
103 /* Write out any remaining bytes if no LF was found. */
106 p
= write_block (dtp
, bytes
);
109 memcpy (p
, &source
[q
], bytes
);
115 p
= write_block (dtp
, wlen
);
120 memcpy (p
, source
, wlen
);
123 memset (p
, ' ', wlen
- len
);
124 memcpy (p
+ wlen
- len
, source
, len
);
131 static GFC_INTEGER_LARGEST
132 extract_int (const void *p
, int len
)
134 GFC_INTEGER_LARGEST i
= 0;
144 memcpy ((void *) &tmp
, p
, len
);
151 memcpy ((void *) &tmp
, p
, len
);
158 memcpy ((void *) &tmp
, p
, len
);
165 memcpy ((void *) &tmp
, p
, len
);
169 #ifdef HAVE_GFC_INTEGER_16
173 memcpy ((void *) &tmp
, p
, len
);
179 internal_error (NULL
, "bad integer kind");
185 static GFC_UINTEGER_LARGEST
186 extract_uint (const void *p
, int len
)
188 GFC_UINTEGER_LARGEST i
= 0;
198 memcpy ((void *) &tmp
, p
, len
);
199 i
= (GFC_UINTEGER_1
) tmp
;
205 memcpy ((void *) &tmp
, p
, len
);
206 i
= (GFC_UINTEGER_2
) tmp
;
212 memcpy ((void *) &tmp
, p
, len
);
213 i
= (GFC_UINTEGER_4
) tmp
;
219 memcpy ((void *) &tmp
, p
, len
);
220 i
= (GFC_UINTEGER_8
) tmp
;
223 #ifdef HAVE_GFC_INTEGER_16
227 memcpy ((void *) &tmp
, p
, len
);
228 i
= (GFC_UINTEGER_16
) tmp
;
233 internal_error (NULL
, "bad integer kind");
239 static GFC_REAL_LARGEST
240 extract_real (const void *p
, int len
)
242 GFC_REAL_LARGEST i
= 0;
248 memcpy ((void *) &tmp
, p
, len
);
255 memcpy ((void *) &tmp
, p
, len
);
259 #ifdef HAVE_GFC_REAL_10
263 memcpy ((void *) &tmp
, p
, len
);
268 #ifdef HAVE_GFC_REAL_16
272 memcpy ((void *) &tmp
, p
, len
);
278 internal_error (NULL
, "bad real kind");
284 /* Given a flag that indicate if a value is negative or not, return a
285 sign_t that gives the sign that we need to produce. */
288 calculate_sign (st_parameter_dt
*dtp
, int negative_flag
)
290 sign_t s
= SIGN_NONE
;
295 switch (dtp
->u
.p
.sign_status
)
304 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
312 /* Returns the value of 10**d. */
314 static GFC_REAL_LARGEST
315 calculate_exp (int d
)
318 GFC_REAL_LARGEST r
= 1.0;
320 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
323 r
= (d
>= 0) ? r
: 1.0 / r
;
329 /* Generate corresponding I/O format for FMT_G output.
330 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
331 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
333 Data Magnitude Equivalent Conversion
334 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
335 m = 0 F(w-n).(d-1), n' '
336 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
337 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
338 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
339 ................ ..........
340 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
341 m >= 10**d-0.5 Ew.d[Ee]
343 notes: for Gw.d , n' ' means 4 blanks
344 for Gw.dEe, n' ' means e+2 blanks */
347 calculate_G_format (st_parameter_dt
*dtp
, const fnode
*f
,
348 GFC_REAL_LARGEST value
, int *num_blank
)
354 GFC_REAL_LARGEST m
, exp_d
;
358 newf
= get_mem (sizeof (fnode
));
360 /* Absolute value. */
361 m
= (value
> 0.0) ? value
: -value
;
363 /* In case of the two data magnitude ranges,
364 generate E editing, Ew.d[Ee]. */
365 exp_d
= calculate_exp (d
);
366 if ((m
> 0.0 && m
< 0.1 - 0.05 / exp_d
) || (m
>= exp_d
- 0.5 ) ||
367 ((m
== 0.0) && !(compile_options
.allow_std
& GFC_STD_F2003
)))
369 newf
->format
= FMT_E
;
377 /* Use binary search to find the data magnitude range. */
386 GFC_REAL_LARGEST temp
;
387 mid
= (low
+ high
) / 2;
389 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
390 temp
= 0.1 * calculate_exp (mid
) - 0.5 * calculate_exp (mid
- d
- 1);
395 if (ubound
== lbound
+ 1)
402 if (ubound
== lbound
+ 1)
413 /* Pad with blanks where the exponent would be. */
419 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
420 newf
->format
= FMT_F
;
421 newf
->u
.real
.w
= f
->u
.real
.w
- *num_blank
;
425 newf
->u
.real
.d
= d
- 1;
427 newf
->u
.real
.d
= - (mid
- d
- 1);
429 /* For F editing, the scale factor is ignored. */
430 dtp
->u
.p
.scale_factor
= 0;
435 /* Output a real number according to its format which is FMT_G free. */
438 output_float (st_parameter_dt
*dtp
, const fnode
*f
, GFC_REAL_LARGEST value
)
440 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
441 # define MIN_FIELD_WIDTH 46
443 # define MIN_FIELD_WIDTH 31
445 #define STR(x) STR1(x)
447 /* This must be large enough to accurately hold any value. */
448 char buffer
[MIN_FIELD_WIDTH
+1];
458 /* Number of digits before the decimal point. */
460 /* Number of zeros after the decimal point. */
462 /* Number of digits after the decimal point. */
464 /* Number of zeros after the decimal point, whatever the precision. */
479 /* We should always know the field width and precision. */
481 internal_error (&dtp
->common
, "Unspecified precision");
483 /* Use sprintf to print the number in the format +D.DDDDe+ddd
484 For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits
485 after the decimal point, plus another one before the decimal point. */
486 sign
= calculate_sign (dtp
, value
< 0.0);
490 /* Special case when format specifies no digits after the decimal point. */
495 else if (value
< 1.0)
499 /* Printf always prints at least two exponent digits. */
504 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
505 abslog
= fabs((double) log10l(value
));
507 abslog
= fabs(log10(value
));
512 edigits
= 1 + (int) log10(abslog
);
515 if (ft
== FMT_F
|| ft
== FMT_EN
516 || ((ft
== FMT_D
|| ft
== FMT_E
) && dtp
->u
.p
.scale_factor
!= 0))
518 /* Always convert at full precision to avoid double rounding. */
519 ndigits
= MIN_FIELD_WIDTH
- 4 - edigits
;
523 /* We know the number of digits, so can let printf do the rounding
529 if (ndigits
> MIN_FIELD_WIDTH
- 4 - edigits
)
530 ndigits
= MIN_FIELD_WIDTH
- 4 - edigits
;
533 /* # The result will always contain a decimal point, even if no
536 * - The converted value is to be left adjusted on the field boundary
538 * + A sign (+ or -) always be placed before a number
540 * MIN_FIELD_WIDTH minimum field width
542 * * (ndigits-1) is used as the precision
544 * e format: [-]d.ddde±dd where there is one digit before the
545 * decimal-point character and the number of digits after it is
546 * equal to the precision. The exponent always contains at least two
547 * digits; if the value is zero, the exponent is 00.
549 sprintf (buffer
, "%+-#" STR(MIN_FIELD_WIDTH
) ".*"
550 GFC_REAL_LARGEST_FORMAT
"e", ndigits
- 1, value
);
552 /* Check the resulting string has punctuation in the correct places. */
553 if (d
!= 0 && (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e'))
554 internal_error (&dtp
->common
, "printf is broken");
556 /* Read the exponent back in. */
557 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
559 /* Make sure zero comes out as 0.0e0. */
563 /* Normalize the fractional component. */
564 buffer
[2] = buffer
[1];
567 /* Figure out where to place the decimal point. */
571 nbefore
= e
+ dtp
->u
.p
.scale_factor
;
591 i
= dtp
->u
.p
.scale_factor
;
604 nafter
= (d
- i
) + 1;
620 /* The exponent must be a multiple of three, with 1-3 digits before
621 the decimal point. */
630 nbefore
= 3 - nbefore
;
649 /* Should never happen. */
650 internal_error (&dtp
->common
, "Unexpected format token");
653 /* Round the value. */
654 if (nbefore
+ nafter
== 0)
657 if (nzero_real
== d
&& digits
[0] >= '5')
659 /* We rounded to zero but shouldn't have */
666 else if (nbefore
+ nafter
< ndigits
)
668 ndigits
= nbefore
+ nafter
;
670 if (digits
[i
] >= '5')
672 /* Propagate the carry. */
673 for (i
--; i
>= 0; i
--)
675 if (digits
[i
] != '9')
685 /* The carry overflowed. Fortunately we have some spare space
686 at the start of the buffer. We may discard some digits, but
687 this is ok because we already know they are zero. */
700 else if (ft
== FMT_EN
)
715 /* Calculate the format of the exponent field. */
719 for (i
= abs (e
); i
>= 10; i
/= 10)
724 /* Width not specified. Must be no more than 3 digits. */
725 if (e
> 999 || e
< -999)
730 if (e
> 99 || e
< -99)
736 /* Exponent width specified, check it is wide enough. */
737 if (edigits
> f
->u
.real
.e
)
740 edigits
= f
->u
.real
.e
+ 2;
746 /* Pick a field size if none was specified. */
748 w
= nbefore
+ nzero
+ nafter
+ (sign
!= SIGN_NONE
? 2 : 1);
750 /* Create the ouput buffer. */
751 out
= write_block (dtp
, w
);
755 /* Zero values always output as positive, even if the value was negative
757 for (i
= 0; i
< ndigits
; i
++)
759 if (digits
[i
] != '0')
763 sign
= calculate_sign (dtp
, 0);
765 /* Work out how much padding is needed. */
766 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
767 if (sign
!= SIGN_NONE
)
770 /* Check the value fits in the specified field width. */
771 if (nblanks
< 0 || edigits
== -1)
777 /* See if we have space for a zero before the decimal point. */
778 if (nbefore
== 0 && nblanks
> 0)
786 /* Pad to full field width. */
789 if ( ( nblanks
> 0 ) && !dtp
->u
.p
.no_leading_blank
)
791 memset (out
, ' ', nblanks
);
795 /* Output the initial sign (if any). */
796 if (sign
== SIGN_PLUS
)
798 else if (sign
== SIGN_MINUS
)
801 /* Output an optional leading zero. */
805 /* Output the part before the decimal point, padding with zeros. */
808 if (nbefore
> ndigits
)
813 memcpy (out
, digits
, i
);
821 /* Output the decimal point. */
824 /* Output leading zeros after the decimal point. */
827 for (i
= 0; i
< nzero
; i
++)
831 /* Output digits after the decimal point, padding with zeros. */
834 if (nafter
> ndigits
)
839 memcpy (out
, digits
, i
);
848 /* Output the exponent. */
857 snprintf (buffer
, sizeof (buffer
), "%+0*d", edigits
, e
);
859 sprintf (buffer
, "%+0*d", edigits
, e
);
861 memcpy (out
, buffer
, edigits
);
864 if (dtp
->u
.p
.no_leading_blank
)
867 memset( out
, ' ' , nblanks
);
868 dtp
->u
.p
.no_leading_blank
= 0;
872 #undef MIN_FIELD_WIDTH
877 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
880 GFC_INTEGER_LARGEST n
;
882 p
= write_block (dtp
, f
->u
.w
);
886 memset (p
, ' ', f
->u
.w
- 1);
887 n
= extract_int (source
, len
);
888 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
891 /* Output a real number according to its format. */
894 write_float (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
897 int nb
=0, res
, save_scale_factor
;
901 n
= extract_real (source
, len
);
903 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
910 /* If the field width is zero, the processor must select a width
911 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
914 p
= write_block (dtp
, nb
);
930 /* If the sign is negative and the width is 3, there is
931 insufficient room to output '-Inf', so output asterisks */
939 /* The negative sign is mandatory */
945 /* The positive sign is optional, but we output it for
952 /* We have room, so output 'Infinity' */
954 memcpy(p
+ nb
- 8, "Infinity", 8);
957 /* For the case of width equals 8, there is not enough room
958 for the sign and 'Infinity' so we go with 'Inf' */
960 memcpy(p
+ nb
- 3, "Inf", 3);
961 if (nb
< 9 && nb
> 3)
962 p
[nb
- 4] = fin
; /* Put the sign in front of Inf */
964 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity */
967 memcpy(p
+ nb
- 3, "NaN", 3);
972 if (f
->format
!= FMT_G
)
973 output_float (dtp
, f
, n
);
976 save_scale_factor
= dtp
->u
.p
.scale_factor
;
977 f2
= calculate_G_format (dtp
, f
, n
, &nb
);
978 output_float (dtp
, f2
, n
);
979 dtp
->u
.p
.scale_factor
= save_scale_factor
;
985 p
= write_block (dtp
, nb
);
995 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
996 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
998 GFC_UINTEGER_LARGEST n
= 0;
999 int w
, m
, digits
, nzero
, nblank
;
1002 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1007 n
= extract_uint (source
, len
);
1011 if (m
== 0 && n
== 0)
1016 p
= write_block (dtp
, w
);
1024 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
1025 digits
= strlen (q
);
1027 /* Select a width if none was specified. The idea here is to always
1031 w
= ((digits
< m
) ? m
: digits
);
1033 p
= write_block (dtp
, w
);
1041 /* See if things will work. */
1043 nblank
= w
- (nzero
+ digits
);
1052 if (!dtp
->u
.p
.no_leading_blank
)
1054 memset (p
, ' ', nblank
);
1056 memset (p
, '0', nzero
);
1058 memcpy (p
, q
, digits
);
1062 memset (p
, '0', nzero
);
1064 memcpy (p
, q
, digits
);
1066 memset (p
, ' ', nblank
);
1067 dtp
->u
.p
.no_leading_blank
= 0;
1075 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
1077 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
1079 GFC_INTEGER_LARGEST n
= 0;
1080 int w
, m
, digits
, nsign
, nzero
, nblank
;
1084 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1089 n
= extract_int (source
, len
);
1093 if (m
== 0 && n
== 0)
1098 p
= write_block (dtp
, w
);
1106 sign
= calculate_sign (dtp
, n
< 0);
1110 nsign
= sign
== SIGN_NONE
? 0 : 1;
1111 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
1113 digits
= strlen (q
);
1115 /* Select a width if none was specified. The idea here is to always
1119 w
= ((digits
< m
) ? m
: digits
) + nsign
;
1121 p
= write_block (dtp
, w
);
1129 /* See if things will work. */
1131 nblank
= w
- (nsign
+ nzero
+ digits
);
1139 memset (p
, ' ', nblank
);
1154 memset (p
, '0', nzero
);
1157 memcpy (p
, q
, digits
);
1164 /* Convert unsigned octal to ascii. */
1167 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1171 assert (len
>= GFC_OTOA_BUF_SIZE
);
1176 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1181 *--p
= '0' + (n
& 7);
1189 /* Convert unsigned binary to ascii. */
1192 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1196 assert (len
>= GFC_BTOA_BUF_SIZE
);
1201 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
1206 *--p
= '0' + (n
& 1);
1215 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1217 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1222 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1224 write_int (dtp
, f
, p
, len
, btoa
);
1229 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1231 write_int (dtp
, f
, p
, len
, otoa
);
1235 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1237 write_int (dtp
, f
, p
, len
, xtoa
);
1242 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1244 write_float (dtp
, f
, p
, len
);
1249 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1251 write_float (dtp
, f
, p
, len
);
1256 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1258 write_float (dtp
, f
, p
, len
);
1263 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1265 write_float (dtp
, f
, p
, len
);
1270 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1272 write_float (dtp
, f
, p
, len
);
1276 /* Take care of the X/TR descriptor. */
1279 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1283 p
= write_block (dtp
, len
);
1288 memset (&p
[len
- nspaces
], ' ', nspaces
);
1292 /* List-directed writing. */
1295 /* Write a single character to the output. Returns nonzero if
1296 something goes wrong. */
1299 write_char (st_parameter_dt
*dtp
, char c
)
1303 p
= write_block (dtp
, 1);
1313 /* Write a list-directed logical value. */
1316 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1318 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1322 /* Write a list-directed integer value. */
1325 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1331 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1333 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1358 digits
= strlen (q
);
1362 p
= write_block (dtp
, width
);
1365 if (dtp
->u
.p
.no_leading_blank
)
1367 memcpy (p
, q
, digits
);
1368 memset (p
+ digits
, ' ', width
- digits
);
1372 memset (p
, ' ', width
- digits
);
1373 memcpy (p
+ width
- digits
, q
, digits
);
1378 /* Write a list-directed string. We have to worry about delimiting
1379 the strings if the file has been opened in that mode. */
1382 write_character (st_parameter_dt
*dtp
, const char *source
, int length
)
1387 switch (dtp
->u
.p
.current_unit
->flags
.delim
)
1389 case DELIM_APOSTROPHE
:
1406 for (i
= 0; i
< length
; i
++)
1411 p
= write_block (dtp
, length
+ extra
);
1416 memcpy (p
, source
, length
);
1421 for (i
= 0; i
< length
; i
++)
1433 /* Output a real number with default format.
1434 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1435 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
1438 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1441 int org_scale
= dtp
->u
.p
.scale_factor
;
1443 dtp
->u
.p
.scale_factor
= 1;
1467 internal_error (&dtp
->common
, "bad real kind");
1470 write_float (dtp
, &f
, source
, length
);
1471 dtp
->u
.p
.scale_factor
= org_scale
;
1476 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1478 if (write_char (dtp
, '('))
1480 write_real (dtp
, source
, kind
);
1482 if (write_char (dtp
, ','))
1484 write_real (dtp
, source
+ size
/ 2, kind
);
1486 write_char (dtp
, ')');
1490 /* Write the separator between items. */
1493 write_separator (st_parameter_dt
*dtp
)
1497 p
= write_block (dtp
, options
.separator_len
);
1501 memcpy (p
, options
.separator
, options
.separator_len
);
1505 /* Write an item with list formatting.
1506 TODO: handle skipping to the next record correctly, particularly
1510 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1513 if (dtp
->u
.p
.current_unit
== NULL
)
1516 if (dtp
->u
.p
.first_item
)
1518 dtp
->u
.p
.first_item
= 0;
1519 write_char (dtp
, ' ');
1523 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1524 dtp
->u
.p
.current_unit
->flags
.delim
!= DELIM_NONE
)
1525 write_separator (dtp
);
1531 write_integer (dtp
, p
, kind
);
1534 write_logical (dtp
, p
, kind
);
1537 write_character (dtp
, p
, kind
);
1540 write_real (dtp
, p
, kind
);
1543 write_complex (dtp
, p
, kind
, size
);
1546 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1549 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1554 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1555 size_t size
, size_t nelems
)
1562 /* Big loop over all the elements. */
1563 for (elem
= 0; elem
< nelems
; elem
++)
1565 dtp
->u
.p
.item_count
++;
1566 list_formatted_write_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1572 nml_write_obj writes a namelist object to the output stream. It is called
1573 recursively for derived type components:
1574 obj = is the namelist_info for the current object.
1575 offset = the offset relative to the address held by the object for
1576 derived type arrays.
1577 base = is the namelist_info of the derived type, when obj is a
1579 base_name = the full name for a derived type, including qualifiers
1581 The returned value is a pointer to the object beyond the last one
1582 accessed, including nested derived types. Notice that the namelist is
1583 a linear linked list of objects, including derived types and their
1584 components. A tree, of sorts, is implied by the compound names of
1585 the derived type components and this is how this function recurses through
1588 /* A generous estimate of the number of characters needed to print
1589 repeat counts and indices, including commas, asterices and brackets. */
1591 #define NML_DIGITS 20
1593 static namelist_info
*
1594 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1595 namelist_info
* base
, char * base_name
)
1601 index_type obj_size
;
1605 index_type elem_ctr
;
1606 index_type obj_name_len
;
1611 char rep_buff
[NML_DIGITS
];
1612 namelist_info
* cmp
;
1613 namelist_info
* retval
= obj
->next
;
1615 /* Write namelist variable names in upper case. If a derived type,
1616 nothing is output. If a component, base and base_name are set. */
1618 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1621 write_character (dtp
, "\r\n ", 3);
1623 write_character (dtp
, "\n ", 2);
1628 len
=strlen (base
->var_name
);
1629 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1631 cup
= toupper (base_name
[dim_i
]);
1632 write_character (dtp
, &cup
, 1);
1635 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1637 cup
= toupper (obj
->var_name
[dim_i
]);
1638 write_character (dtp
, &cup
, 1);
1640 write_character (dtp
, "=", 1);
1643 /* Counts the number of data output on a line, including names. */
1652 case GFC_DTYPE_REAL
:
1653 obj_size
= size_from_real_kind (len
);
1656 case GFC_DTYPE_COMPLEX
:
1657 obj_size
= size_from_complex_kind (len
);
1660 case GFC_DTYPE_CHARACTER
:
1661 obj_size
= obj
->string_length
;
1669 obj_size
= obj
->size
;
1671 /* Set the index vector and count the number of elements. */
1674 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1676 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1677 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1680 /* Main loop to output the data held in the object. */
1683 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1686 /* Build the pointer to the data value. The offset is passed by
1687 recursive calls to this function for arrays of derived types.
1688 Is NULL otherwise. */
1690 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1693 /* Check for repeat counts of intrinsic types. */
1695 if ((elem_ctr
< (nelem
- 1)) &&
1696 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1697 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1702 /* Execute a repeated output. Note the flag no_leading_blank that
1703 is used in the functions used to output the intrinsic types. */
1709 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1710 write_character (dtp
, rep_buff
, strlen (rep_buff
));
1711 dtp
->u
.p
.no_leading_blank
= 1;
1715 /* Output the data, if an intrinsic type, or recurse into this
1716 routine to treat derived types. */
1721 case GFC_DTYPE_INTEGER
:
1722 write_integer (dtp
, p
, len
);
1725 case GFC_DTYPE_LOGICAL
:
1726 write_logical (dtp
, p
, len
);
1729 case GFC_DTYPE_CHARACTER
:
1730 if (dtp
->u
.p
.nml_delim
)
1731 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1732 write_character (dtp
, p
, obj
->string_length
);
1733 if (dtp
->u
.p
.nml_delim
)
1734 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1737 case GFC_DTYPE_REAL
:
1738 write_real (dtp
, p
, len
);
1741 case GFC_DTYPE_COMPLEX
:
1742 dtp
->u
.p
.no_leading_blank
= 0;
1744 write_complex (dtp
, p
, len
, obj_size
);
1747 case GFC_DTYPE_DERIVED
:
1749 /* To treat a derived type, we need to build two strings:
1750 ext_name = the name, including qualifiers that prepends
1751 component names in the output - passed to
1753 obj_name = the derived type name with no qualifiers but %
1754 appended. This is used to identify the
1757 /* First ext_name => get length of all possible components */
1759 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1760 + (base
? strlen (base
->var_name
) : 0)
1761 + strlen (obj
->var_name
)
1762 + obj
->var_rank
* NML_DIGITS
1765 strcpy(ext_name
, base_name
? base_name
: "");
1766 clen
= base
? strlen (base
->var_name
) : 0;
1767 strcat (ext_name
, obj
->var_name
+ clen
);
1769 /* Append the qualifier. */
1771 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1773 strcat (ext_name
, dim_i
? "" : "(");
1774 clen
= strlen (ext_name
);
1775 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1776 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1781 obj_name_len
= strlen (obj
->var_name
) + 1;
1782 obj_name
= get_mem (obj_name_len
+1);
1783 strcpy (obj_name
, obj
->var_name
);
1784 strcat (obj_name
, "%");
1786 /* Now loop over the components. Update the component pointer
1787 with the return value from nml_write_obj => this loop jumps
1788 past nested derived types. */
1790 for (cmp
= obj
->next
;
1791 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1794 retval
= nml_write_obj (dtp
, cmp
,
1795 (index_type
)(p
- obj
->mem_pos
),
1799 free_mem (obj_name
);
1800 free_mem (ext_name
);
1804 internal_error (&dtp
->common
, "Bad type for namelist write");
1807 /* Reset the leading blank suppression, write a comma and, if 5
1808 values have been output, write a newline and advance to column
1809 2. Reset the repeat counter. */
1811 dtp
->u
.p
.no_leading_blank
= 0;
1812 write_character (dtp
, ",", 1);
1817 write_character (dtp
, "\r\n ", 3);
1819 write_character (dtp
, "\n ", 2);
1825 /* Cycle through and increment the index vector. */
1830 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1832 obj
->ls
[dim_i
].idx
+= nml_carry
;
1834 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1836 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1842 /* Return a pointer beyond the furthest object accessed. */
1847 /* This is the entry function for namelist writes. It outputs the name
1848 of the namelist and iterates through the namelist by calls to
1849 nml_write_obj. The call below has dummys in the arguments used in
1850 the treatment of derived types. */
1853 namelist_write (st_parameter_dt
*dtp
)
1855 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1857 index_type dummy_offset
= 0;
1859 char * dummy_name
= NULL
;
1860 unit_delim tmp_delim
;
1862 /* Set the delimiter for namelist output. */
1864 tmp_delim
= dtp
->u
.p
.current_unit
->flags
.delim
;
1865 dtp
->u
.p
.current_unit
->flags
.delim
= DELIM_NONE
;
1869 dtp
->u
.p
.nml_delim
= '"';
1872 case (DELIM_APOSTROPHE
):
1873 dtp
->u
.p
.nml_delim
= '\'';
1877 dtp
->u
.p
.nml_delim
= '\0';
1881 write_character (dtp
, "&", 1);
1883 /* Write namelist name in upper case - f95 std. */
1885 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1887 c
= toupper (dtp
->namelist_name
[i
]);
1888 write_character (dtp
, &c
,1);
1891 if (dtp
->u
.p
.ionml
!= NULL
)
1893 t1
= dtp
->u
.p
.ionml
;
1897 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1901 write_character (dtp
, " /\r\n", 5);
1903 write_character (dtp
, " /\n", 4);
1906 /* Recover the original delimiter. */
1908 dtp
->u
.p
.current_unit
->flags
.delim
= tmp_delim
;