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
}
49 static int no_leading_blank
= 0 ;
52 write_a (fnode
* f
, const char *source
, int len
)
57 wlen
= f
->u
.string
.length
< 0 ? len
: f
->u
.string
.length
;
59 p
= write_block (wlen
);
64 memcpy (p
, source
, wlen
);
67 memset (p
, ' ', wlen
- len
);
68 memcpy (p
+ wlen
- len
, source
, len
);
72 static GFC_INTEGER_LARGEST
73 extract_int (const void *p
, int len
)
75 GFC_INTEGER_LARGEST i
= 0;
85 memcpy ((void *) &tmp
, p
, len
);
92 memcpy ((void *) &tmp
, p
, len
);
99 memcpy ((void *) &tmp
, p
, len
);
106 memcpy ((void *) &tmp
, p
, len
);
110 #ifdef HAVE_GFC_INTEGER_16
114 memcpy ((void *) &tmp
, p
, len
);
120 internal_error ("bad integer kind");
126 static GFC_UINTEGER_LARGEST
127 extract_uint (const void *p
, int len
)
129 GFC_UINTEGER_LARGEST i
= 0;
139 memcpy ((void *) &tmp
, p
, len
);
140 i
= (GFC_UINTEGER_1
) tmp
;
146 memcpy ((void *) &tmp
, p
, len
);
147 i
= (GFC_UINTEGER_2
) tmp
;
153 memcpy ((void *) &tmp
, p
, len
);
154 i
= (GFC_UINTEGER_4
) tmp
;
160 memcpy ((void *) &tmp
, p
, len
);
161 i
= (GFC_UINTEGER_8
) tmp
;
164 #ifdef HAVE_GFC_INTEGER_16
168 memcpy ((void *) &tmp
, p
, len
);
169 i
= (GFC_UINTEGER_16
) tmp
;
174 internal_error ("bad integer kind");
180 static GFC_REAL_LARGEST
181 extract_real (const void *p
, int len
)
183 GFC_REAL_LARGEST i
= 0;
189 memcpy ((void *) &tmp
, p
, len
);
196 memcpy ((void *) &tmp
, p
, len
);
200 #ifdef HAVE_GFC_REAL_10
204 memcpy ((void *) &tmp
, p
, len
);
209 #ifdef HAVE_GFC_REAL_16
213 memcpy ((void *) &tmp
, p
, len
);
219 internal_error ("bad real kind");
225 /* Given a flag that indicate if a value is negative or not, return a
226 sign_t that gives the sign that we need to produce. */
229 calculate_sign (int negative_flag
)
231 sign_t s
= SIGN_NONE
;
236 switch (g
.sign_status
)
245 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
253 /* Returns the value of 10**d. */
255 static GFC_REAL_LARGEST
256 calculate_exp (int d
)
259 GFC_REAL_LARGEST r
= 1.0;
261 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
264 r
= (d
>= 0) ? r
: 1.0 / r
;
270 /* Generate corresponding I/O format for FMT_G output.
271 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
272 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
274 Data Magnitude Equivalent Conversion
275 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
276 m = 0 F(w-n).(d-1), n' '
277 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
278 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
279 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
280 ................ ..........
281 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
282 m >= 10**d-0.5 Ew.d[Ee]
284 notes: for Gw.d , n' ' means 4 blanks
285 for Gw.dEe, n' ' means e+2 blanks */
288 calculate_G_format (fnode
*f
, GFC_REAL_LARGEST value
, int *num_blank
)
294 GFC_REAL_LARGEST m
, exp_d
;
298 newf
= get_mem (sizeof (fnode
));
300 /* Absolute value. */
301 m
= (value
> 0.0) ? value
: -value
;
303 /* In case of the two data magnitude ranges,
304 generate E editing, Ew.d[Ee]. */
305 exp_d
= calculate_exp (d
);
306 if ((m
> 0.0 && m
< 0.1 - 0.05 / exp_d
) || (m
>= exp_d
- 0.5 ))
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. */
374 /* Output a real number according to its format which is FMT_G free. */
377 output_float (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 ("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 (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
) && g
.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 ("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
+ g
.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 ("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 (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 (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 ) && !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 ( no_leading_blank
)
790 memset( out
, ' ' , nblanks
);
791 no_leading_blank
= 0;
797 write_l (fnode
* f
, char *source
, int len
)
800 GFC_INTEGER_LARGEST n
;
802 p
= write_block (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 (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 (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
)
898 save_scale_factor
= g
.scale_factor
;
899 f2
= calculate_G_format(f
, n
, &nb
);
900 output_float (f2
, n
);
901 g
.scale_factor
= save_scale_factor
;
907 p
= write_block (nb
);
917 write_int (fnode
*f
, const char *source
, int len
,
918 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
920 GFC_UINTEGER_LARGEST n
= 0;
921 int w
, m
, digits
, nzero
, nblank
;
924 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
929 n
= extract_uint (source
, len
);
933 if (m
== 0 && n
== 0)
946 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
949 /* Select a width if none was specified. The idea here is to always
953 w
= ((digits
< m
) ? m
: digits
);
963 /* See if things will work. */
965 nblank
= w
- (nzero
+ digits
);
974 if (!no_leading_blank
)
976 memset (p
, ' ', nblank
);
978 memset (p
, '0', nzero
);
980 memcpy (p
, q
, digits
);
984 memset (p
, '0', nzero
);
986 memcpy (p
, q
, digits
);
988 memset (p
, ' ', nblank
);
989 no_leading_blank
= 0;
997 write_decimal (fnode
*f
, const char *source
, int len
,
998 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
1000 GFC_INTEGER_LARGEST n
= 0;
1001 int w
, m
, digits
, nsign
, nzero
, nblank
;
1005 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1010 n
= extract_int (source
, len
);
1014 if (m
== 0 && n
== 0)
1019 p
= write_block (w
);
1027 sign
= calculate_sign (n
< 0);
1031 nsign
= sign
== SIGN_NONE
? 0 : 1;
1032 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
1034 digits
= strlen (q
);
1036 /* Select a width if none was specified. The idea here is to always
1040 w
= ((digits
< m
) ? m
: digits
) + nsign
;
1042 p
= write_block (w
);
1050 /* See if things will work. */
1052 nblank
= w
- (nsign
+ nzero
+ digits
);
1060 memset (p
, ' ', nblank
);
1075 memset (p
, '0', nzero
);
1078 memcpy (p
, q
, digits
);
1085 /* Convert unsigned octal to ascii. */
1088 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1092 assert (len
>= GFC_OTOA_BUF_SIZE
);
1097 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1102 *--p
= '0' + (n
& 7);
1110 /* Convert unsigned binary to ascii. */
1113 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1117 assert (len
>= GFC_BTOA_BUF_SIZE
);
1122 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
1127 *--p
= '0' + (n
& 1);
1136 write_i (fnode
* f
, const char *p
, int len
)
1138 write_decimal (f
, p
, len
, (void *) gfc_itoa
);
1143 write_b (fnode
* f
, const char *p
, int len
)
1145 write_int (f
, p
, len
, btoa
);
1150 write_o (fnode
* f
, const char *p
, int len
)
1152 write_int (f
, p
, len
, otoa
);
1156 write_z (fnode
* f
, const char *p
, int len
)
1158 write_int (f
, p
, len
, xtoa
);
1163 write_d (fnode
*f
, const char *p
, int len
)
1165 write_float (f
, p
, len
);
1170 write_e (fnode
*f
, const char *p
, int len
)
1172 write_float (f
, p
, len
);
1177 write_f (fnode
*f
, const char *p
, int len
)
1179 write_float (f
, p
, len
);
1184 write_en (fnode
*f
, const char *p
, int len
)
1186 write_float (f
, p
, len
);
1191 write_es (fnode
*f
, const char *p
, int len
)
1193 write_float (f
, p
, len
);
1197 /* Take care of the X/TR descriptor. */
1200 write_x (int len
, int nspaces
)
1204 p
= write_block (len
);
1209 memset (&p
[len
- nspaces
], ' ', nspaces
);
1213 /* List-directed writing. */
1216 /* Write a single character to the output. Returns nonzero if
1217 something goes wrong. */
1224 p
= write_block (1);
1234 /* Write a list-directed logical value. */
1237 write_logical (const char *source
, int length
)
1239 write_char (extract_int (source
, length
) ? 'T' : 'F');
1243 /* Write a list-directed integer value. */
1246 write_integer (const char *source
, int length
)
1252 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1254 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1279 digits
= strlen (q
);
1283 p
= write_block (width
) ;
1286 if (no_leading_blank
)
1288 memcpy (p
, q
, digits
);
1289 memset(p
+ digits
,' ', width
- digits
) ;
1293 memset(p
,' ', width
- digits
) ;
1294 memcpy (p
+ width
- digits
, q
, digits
);
1299 /* Write a list-directed string. We have to worry about delimiting
1300 the strings if the file has been opened in that mode. */
1303 write_character (const char *source
, int length
)
1308 switch (current_unit
->flags
.delim
)
1310 case DELIM_APOSTROPHE
:
1327 for (i
= 0; i
< length
; i
++)
1332 p
= write_block (length
+ extra
);
1337 memcpy (p
, source
, length
);
1342 for (i
= 0; i
< length
; i
++)
1354 /* Output a real number with default format.
1355 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1356 1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
1359 write_real (const char *source
, int length
)
1362 int org_scale
= g
.scale_factor
;
1388 internal_error ("bad real kind");
1391 write_float (&f
, source
, length
);
1392 g
.scale_factor
= org_scale
;
1397 write_complex (const char *source
, int kind
, size_t size
)
1399 if (write_char ('('))
1401 write_real (source
, kind
);
1403 if (write_char (','))
1405 write_real (source
+ size
/ 2, kind
);
1411 /* Write the separator between items. */
1414 write_separator (void)
1418 p
= write_block (options
.separator_len
);
1422 memcpy (p
, options
.separator
, options
.separator_len
);
1426 /* Write an item with list formatting.
1427 TODO: handle skipping to the next record correctly, particularly
1431 list_formatted_write_scalar (bt type
, void *p
, int kind
, size_t size
)
1433 static int char_flag
;
1435 if (current_unit
== NULL
)
1446 if (type
!= BT_CHARACTER
|| !char_flag
||
1447 current_unit
->flags
.delim
!= DELIM_NONE
)
1454 write_integer (p
, kind
);
1457 write_logical (p
, kind
);
1460 write_character (p
, kind
);
1463 write_real (p
, kind
);
1466 write_complex (p
, kind
, size
);
1469 internal_error ("list_formatted_write(): Bad type");
1472 char_flag
= (type
== BT_CHARACTER
);
1477 list_formatted_write (bt type
, void *p
, int kind
, size_t size
, size_t nelems
)
1484 /* Big loop over all the elements. */
1485 for (elem
= 0; elem
< nelems
; elem
++)
1488 list_formatted_write_scalar (type
, tmp
+ size
*elem
, kind
, size
);
1494 nml_write_obj writes a namelist object to the output stream. It is called
1495 recursively for derived type components:
1496 obj = is the namelist_info for the current object.
1497 offset = the offset relative to the address held by the object for
1498 derived type arrays.
1499 base = is the namelist_info of the derived type, when obj is a
1501 base_name = the full name for a derived type, including qualifiers
1503 The returned value is a pointer to the object beyond the last one
1504 accessed, including nested derived types. Notice that the namelist is
1505 a linear linked list of objects, including derived types and their
1506 components. A tree, of sorts, is implied by the compound names of
1507 the derived type components and this is how this function recurses through
1510 /* A generous estimate of the number of characters needed to print
1511 repeat counts and indices, including commas, asterices and brackets. */
1513 #define NML_DIGITS 20
1515 /* Stores the delimiter to be used for character objects. */
1517 static const char * nml_delim
;
1519 static namelist_info
*
1520 nml_write_obj (namelist_info
* obj
, index_type offset
,
1521 namelist_info
* base
, char * base_name
)
1527 index_type obj_size
;
1531 index_type elem_ctr
;
1532 index_type obj_name_len
;
1537 char rep_buff
[NML_DIGITS
];
1538 namelist_info
* cmp
;
1539 namelist_info
* retval
= obj
->next
;
1541 /* Write namelist variable names in upper case. If a derived type,
1542 nothing is output. If a component, base and base_name are set. */
1544 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1546 write_character ("\n ", 2);
1550 len
=strlen (base
->var_name
);
1551 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1553 cup
= toupper (base_name
[dim_i
]);
1554 write_character (&cup
, 1);
1557 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1559 cup
= toupper (obj
->var_name
[dim_i
]);
1560 write_character (&cup
, 1);
1562 write_character ("=", 1);
1565 /* Counts the number of data output on a line, including names. */
1574 case GFC_DTYPE_REAL
:
1575 obj_size
= size_from_real_kind (len
);
1578 case GFC_DTYPE_COMPLEX
:
1579 obj_size
= size_from_complex_kind (len
);
1582 case GFC_DTYPE_CHARACTER
:
1583 obj_size
= obj
->string_length
;
1591 obj_size
= obj
->size
;
1593 /* Set the index vector and count the number of elements. */
1596 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1598 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1599 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1602 /* Main loop to output the data held in the object. */
1605 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1608 /* Build the pointer to the data value. The offset is passed by
1609 recursive calls to this function for arrays of derived types.
1610 Is NULL otherwise. */
1612 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1615 /* Check for repeat counts of intrinsic types. */
1617 if ((elem_ctr
< (nelem
- 1)) &&
1618 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1619 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1624 /* Execute a repeated output. Note the flag no_leading_blank that
1625 is used in the functions used to output the intrinsic types. */
1631 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1632 write_character (rep_buff
, strlen (rep_buff
));
1633 no_leading_blank
= 1;
1637 /* Output the data, if an intrinsic type, or recurse into this
1638 routine to treat derived types. */
1643 case GFC_DTYPE_INTEGER
:
1644 write_integer (p
, len
);
1647 case GFC_DTYPE_LOGICAL
:
1648 write_logical (p
, len
);
1651 case GFC_DTYPE_CHARACTER
:
1653 write_character (nml_delim
, 1);
1654 write_character (p
, obj
->string_length
);
1656 write_character (nml_delim
, 1);
1659 case GFC_DTYPE_REAL
:
1660 write_real (p
, len
);
1663 case GFC_DTYPE_COMPLEX
:
1664 no_leading_blank
= 0;
1666 write_complex (p
, len
, obj_size
);
1669 case GFC_DTYPE_DERIVED
:
1671 /* To treat a derived type, we need to build two strings:
1672 ext_name = the name, including qualifiers that prepends
1673 component names in the output - passed to
1675 obj_name = the derived type name with no qualifiers but %
1676 appended. This is used to identify the
1679 /* First ext_name => get length of all possible components */
1681 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1682 + (base
? strlen (base
->var_name
) : 0)
1683 + strlen (obj
->var_name
)
1684 + obj
->var_rank
* NML_DIGITS
1687 strcpy(ext_name
, base_name
? base_name
: "");
1688 clen
= base
? strlen (base
->var_name
) : 0;
1689 strcat (ext_name
, obj
->var_name
+ clen
);
1691 /* Append the qualifier. */
1693 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1695 strcat (ext_name
, dim_i
? "" : "(");
1696 clen
= strlen (ext_name
);
1697 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1698 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1703 obj_name_len
= strlen (obj
->var_name
) + 1;
1704 obj_name
= get_mem (obj_name_len
+1);
1705 strcpy (obj_name
, obj
->var_name
);
1706 strcat (obj_name
, "%");
1708 /* Now loop over the components. Update the component pointer
1709 with the return value from nml_write_obj => this loop jumps
1710 past nested derived types. */
1712 for (cmp
= obj
->next
;
1713 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1716 retval
= nml_write_obj (cmp
, (index_type
)(p
- obj
->mem_pos
),
1720 free_mem (obj_name
);
1721 free_mem (ext_name
);
1725 internal_error ("Bad type for namelist write");
1728 /* Reset the leading blank suppression, write a comma and, if 5
1729 values have been output, write a newline and advance to column
1730 2. Reset the repeat counter. */
1732 no_leading_blank
= 0;
1733 write_character (",", 1);
1737 write_character ("\n ", 2);
1742 /* Cycle through and increment the index vector. */
1747 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1749 obj
->ls
[dim_i
].idx
+= nml_carry
;
1751 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1753 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1759 /* Return a pointer beyond the furthest object accessed. */
1764 /* This is the entry function for namelist writes. It outputs the name
1765 of the namelist and iterates through the namelist by calls to
1766 nml_write_obj. The call below has dummys in the arguments used in
1767 the treatment of derived types. */
1770 namelist_write (void)
1772 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1774 index_type dummy_offset
= 0;
1776 char * dummy_name
= NULL
;
1777 unit_delim tmp_delim
;
1779 /* Set the delimiter for namelist output. */
1781 tmp_delim
= current_unit
->flags
.delim
;
1782 current_unit
->flags
.delim
= DELIM_NONE
;
1789 case (DELIM_APOSTROPHE
):
1797 write_character ("&",1);
1799 /* Write namelist name in upper case - f95 std. */
1801 for (i
= 0 ;i
< ioparm
.namelist_name_len
;i
++ )
1803 c
= toupper (ioparm
.namelist_name
[i
]);
1804 write_character (&c
,1);
1813 t1
= nml_write_obj (t2
, dummy_offset
, dummy
, dummy_name
);
1816 write_character (" /\n", 4);
1818 /* Recover the original delimiter. */
1820 current_unit
->flags
.delim
= tmp_delim
;