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. */
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 /* This must be large enough to accurately hold any value. */
390 /* Number of digits before the decimal point. */
392 /* Number of zeros after the decimal point. */
394 /* Number of digits after the decimal point. */
396 /* Number of zeros after the decimal point, whatever the precision. */
411 /* We should always know the field width and precision. */
413 internal_error (&dtp
->common
, "Unspecified precision");
415 /* Use sprintf to print the number in the format +D.DDDDe+ddd
416 For an N digit exponent, this gives us (32-6)-N digits after the
417 decimal point, plus another one before the decimal point. */
418 sign
= calculate_sign (dtp
, value
< 0.0);
422 /* Printf always prints at least two exponent digits. */
427 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
428 abslog
= fabs((double) log10l(value
));
430 abslog
= fabs(log10(value
));
435 edigits
= 1 + (int) log10(abslog
);
438 if (ft
== FMT_F
|| ft
== FMT_EN
439 || ((ft
== FMT_D
|| ft
== FMT_E
) && dtp
->u
.p
.scale_factor
!= 0))
441 /* Always convert at full precision to avoid double rounding. */
442 ndigits
= 27 - edigits
;
446 /* We know the number of digits, so can let printf do the rounding
452 if (ndigits
> 27 - edigits
)
453 ndigits
= 27 - edigits
;
456 /* # The result will always contain a decimal point, even if no
459 * - The converted value is to be left adjusted on the field boundary
461 * + A sign (+ or -) always be placed before a number
463 * 31 minimum field width
465 * * (ndigits-1) is used as the precision
467 * e format: [-]d.ddde±dd where there is one digit before the
468 * decimal-point character and the number of digits after it is
469 * equal to the precision. The exponent always contains at least two
470 * digits; if the value is zero, the exponent is 00.
472 sprintf (buffer
, "%+-#31.*" GFC_REAL_LARGEST_FORMAT
"e",
475 /* Check the resulting string has punctuation in the correct places. */
476 if (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e')
477 internal_error (&dtp
->common
, "printf is broken");
479 /* Read the exponent back in. */
480 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
482 /* Make sure zero comes out as 0.0e0. */
486 /* Normalize the fractional component. */
487 buffer
[2] = buffer
[1];
490 /* Figure out where to place the decimal point. */
494 nbefore
= e
+ dtp
->u
.p
.scale_factor
;
514 i
= dtp
->u
.p
.scale_factor
;
527 nafter
= (d
- i
) + 1;
543 /* The exponent must be a multiple of three, with 1-3 digits before
544 the decimal point. */
553 nbefore
= 3 - nbefore
;
572 /* Should never happen. */
573 internal_error (&dtp
->common
, "Unexpected format token");
576 /* Round the value. */
577 if (nbefore
+ nafter
== 0)
580 if (nzero_real
== d
&& digits
[0] >= '5')
582 /* We rounded to zero but shouldn't have */
589 else if (nbefore
+ nafter
< ndigits
)
591 ndigits
= nbefore
+ nafter
;
593 if (digits
[i
] >= '5')
595 /* Propagate the carry. */
596 for (i
--; i
>= 0; i
--)
598 if (digits
[i
] != '9')
608 /* The carry overflowed. Fortunately we have some spare space
609 at the start of the buffer. We may discard some digits, but
610 this is ok because we already know they are zero. */
623 else if (ft
== FMT_EN
)
638 /* Calculate the format of the exponent field. */
642 for (i
= abs (e
); i
>= 10; i
/= 10)
647 /* Width not specified. Must be no more than 3 digits. */
648 if (e
> 999 || e
< -999)
653 if (e
> 99 || e
< -99)
659 /* Exponent width specified, check it is wide enough. */
660 if (edigits
> f
->u
.real
.e
)
663 edigits
= f
->u
.real
.e
+ 2;
669 /* Pick a field size if none was specified. */
671 w
= nbefore
+ nzero
+ nafter
+ (sign
!= SIGN_NONE
? 2 : 1);
673 /* Create the ouput buffer. */
674 out
= write_block (dtp
, w
);
678 /* Zero values always output as positive, even if the value was negative
680 for (i
= 0; i
< ndigits
; i
++)
682 if (digits
[i
] != '0')
686 sign
= calculate_sign (dtp
, 0);
688 /* Work out how much padding is needed. */
689 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
690 if (sign
!= SIGN_NONE
)
693 /* Check the value fits in the specified field width. */
694 if (nblanks
< 0 || edigits
== -1)
700 /* See if we have space for a zero before the decimal point. */
701 if (nbefore
== 0 && nblanks
> 0)
709 /* Pad to full field width. */
712 if ( ( nblanks
> 0 ) && !dtp
->u
.p
.no_leading_blank
)
714 memset (out
, ' ', nblanks
);
718 /* Output the initial sign (if any). */
719 if (sign
== SIGN_PLUS
)
721 else if (sign
== SIGN_MINUS
)
724 /* Output an optional leading zero. */
728 /* Output the part before the decimal point, padding with zeros. */
731 if (nbefore
> ndigits
)
736 memcpy (out
, digits
, i
);
744 /* Output the decimal point. */
747 /* Output leading zeros after the decimal point. */
750 for (i
= 0; i
< nzero
; i
++)
754 /* Output digits after the decimal point, padding with zeros. */
757 if (nafter
> ndigits
)
762 memcpy (out
, digits
, i
);
771 /* Output the exponent. */
780 snprintf (buffer
, 32, "%+0*d", edigits
, e
);
782 sprintf (buffer
, "%+0*d", edigits
, e
);
784 memcpy (out
, buffer
, edigits
);
787 if (dtp
->u
.p
.no_leading_blank
)
790 memset( out
, ' ' , nblanks
);
791 dtp
->u
.p
.no_leading_blank
= 0;
797 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
800 GFC_INTEGER_LARGEST n
;
802 p
= write_block (dtp
, f
->u
.w
);
806 memset (p
, ' ', f
->u
.w
- 1);
807 n
= extract_int (source
, len
);
808 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
811 /* Output a real number according to its format. */
814 write_float (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
817 int nb
=0, res
, save_scale_factor
;
821 n
= extract_real (source
, len
);
823 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
830 /* If the field width is zero, the processor must select a width
831 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
834 p
= write_block (dtp
, nb
);
850 /* If the sign is negative and the width is 3, there is
851 insufficient room to output '-Inf', so output asterisks */
859 /* The negative sign is mandatory */
865 /* The positive sign is optional, but we output it for
872 /* We have room, so output 'Infinity' */
874 memcpy(p
+ nb
- 8, "Infinity", 8);
877 /* For the case of width equals 8, there is not enough room
878 for the sign and 'Infinity' so we go with 'Inf' */
880 memcpy(p
+ nb
- 3, "Inf", 3);
881 if (nb
< 9 && nb
> 3)
882 p
[nb
- 4] = fin
; /* Put the sign in front of Inf */
884 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity */
887 memcpy(p
+ nb
- 3, "NaN", 3);
892 if (f
->format
!= FMT_G
)
893 output_float (dtp
, f
, n
);
896 save_scale_factor
= dtp
->u
.p
.scale_factor
;
897 f2
= calculate_G_format (dtp
, f
, n
, &nb
);
898 output_float (dtp
, f2
, n
);
899 dtp
->u
.p
.scale_factor
= save_scale_factor
;
905 p
= write_block (dtp
, nb
);
915 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
916 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
918 GFC_UINTEGER_LARGEST n
= 0;
919 int w
, m
, digits
, nzero
, nblank
;
922 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
927 n
= extract_uint (source
, len
);
931 if (m
== 0 && n
== 0)
936 p
= write_block (dtp
, w
);
944 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
947 /* Select a width if none was specified. The idea here is to always
951 w
= ((digits
< m
) ? m
: digits
);
953 p
= write_block (dtp
, w
);
961 /* See if things will work. */
963 nblank
= w
- (nzero
+ digits
);
972 if (!dtp
->u
.p
.no_leading_blank
)
974 memset (p
, ' ', nblank
);
976 memset (p
, '0', nzero
);
978 memcpy (p
, q
, digits
);
982 memset (p
, '0', nzero
);
984 memcpy (p
, q
, digits
);
986 memset (p
, ' ', nblank
);
987 dtp
->u
.p
.no_leading_blank
= 0;
995 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
997 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
999 GFC_INTEGER_LARGEST n
= 0;
1000 int w
, m
, digits
, nsign
, nzero
, nblank
;
1004 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1009 n
= extract_int (source
, len
);
1013 if (m
== 0 && n
== 0)
1018 p
= write_block (dtp
, w
);
1026 sign
= calculate_sign (dtp
, n
< 0);
1030 nsign
= sign
== SIGN_NONE
? 0 : 1;
1031 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
1033 digits
= strlen (q
);
1035 /* Select a width if none was specified. The idea here is to always
1039 w
= ((digits
< m
) ? m
: digits
) + nsign
;
1041 p
= write_block (dtp
, w
);
1049 /* See if things will work. */
1051 nblank
= w
- (nsign
+ nzero
+ digits
);
1059 memset (p
, ' ', nblank
);
1074 memset (p
, '0', nzero
);
1077 memcpy (p
, q
, digits
);
1084 /* Convert unsigned octal to ascii. */
1087 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1091 assert (len
>= GFC_OTOA_BUF_SIZE
);
1096 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1101 *--p
= '0' + (n
& 7);
1109 /* Convert unsigned binary to ascii. */
1112 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1116 assert (len
>= GFC_BTOA_BUF_SIZE
);
1121 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
1126 *--p
= '0' + (n
& 1);
1135 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1137 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1142 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1144 write_int (dtp
, f
, p
, len
, btoa
);
1149 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1151 write_int (dtp
, f
, p
, len
, otoa
);
1155 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1157 write_int (dtp
, f
, p
, len
, xtoa
);
1162 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1164 write_float (dtp
, f
, p
, len
);
1169 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1171 write_float (dtp
, f
, p
, len
);
1176 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1178 write_float (dtp
, f
, p
, len
);
1183 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1185 write_float (dtp
, f
, p
, len
);
1190 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1192 write_float (dtp
, f
, p
, len
);
1196 /* Take care of the X/TR descriptor. */
1199 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1203 p
= write_block (dtp
, len
);
1208 memset (&p
[len
- nspaces
], ' ', nspaces
);
1212 /* List-directed writing. */
1215 /* Write a single character to the output. Returns nonzero if
1216 something goes wrong. */
1219 write_char (st_parameter_dt
*dtp
, char c
)
1223 p
= write_block (dtp
, 1);
1233 /* Write a list-directed logical value. */
1236 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1238 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1242 /* Write a list-directed integer value. */
1245 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1251 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1253 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1278 digits
= strlen (q
);
1282 p
= write_block (dtp
, width
);
1285 if (dtp
->u
.p
.no_leading_blank
)
1287 memcpy (p
, q
, digits
);
1288 memset (p
+ digits
, ' ', width
- digits
);
1292 memset (p
, ' ', width
- digits
);
1293 memcpy (p
+ width
- digits
, q
, digits
);
1298 /* Write a list-directed string. We have to worry about delimiting
1299 the strings if the file has been opened in that mode. */
1302 write_character (st_parameter_dt
*dtp
, const char *source
, int length
)
1307 switch (dtp
->u
.p
.current_unit
->flags
.delim
)
1309 case DELIM_APOSTROPHE
:
1326 for (i
= 0; i
< length
; i
++)
1331 p
= write_block (dtp
, length
+ extra
);
1336 memcpy (p
, source
, length
);
1341 for (i
= 0; i
< length
; i
++)
1353 /* Output a real number with default format.
1354 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1355 1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
1358 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1361 int org_scale
= dtp
->u
.p
.scale_factor
;
1363 dtp
->u
.p
.scale_factor
= 1;
1387 internal_error (&dtp
->common
, "bad real kind");
1390 write_float (dtp
, &f
, source
, length
);
1391 dtp
->u
.p
.scale_factor
= org_scale
;
1396 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1398 if (write_char (dtp
, '('))
1400 write_real (dtp
, source
, kind
);
1402 if (write_char (dtp
, ','))
1404 write_real (dtp
, source
+ size
/ 2, kind
);
1406 write_char (dtp
, ')');
1410 /* Write the separator between items. */
1413 write_separator (st_parameter_dt
*dtp
)
1417 p
= write_block (dtp
, options
.separator_len
);
1421 memcpy (p
, options
.separator
, options
.separator_len
);
1425 /* Write an item with list formatting.
1426 TODO: handle skipping to the next record correctly, particularly
1430 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1433 if (dtp
->u
.p
.current_unit
== NULL
)
1436 if (dtp
->u
.p
.first_item
)
1438 dtp
->u
.p
.first_item
= 0;
1439 write_char (dtp
, ' ');
1443 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1444 dtp
->u
.p
.current_unit
->flags
.delim
!= DELIM_NONE
)
1445 write_separator (dtp
);
1451 write_integer (dtp
, p
, kind
);
1454 write_logical (dtp
, p
, kind
);
1457 write_character (dtp
, p
, kind
);
1460 write_real (dtp
, p
, kind
);
1463 write_complex (dtp
, p
, kind
, size
);
1466 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1469 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1474 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1475 size_t size
, size_t nelems
)
1482 /* Big loop over all the elements. */
1483 for (elem
= 0; elem
< nelems
; elem
++)
1485 dtp
->u
.p
.item_count
++;
1486 list_formatted_write_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1492 nml_write_obj writes a namelist object to the output stream. It is called
1493 recursively for derived type components:
1494 obj = is the namelist_info for the current object.
1495 offset = the offset relative to the address held by the object for
1496 derived type arrays.
1497 base = is the namelist_info of the derived type, when obj is a
1499 base_name = the full name for a derived type, including qualifiers
1501 The returned value is a pointer to the object beyond the last one
1502 accessed, including nested derived types. Notice that the namelist is
1503 a linear linked list of objects, including derived types and their
1504 components. A tree, of sorts, is implied by the compound names of
1505 the derived type components and this is how this function recurses through
1508 /* A generous estimate of the number of characters needed to print
1509 repeat counts and indices, including commas, asterices and brackets. */
1511 #define NML_DIGITS 20
1513 static namelist_info
*
1514 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1515 namelist_info
* base
, char * base_name
)
1521 index_type obj_size
;
1525 index_type elem_ctr
;
1526 index_type obj_name_len
;
1531 char rep_buff
[NML_DIGITS
];
1532 namelist_info
* cmp
;
1533 namelist_info
* retval
= obj
->next
;
1535 /* Write namelist variable names in upper case. If a derived type,
1536 nothing is output. If a component, base and base_name are set. */
1538 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1541 write_character (dtp
, "\r\n ", 3);
1543 write_character (dtp
, "\n ", 2);
1548 len
=strlen (base
->var_name
);
1549 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1551 cup
= toupper (base_name
[dim_i
]);
1552 write_character (dtp
, &cup
, 1);
1555 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1557 cup
= toupper (obj
->var_name
[dim_i
]);
1558 write_character (dtp
, &cup
, 1);
1560 write_character (dtp
, "=", 1);
1563 /* Counts the number of data output on a line, including names. */
1572 case GFC_DTYPE_REAL
:
1573 obj_size
= size_from_real_kind (len
);
1576 case GFC_DTYPE_COMPLEX
:
1577 obj_size
= size_from_complex_kind (len
);
1580 case GFC_DTYPE_CHARACTER
:
1581 obj_size
= obj
->string_length
;
1589 obj_size
= obj
->size
;
1591 /* Set the index vector and count the number of elements. */
1594 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1596 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1597 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1600 /* Main loop to output the data held in the object. */
1603 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1606 /* Build the pointer to the data value. The offset is passed by
1607 recursive calls to this function for arrays of derived types.
1608 Is NULL otherwise. */
1610 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1613 /* Check for repeat counts of intrinsic types. */
1615 if ((elem_ctr
< (nelem
- 1)) &&
1616 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1617 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1622 /* Execute a repeated output. Note the flag no_leading_blank that
1623 is used in the functions used to output the intrinsic types. */
1629 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1630 write_character (dtp
, rep_buff
, strlen (rep_buff
));
1631 dtp
->u
.p
.no_leading_blank
= 1;
1635 /* Output the data, if an intrinsic type, or recurse into this
1636 routine to treat derived types. */
1641 case GFC_DTYPE_INTEGER
:
1642 write_integer (dtp
, p
, len
);
1645 case GFC_DTYPE_LOGICAL
:
1646 write_logical (dtp
, p
, len
);
1649 case GFC_DTYPE_CHARACTER
:
1650 if (dtp
->u
.p
.nml_delim
)
1651 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1652 write_character (dtp
, p
, obj
->string_length
);
1653 if (dtp
->u
.p
.nml_delim
)
1654 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1657 case GFC_DTYPE_REAL
:
1658 write_real (dtp
, p
, len
);
1661 case GFC_DTYPE_COMPLEX
:
1662 dtp
->u
.p
.no_leading_blank
= 0;
1664 write_complex (dtp
, p
, len
, obj_size
);
1667 case GFC_DTYPE_DERIVED
:
1669 /* To treat a derived type, we need to build two strings:
1670 ext_name = the name, including qualifiers that prepends
1671 component names in the output - passed to
1673 obj_name = the derived type name with no qualifiers but %
1674 appended. This is used to identify the
1677 /* First ext_name => get length of all possible components */
1679 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1680 + (base
? strlen (base
->var_name
) : 0)
1681 + strlen (obj
->var_name
)
1682 + obj
->var_rank
* NML_DIGITS
1685 strcpy(ext_name
, base_name
? base_name
: "");
1686 clen
= base
? strlen (base
->var_name
) : 0;
1687 strcat (ext_name
, obj
->var_name
+ clen
);
1689 /* Append the qualifier. */
1691 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1693 strcat (ext_name
, dim_i
? "" : "(");
1694 clen
= strlen (ext_name
);
1695 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1696 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1701 obj_name_len
= strlen (obj
->var_name
) + 1;
1702 obj_name
= get_mem (obj_name_len
+1);
1703 strcpy (obj_name
, obj
->var_name
);
1704 strcat (obj_name
, "%");
1706 /* Now loop over the components. Update the component pointer
1707 with the return value from nml_write_obj => this loop jumps
1708 past nested derived types. */
1710 for (cmp
= obj
->next
;
1711 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1714 retval
= nml_write_obj (dtp
, cmp
,
1715 (index_type
)(p
- obj
->mem_pos
),
1719 free_mem (obj_name
);
1720 free_mem (ext_name
);
1724 internal_error (&dtp
->common
, "Bad type for namelist write");
1727 /* Reset the leading blank suppression, write a comma and, if 5
1728 values have been output, write a newline and advance to column
1729 2. Reset the repeat counter. */
1731 dtp
->u
.p
.no_leading_blank
= 0;
1732 write_character (dtp
, ",", 1);
1737 write_character (dtp
, "\r\n ", 3);
1739 write_character (dtp
, "\n ", 2);
1745 /* Cycle through and increment the index vector. */
1750 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1752 obj
->ls
[dim_i
].idx
+= nml_carry
;
1754 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1756 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1762 /* Return a pointer beyond the furthest object accessed. */
1767 /* This is the entry function for namelist writes. It outputs the name
1768 of the namelist and iterates through the namelist by calls to
1769 nml_write_obj. The call below has dummys in the arguments used in
1770 the treatment of derived types. */
1773 namelist_write (st_parameter_dt
*dtp
)
1775 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1777 index_type dummy_offset
= 0;
1779 char * dummy_name
= NULL
;
1780 unit_delim tmp_delim
;
1782 /* Set the delimiter for namelist output. */
1784 tmp_delim
= dtp
->u
.p
.current_unit
->flags
.delim
;
1785 dtp
->u
.p
.current_unit
->flags
.delim
= DELIM_NONE
;
1789 dtp
->u
.p
.nml_delim
= '"';
1792 case (DELIM_APOSTROPHE
):
1793 dtp
->u
.p
.nml_delim
= '\'';
1797 dtp
->u
.p
.nml_delim
= '\0';
1801 write_character (dtp
, "&", 1);
1803 /* Write namelist name in upper case - f95 std. */
1805 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1807 c
= toupper (dtp
->namelist_name
[i
]);
1808 write_character (dtp
, &c
,1);
1811 if (dtp
->u
.p
.ionml
!= NULL
)
1813 t1
= dtp
->u
.p
.ionml
;
1817 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1821 write_character (dtp
, " /\r\n", 5);
1823 write_character (dtp
, " /\n", 4);
1826 /* Recover the original delimiter. */
1828 dtp
->u
.p
.current_unit
->flags
.delim
= tmp_delim
;