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 ))
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. */
368 dtp
->u
.p
.scale_factor
= 0;
373 /* Output a real number according to its format which is FMT_G free. */
376 output_float (st_parameter_dt
*dtp
, const 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 (&dtp
->common
, "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 (dtp
, 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
) && dtp
->u
.p
.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 (&dtp
->common
, "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
+ dtp
->u
.p
.scale_factor
;
513 i
= dtp
->u
.p
.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 (&dtp
->common
, "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 (dtp
, 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 (dtp
, 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 ) && !dtp
->u
.p
.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 (dtp
->u
.p
.no_leading_blank
)
789 memset( out
, ' ' , nblanks
);
790 dtp
->u
.p
.no_leading_blank
= 0;
796 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
799 GFC_INTEGER_LARGEST n
;
801 p
= write_block (dtp
, 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 (st_parameter_dt
*dtp
, const 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 (dtp
, nb
);
849 /* If the sign is negative and the width is 3, there is
850 insufficient room to output '-Inf', so output asterisks */
858 /* The negative sign is mandatory */
864 /* The positive sign is optional, but we output it for
871 /* We have room, so output 'Infinity' */
873 memcpy(p
+ nb
- 8, "Infinity", 8);
876 /* For the case of width equals 8, there is not enough room
877 for the sign and 'Infinity' so we go with 'Inf' */
879 memcpy(p
+ nb
- 3, "Inf", 3);
880 if (nb
< 9 && nb
> 3)
881 p
[nb
- 4] = fin
; /* Put the sign in front of Inf */
883 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity */
886 memcpy(p
+ nb
- 3, "NaN", 3);
891 if (f
->format
!= FMT_G
)
892 output_float (dtp
, f
, n
);
895 save_scale_factor
= dtp
->u
.p
.scale_factor
;
896 f2
= calculate_G_format (dtp
, f
, n
, &nb
);
897 output_float (dtp
, f2
, n
);
898 dtp
->u
.p
.scale_factor
= save_scale_factor
;
904 p
= write_block (dtp
, nb
);
914 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
915 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
917 GFC_UINTEGER_LARGEST n
= 0;
918 int w
, m
, digits
, nzero
, nblank
;
921 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
926 n
= extract_uint (source
, len
);
930 if (m
== 0 && n
== 0)
935 p
= write_block (dtp
, w
);
943 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
946 /* Select a width if none was specified. The idea here is to always
950 w
= ((digits
< m
) ? m
: digits
);
952 p
= write_block (dtp
, w
);
960 /* See if things will work. */
962 nblank
= w
- (nzero
+ digits
);
971 if (!dtp
->u
.p
.no_leading_blank
)
973 memset (p
, ' ', nblank
);
975 memset (p
, '0', nzero
);
977 memcpy (p
, q
, digits
);
981 memset (p
, '0', nzero
);
983 memcpy (p
, q
, digits
);
985 memset (p
, ' ', nblank
);
986 dtp
->u
.p
.no_leading_blank
= 0;
994 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
996 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
998 GFC_INTEGER_LARGEST n
= 0;
999 int w
, m
, digits
, nsign
, nzero
, nblank
;
1003 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1008 n
= extract_int (source
, len
);
1012 if (m
== 0 && n
== 0)
1017 p
= write_block (dtp
, w
);
1025 sign
= calculate_sign (dtp
, n
< 0);
1029 nsign
= sign
== SIGN_NONE
? 0 : 1;
1030 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
1032 digits
= strlen (q
);
1034 /* Select a width if none was specified. The idea here is to always
1038 w
= ((digits
< m
) ? m
: digits
) + nsign
;
1040 p
= write_block (dtp
, w
);
1048 /* See if things will work. */
1050 nblank
= w
- (nsign
+ nzero
+ digits
);
1058 memset (p
, ' ', nblank
);
1073 memset (p
, '0', nzero
);
1076 memcpy (p
, q
, digits
);
1083 /* Convert unsigned octal to ascii. */
1086 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1090 assert (len
>= GFC_OTOA_BUF_SIZE
);
1095 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1100 *--p
= '0' + (n
& 7);
1108 /* Convert unsigned binary to ascii. */
1111 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1115 assert (len
>= GFC_BTOA_BUF_SIZE
);
1120 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
1125 *--p
= '0' + (n
& 1);
1134 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1136 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1141 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1143 write_int (dtp
, f
, p
, len
, btoa
);
1148 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1150 write_int (dtp
, f
, p
, len
, otoa
);
1154 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1156 write_int (dtp
, f
, p
, len
, xtoa
);
1161 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1163 write_float (dtp
, f
, p
, len
);
1168 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1170 write_float (dtp
, f
, p
, len
);
1175 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1177 write_float (dtp
, f
, p
, len
);
1182 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1184 write_float (dtp
, f
, p
, len
);
1189 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1191 write_float (dtp
, f
, p
, len
);
1195 /* Take care of the X/TR descriptor. */
1198 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1202 p
= write_block (dtp
, len
);
1207 memset (&p
[len
- nspaces
], ' ', nspaces
);
1211 /* List-directed writing. */
1214 /* Write a single character to the output. Returns nonzero if
1215 something goes wrong. */
1218 write_char (st_parameter_dt
*dtp
, char c
)
1222 p
= write_block (dtp
, 1);
1232 /* Write a list-directed logical value. */
1235 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1237 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1241 /* Write a list-directed integer value. */
1244 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1250 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1252 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1277 digits
= strlen (q
);
1281 p
= write_block (dtp
, width
);
1284 if (dtp
->u
.p
.no_leading_blank
)
1286 memcpy (p
, q
, digits
);
1287 memset (p
+ digits
, ' ', width
- digits
);
1291 memset (p
, ' ', width
- digits
);
1292 memcpy (p
+ width
- digits
, q
, digits
);
1297 /* Write a list-directed string. We have to worry about delimiting
1298 the strings if the file has been opened in that mode. */
1301 write_character (st_parameter_dt
*dtp
, const char *source
, int length
)
1306 switch (dtp
->u
.p
.current_unit
->flags
.delim
)
1308 case DELIM_APOSTROPHE
:
1325 for (i
= 0; i
< length
; i
++)
1330 p
= write_block (dtp
, length
+ extra
);
1335 memcpy (p
, source
, length
);
1340 for (i
= 0; i
< length
; i
++)
1352 /* Output a real number with default format.
1353 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1354 1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
1357 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1360 int org_scale
= dtp
->u
.p
.scale_factor
;
1362 dtp
->u
.p
.scale_factor
= 1;
1386 internal_error (&dtp
->common
, "bad real kind");
1389 write_float (dtp
, &f
, source
, length
);
1390 dtp
->u
.p
.scale_factor
= org_scale
;
1395 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1397 if (write_char (dtp
, '('))
1399 write_real (dtp
, source
, kind
);
1401 if (write_char (dtp
, ','))
1403 write_real (dtp
, source
+ size
/ 2, kind
);
1405 write_char (dtp
, ')');
1409 /* Write the separator between items. */
1412 write_separator (st_parameter_dt
*dtp
)
1416 p
= write_block (dtp
, options
.separator_len
);
1420 memcpy (p
, options
.separator
, options
.separator_len
);
1424 /* Write an item with list formatting.
1425 TODO: handle skipping to the next record correctly, particularly
1429 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1432 if (dtp
->u
.p
.current_unit
== NULL
)
1435 if (dtp
->u
.p
.first_item
)
1437 dtp
->u
.p
.first_item
= 0;
1438 write_char (dtp
, ' ');
1442 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1443 dtp
->u
.p
.current_unit
->flags
.delim
!= DELIM_NONE
)
1444 write_separator (dtp
);
1450 write_integer (dtp
, p
, kind
);
1453 write_logical (dtp
, p
, kind
);
1456 write_character (dtp
, p
, kind
);
1459 write_real (dtp
, p
, kind
);
1462 write_complex (dtp
, p
, kind
, size
);
1465 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1468 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1473 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1474 size_t size
, size_t nelems
)
1481 /* Big loop over all the elements. */
1482 for (elem
= 0; elem
< nelems
; elem
++)
1484 dtp
->u
.p
.item_count
++;
1485 list_formatted_write_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1491 nml_write_obj writes a namelist object to the output stream. It is called
1492 recursively for derived type components:
1493 obj = is the namelist_info for the current object.
1494 offset = the offset relative to the address held by the object for
1495 derived type arrays.
1496 base = is the namelist_info of the derived type, when obj is a
1498 base_name = the full name for a derived type, including qualifiers
1500 The returned value is a pointer to the object beyond the last one
1501 accessed, including nested derived types. Notice that the namelist is
1502 a linear linked list of objects, including derived types and their
1503 components. A tree, of sorts, is implied by the compound names of
1504 the derived type components and this is how this function recurses through
1507 /* A generous estimate of the number of characters needed to print
1508 repeat counts and indices, including commas, asterices and brackets. */
1510 #define NML_DIGITS 20
1512 static namelist_info
*
1513 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1514 namelist_info
* base
, char * base_name
)
1520 index_type obj_size
;
1524 index_type elem_ctr
;
1525 index_type obj_name_len
;
1530 char rep_buff
[NML_DIGITS
];
1531 namelist_info
* cmp
;
1532 namelist_info
* retval
= obj
->next
;
1534 /* Write namelist variable names in upper case. If a derived type,
1535 nothing is output. If a component, base and base_name are set. */
1537 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1540 write_character (dtp
, "\r\n ", 3);
1542 write_character (dtp
, "\n ", 2);
1547 len
=strlen (base
->var_name
);
1548 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1550 cup
= toupper (base_name
[dim_i
]);
1551 write_character (dtp
, &cup
, 1);
1554 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1556 cup
= toupper (obj
->var_name
[dim_i
]);
1557 write_character (dtp
, &cup
, 1);
1559 write_character (dtp
, "=", 1);
1562 /* Counts the number of data output on a line, including names. */
1571 case GFC_DTYPE_REAL
:
1572 obj_size
= size_from_real_kind (len
);
1575 case GFC_DTYPE_COMPLEX
:
1576 obj_size
= size_from_complex_kind (len
);
1579 case GFC_DTYPE_CHARACTER
:
1580 obj_size
= obj
->string_length
;
1588 obj_size
= obj
->size
;
1590 /* Set the index vector and count the number of elements. */
1593 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1595 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1596 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1599 /* Main loop to output the data held in the object. */
1602 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1605 /* Build the pointer to the data value. The offset is passed by
1606 recursive calls to this function for arrays of derived types.
1607 Is NULL otherwise. */
1609 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1612 /* Check for repeat counts of intrinsic types. */
1614 if ((elem_ctr
< (nelem
- 1)) &&
1615 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1616 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1621 /* Execute a repeated output. Note the flag no_leading_blank that
1622 is used in the functions used to output the intrinsic types. */
1628 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1629 write_character (dtp
, rep_buff
, strlen (rep_buff
));
1630 dtp
->u
.p
.no_leading_blank
= 1;
1634 /* Output the data, if an intrinsic type, or recurse into this
1635 routine to treat derived types. */
1640 case GFC_DTYPE_INTEGER
:
1641 write_integer (dtp
, p
, len
);
1644 case GFC_DTYPE_LOGICAL
:
1645 write_logical (dtp
, p
, len
);
1648 case GFC_DTYPE_CHARACTER
:
1649 if (dtp
->u
.p
.nml_delim
)
1650 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1651 write_character (dtp
, p
, obj
->string_length
);
1652 if (dtp
->u
.p
.nml_delim
)
1653 write_character (dtp
, &dtp
->u
.p
.nml_delim
, 1);
1656 case GFC_DTYPE_REAL
:
1657 write_real (dtp
, p
, len
);
1660 case GFC_DTYPE_COMPLEX
:
1661 dtp
->u
.p
.no_leading_blank
= 0;
1663 write_complex (dtp
, p
, len
, obj_size
);
1666 case GFC_DTYPE_DERIVED
:
1668 /* To treat a derived type, we need to build two strings:
1669 ext_name = the name, including qualifiers that prepends
1670 component names in the output - passed to
1672 obj_name = the derived type name with no qualifiers but %
1673 appended. This is used to identify the
1676 /* First ext_name => get length of all possible components */
1678 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1679 + (base
? strlen (base
->var_name
) : 0)
1680 + strlen (obj
->var_name
)
1681 + obj
->var_rank
* NML_DIGITS
1684 strcpy(ext_name
, base_name
? base_name
: "");
1685 clen
= base
? strlen (base
->var_name
) : 0;
1686 strcat (ext_name
, obj
->var_name
+ clen
);
1688 /* Append the qualifier. */
1690 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1692 strcat (ext_name
, dim_i
? "" : "(");
1693 clen
= strlen (ext_name
);
1694 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1695 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1700 obj_name_len
= strlen (obj
->var_name
) + 1;
1701 obj_name
= get_mem (obj_name_len
+1);
1702 strcpy (obj_name
, obj
->var_name
);
1703 strcat (obj_name
, "%");
1705 /* Now loop over the components. Update the component pointer
1706 with the return value from nml_write_obj => this loop jumps
1707 past nested derived types. */
1709 for (cmp
= obj
->next
;
1710 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1713 retval
= nml_write_obj (dtp
, cmp
,
1714 (index_type
)(p
- obj
->mem_pos
),
1718 free_mem (obj_name
);
1719 free_mem (ext_name
);
1723 internal_error (&dtp
->common
, "Bad type for namelist write");
1726 /* Reset the leading blank suppression, write a comma and, if 5
1727 values have been output, write a newline and advance to column
1728 2. Reset the repeat counter. */
1730 dtp
->u
.p
.no_leading_blank
= 0;
1731 write_character (dtp
, ",", 1);
1736 write_character (dtp
, "\r\n ", 3);
1738 write_character (dtp
, "\n ", 2);
1744 /* Cycle through and increment the index vector. */
1749 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1751 obj
->ls
[dim_i
].idx
+= nml_carry
;
1753 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1755 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1761 /* Return a pointer beyond the furthest object accessed. */
1766 /* This is the entry function for namelist writes. It outputs the name
1767 of the namelist and iterates through the namelist by calls to
1768 nml_write_obj. The call below has dummys in the arguments used in
1769 the treatment of derived types. */
1772 namelist_write (st_parameter_dt
*dtp
)
1774 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1776 index_type dummy_offset
= 0;
1778 char * dummy_name
= NULL
;
1779 unit_delim tmp_delim
;
1781 /* Set the delimiter for namelist output. */
1783 tmp_delim
= dtp
->u
.p
.current_unit
->flags
.delim
;
1784 dtp
->u
.p
.current_unit
->flags
.delim
= DELIM_NONE
;
1788 dtp
->u
.p
.nml_delim
= '"';
1791 case (DELIM_APOSTROPHE
):
1792 dtp
->u
.p
.nml_delim
= '\'';
1796 dtp
->u
.p
.nml_delim
= '\0';
1800 write_character (dtp
, "&", 1);
1802 /* Write namelist name in upper case - f95 std. */
1804 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1806 c
= toupper (dtp
->namelist_name
[i
]);
1807 write_character (dtp
, &c
,1);
1810 if (dtp
->u
.p
.ionml
!= NULL
)
1812 t1
= dtp
->u
.p
.ionml
;
1816 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1820 write_character (dtp
, " /\r\n", 5);
1822 write_character (dtp
, " /\n", 4);
1825 /* Recover the original delimiter. */
1827 dtp
->u
.p
.current_unit
->flags
.delim
= tmp_delim
;