[RTL-ifcvt] PR rtl-optimization/68506: Fix emitting order of insns in IF-THEN-JOIN...
[official-gcc.git] / libgfortran / io / write.c
blob6656c9768158daefdbf475f84d6b125c98c46913
1 /* Copyright (C) 2002-2015 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist output contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 #include "io.h"
28 #include "fbuf.h"
29 #include "format.h"
30 #include "unix.h"
31 #include <assert.h>
32 #include <string.h>
33 #include <ctype.h>
34 #include <stdlib.h>
35 #include <errno.h>
36 #define star_fill(p, n) memset(p, '*', n)
38 typedef unsigned char uchar;
40 /* Helper functions for character(kind=4) internal units. These are needed
41 by write_float.def. */
43 static void
44 memcpy4 (gfc_char4_t *dest, const char *source, int k)
46 int j;
48 const char *p = source;
49 for (j = 0; j < k; j++)
50 *dest++ = (gfc_char4_t) *p++;
53 /* This include contains the heart and soul of formatted floating point. */
54 #include "write_float.def"
56 /* Write out default char4. */
58 static void
59 write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
60 int src_len, int w_len)
62 char *p;
63 int j, k = 0;
64 gfc_char4_t c;
65 uchar d;
67 /* Take care of preceding blanks. */
68 if (w_len > src_len)
70 k = w_len - src_len;
71 p = write_block (dtp, k);
72 if (p == NULL)
73 return;
74 if (is_char4_unit (dtp))
76 gfc_char4_t *p4 = (gfc_char4_t *) p;
77 memset4 (p4, ' ', k);
79 else
80 memset (p, ' ', k);
83 /* Get ready to handle delimiters if needed. */
84 switch (dtp->u.p.current_unit->delim_status)
86 case DELIM_APOSTROPHE:
87 d = '\'';
88 break;
89 case DELIM_QUOTE:
90 d = '"';
91 break;
92 default:
93 d = ' ';
94 break;
97 /* Now process the remaining characters, one at a time. */
98 for (j = 0; j < src_len; j++)
100 c = source[j];
101 if (is_char4_unit (dtp))
103 gfc_char4_t *q;
104 /* Handle delimiters if any. */
105 if (c == d && d != ' ')
107 p = write_block (dtp, 2);
108 if (p == NULL)
109 return;
110 q = (gfc_char4_t *) p;
111 *q++ = c;
113 else
115 p = write_block (dtp, 1);
116 if (p == NULL)
117 return;
118 q = (gfc_char4_t *) p;
120 *q = c;
122 else
124 /* Handle delimiters if any. */
125 if (c == d && d != ' ')
127 p = write_block (dtp, 2);
128 if (p == NULL)
129 return;
130 *p++ = (uchar) c;
132 else
134 p = write_block (dtp, 1);
135 if (p == NULL)
136 return;
138 *p = c > 255 ? '?' : (uchar) c;
144 /* Write out UTF-8 converted from char4. */
146 static void
147 write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
148 int src_len, int w_len)
150 char *p;
151 int j, k = 0;
152 gfc_char4_t c;
153 static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
154 static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
155 int nbytes;
156 uchar buf[6], d, *q;
158 /* Take care of preceding blanks. */
159 if (w_len > src_len)
161 k = w_len - src_len;
162 p = write_block (dtp, k);
163 if (p == NULL)
164 return;
165 memset (p, ' ', k);
168 /* Get ready to handle delimiters if needed. */
169 switch (dtp->u.p.current_unit->delim_status)
171 case DELIM_APOSTROPHE:
172 d = '\'';
173 break;
174 case DELIM_QUOTE:
175 d = '"';
176 break;
177 default:
178 d = ' ';
179 break;
182 /* Now process the remaining characters, one at a time. */
183 for (j = k; j < src_len; j++)
185 c = source[j];
186 if (c < 0x80)
188 /* Handle the delimiters if any. */
189 if (c == d && d != ' ')
191 p = write_block (dtp, 2);
192 if (p == NULL)
193 return;
194 *p++ = (uchar) c;
196 else
198 p = write_block (dtp, 1);
199 if (p == NULL)
200 return;
202 *p = (uchar) c;
204 else
206 /* Convert to UTF-8 sequence. */
207 nbytes = 1;
208 q = &buf[6];
212 *--q = ((c & 0x3F) | 0x80);
213 c >>= 6;
214 nbytes++;
216 while (c >= 0x3F || (c & limits[nbytes-1]));
218 *--q = (c | masks[nbytes-1]);
220 p = write_block (dtp, nbytes);
221 if (p == NULL)
222 return;
224 while (q < &buf[6])
225 *p++ = *q++;
231 void
232 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
234 int wlen;
235 char *p;
237 wlen = f->u.string.length < 0
238 || (f->format == FMT_G && f->u.string.length == 0)
239 ? len : f->u.string.length;
241 #ifdef HAVE_CRLF
242 /* If this is formatted STREAM IO convert any embedded line feed characters
243 to CR_LF on systems that use that sequence for newlines. See F2003
244 Standard sections 10.6.3 and 9.9 for further information. */
245 if (is_stream_io (dtp))
247 const char crlf[] = "\r\n";
248 int i, q, bytes;
249 q = bytes = 0;
251 /* Write out any padding if needed. */
252 if (len < wlen)
254 p = write_block (dtp, wlen - len);
255 if (p == NULL)
256 return;
257 memset (p, ' ', wlen - len);
260 /* Scan the source string looking for '\n' and convert it if found. */
261 for (i = 0; i < wlen; i++)
263 if (source[i] == '\n')
265 /* Write out the previously scanned characters in the string. */
266 if (bytes > 0)
268 p = write_block (dtp, bytes);
269 if (p == NULL)
270 return;
271 memcpy (p, &source[q], bytes);
272 q += bytes;
273 bytes = 0;
276 /* Write out the CR_LF sequence. */
277 q++;
278 p = write_block (dtp, 2);
279 if (p == NULL)
280 return;
281 memcpy (p, crlf, 2);
283 else
284 bytes++;
287 /* Write out any remaining bytes if no LF was found. */
288 if (bytes > 0)
290 p = write_block (dtp, bytes);
291 if (p == NULL)
292 return;
293 memcpy (p, &source[q], bytes);
296 else
298 #endif
299 p = write_block (dtp, wlen);
300 if (p == NULL)
301 return;
303 if (unlikely (is_char4_unit (dtp)))
305 gfc_char4_t *p4 = (gfc_char4_t *) p;
306 if (wlen < len)
307 memcpy4 (p4, source, wlen);
308 else
310 memset4 (p4, ' ', wlen - len);
311 memcpy4 (p4 + wlen - len, source, len);
313 return;
316 if (wlen < len)
317 memcpy (p, source, wlen);
318 else
320 memset (p, ' ', wlen - len);
321 memcpy (p + wlen - len, source, len);
323 #ifdef HAVE_CRLF
325 #endif
329 /* The primary difference between write_a_char4 and write_a is that we have to
330 deal with writing from the first byte of the 4-byte character and pay
331 attention to the most significant bytes. For ENCODING="default" write the
332 lowest significant byte. If the 3 most significant bytes contain
333 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
334 to the UTF-8 encoded string before writing out. */
336 void
337 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
339 int wlen;
340 gfc_char4_t *q;
342 wlen = f->u.string.length < 0
343 || (f->format == FMT_G && f->u.string.length == 0)
344 ? len : f->u.string.length;
346 q = (gfc_char4_t *) source;
347 #ifdef HAVE_CRLF
348 /* If this is formatted STREAM IO convert any embedded line feed characters
349 to CR_LF on systems that use that sequence for newlines. See F2003
350 Standard sections 10.6.3 and 9.9 for further information. */
351 if (is_stream_io (dtp))
353 const gfc_char4_t crlf[] = {0x000d,0x000a};
354 int i, bytes;
355 gfc_char4_t *qq;
356 bytes = 0;
358 /* Write out any padding if needed. */
359 if (len < wlen)
361 char *p;
362 p = write_block (dtp, wlen - len);
363 if (p == NULL)
364 return;
365 memset (p, ' ', wlen - len);
368 /* Scan the source string looking for '\n' and convert it if found. */
369 qq = (gfc_char4_t *) source;
370 for (i = 0; i < wlen; i++)
372 if (qq[i] == '\n')
374 /* Write out the previously scanned characters in the string. */
375 if (bytes > 0)
377 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
378 write_utf8_char4 (dtp, q, bytes, 0);
379 else
380 write_default_char4 (dtp, q, bytes, 0);
381 bytes = 0;
384 /* Write out the CR_LF sequence. */
385 write_default_char4 (dtp, crlf, 2, 0);
387 else
388 bytes++;
391 /* Write out any remaining bytes if no LF was found. */
392 if (bytes > 0)
394 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
395 write_utf8_char4 (dtp, q, bytes, 0);
396 else
397 write_default_char4 (dtp, q, bytes, 0);
400 else
402 #endif
403 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
404 write_utf8_char4 (dtp, q, len, wlen);
405 else
406 write_default_char4 (dtp, q, len, wlen);
407 #ifdef HAVE_CRLF
409 #endif
413 static GFC_INTEGER_LARGEST
414 extract_int (const void *p, int len)
416 GFC_INTEGER_LARGEST i = 0;
418 if (p == NULL)
419 return i;
421 switch (len)
423 case 1:
425 GFC_INTEGER_1 tmp;
426 memcpy ((void *) &tmp, p, len);
427 i = tmp;
429 break;
430 case 2:
432 GFC_INTEGER_2 tmp;
433 memcpy ((void *) &tmp, p, len);
434 i = tmp;
436 break;
437 case 4:
439 GFC_INTEGER_4 tmp;
440 memcpy ((void *) &tmp, p, len);
441 i = tmp;
443 break;
444 case 8:
446 GFC_INTEGER_8 tmp;
447 memcpy ((void *) &tmp, p, len);
448 i = tmp;
450 break;
451 #ifdef HAVE_GFC_INTEGER_16
452 case 16:
454 GFC_INTEGER_16 tmp;
455 memcpy ((void *) &tmp, p, len);
456 i = tmp;
458 break;
459 #endif
460 default:
461 internal_error (NULL, "bad integer kind");
464 return i;
467 static GFC_UINTEGER_LARGEST
468 extract_uint (const void *p, int len)
470 GFC_UINTEGER_LARGEST i = 0;
472 if (p == NULL)
473 return i;
475 switch (len)
477 case 1:
479 GFC_INTEGER_1 tmp;
480 memcpy ((void *) &tmp, p, len);
481 i = (GFC_UINTEGER_1) tmp;
483 break;
484 case 2:
486 GFC_INTEGER_2 tmp;
487 memcpy ((void *) &tmp, p, len);
488 i = (GFC_UINTEGER_2) tmp;
490 break;
491 case 4:
493 GFC_INTEGER_4 tmp;
494 memcpy ((void *) &tmp, p, len);
495 i = (GFC_UINTEGER_4) tmp;
497 break;
498 case 8:
500 GFC_INTEGER_8 tmp;
501 memcpy ((void *) &tmp, p, len);
502 i = (GFC_UINTEGER_8) tmp;
504 break;
505 #ifdef HAVE_GFC_INTEGER_16
506 case 10:
507 case 16:
509 GFC_INTEGER_16 tmp = 0;
510 memcpy ((void *) &tmp, p, len);
511 i = (GFC_UINTEGER_16) tmp;
513 break;
514 #endif
515 default:
516 internal_error (NULL, "bad integer kind");
519 return i;
523 void
524 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
526 char *p;
527 int wlen;
528 GFC_INTEGER_LARGEST n;
530 wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
532 p = write_block (dtp, wlen);
533 if (p == NULL)
534 return;
536 n = extract_int (source, len);
538 if (unlikely (is_char4_unit (dtp)))
540 gfc_char4_t *p4 = (gfc_char4_t *) p;
541 memset4 (p4, ' ', wlen -1);
542 p4[wlen - 1] = (n) ? 'T' : 'F';
543 return;
546 memset (p, ' ', wlen -1);
547 p[wlen - 1] = (n) ? 'T' : 'F';
551 static void
552 write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
554 int w, m, digits, nzero, nblank;
555 char *p;
557 w = f->u.integer.w;
558 m = f->u.integer.m;
560 /* Special case: */
562 if (m == 0 && n == 0)
564 if (w == 0)
565 w = 1;
567 p = write_block (dtp, w);
568 if (p == NULL)
569 return;
570 if (unlikely (is_char4_unit (dtp)))
572 gfc_char4_t *p4 = (gfc_char4_t *) p;
573 memset4 (p4, ' ', w);
575 else
576 memset (p, ' ', w);
577 goto done;
580 digits = strlen (q);
582 /* Select a width if none was specified. The idea here is to always
583 print something. */
585 if (w == 0)
586 w = ((digits < m) ? m : digits);
588 p = write_block (dtp, w);
589 if (p == NULL)
590 return;
592 nzero = 0;
593 if (digits < m)
594 nzero = m - digits;
596 /* See if things will work. */
598 nblank = w - (nzero + digits);
600 if (unlikely (is_char4_unit (dtp)))
602 gfc_char4_t *p4 = (gfc_char4_t *) p;
603 if (nblank < 0)
605 memset4 (p4, '*', w);
606 return;
609 if (!dtp->u.p.no_leading_blank)
611 memset4 (p4, ' ', nblank);
612 q += nblank;
613 memset4 (p4, '0', nzero);
614 q += nzero;
615 memcpy4 (p4, q, digits);
617 else
619 memset4 (p4, '0', nzero);
620 q += nzero;
621 memcpy4 (p4, q, digits);
622 q += digits;
623 memset4 (p4, ' ', nblank);
624 dtp->u.p.no_leading_blank = 0;
626 return;
629 if (nblank < 0)
631 star_fill (p, w);
632 goto done;
635 if (!dtp->u.p.no_leading_blank)
637 memset (p, ' ', nblank);
638 p += nblank;
639 memset (p, '0', nzero);
640 p += nzero;
641 memcpy (p, q, digits);
643 else
645 memset (p, '0', nzero);
646 p += nzero;
647 memcpy (p, q, digits);
648 p += digits;
649 memset (p, ' ', nblank);
650 dtp->u.p.no_leading_blank = 0;
653 done:
654 return;
657 static void
658 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
659 int len,
660 const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
662 GFC_INTEGER_LARGEST n = 0;
663 int w, m, digits, nsign, nzero, nblank;
664 char *p;
665 const char *q;
666 sign_t sign;
667 char itoa_buf[GFC_BTOA_BUF_SIZE];
669 w = f->u.integer.w;
670 m = f->format == FMT_G ? -1 : f->u.integer.m;
672 n = extract_int (source, len);
674 /* Special case: */
675 if (m == 0 && n == 0)
677 if (w == 0)
678 w = 1;
680 p = write_block (dtp, w);
681 if (p == NULL)
682 return;
683 if (unlikely (is_char4_unit (dtp)))
685 gfc_char4_t *p4 = (gfc_char4_t *) p;
686 memset4 (p4, ' ', w);
688 else
689 memset (p, ' ', w);
690 goto done;
693 sign = calculate_sign (dtp, n < 0);
694 if (n < 0)
695 n = -n;
696 nsign = sign == S_NONE ? 0 : 1;
698 /* conv calls itoa which sets the negative sign needed
699 by write_integer. The sign '+' or '-' is set below based on sign
700 calculated above, so we just point past the sign in the string
701 before proceeding to avoid double signs in corner cases.
702 (see PR38504) */
703 q = conv (n, itoa_buf, sizeof (itoa_buf));
704 if (*q == '-')
705 q++;
707 digits = strlen (q);
709 /* Select a width if none was specified. The idea here is to always
710 print something. */
712 if (w == 0)
713 w = ((digits < m) ? m : digits) + nsign;
715 p = write_block (dtp, w);
716 if (p == NULL)
717 return;
719 nzero = 0;
720 if (digits < m)
721 nzero = m - digits;
723 /* See if things will work. */
725 nblank = w - (nsign + nzero + digits);
727 if (unlikely (is_char4_unit (dtp)))
729 gfc_char4_t * p4 = (gfc_char4_t *) p;
730 if (nblank < 0)
732 memset4 (p4, '*', w);
733 goto done;
736 memset4 (p4, ' ', nblank);
737 p4 += nblank;
739 switch (sign)
741 case S_PLUS:
742 *p4++ = '+';
743 break;
744 case S_MINUS:
745 *p4++ = '-';
746 break;
747 case S_NONE:
748 break;
751 memset4 (p4, '0', nzero);
752 p4 += nzero;
754 memcpy4 (p4, q, digits);
755 return;
758 if (nblank < 0)
760 star_fill (p, w);
761 goto done;
764 memset (p, ' ', nblank);
765 p += nblank;
767 switch (sign)
769 case S_PLUS:
770 *p++ = '+';
771 break;
772 case S_MINUS:
773 *p++ = '-';
774 break;
775 case S_NONE:
776 break;
779 memset (p, '0', nzero);
780 p += nzero;
782 memcpy (p, q, digits);
784 done:
785 return;
789 /* Convert unsigned octal to ascii. */
791 static const char *
792 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
794 char *p;
796 assert (len >= GFC_OTOA_BUF_SIZE);
798 if (n == 0)
799 return "0";
801 p = buffer + GFC_OTOA_BUF_SIZE - 1;
802 *p = '\0';
804 while (n != 0)
806 *--p = '0' + (n & 7);
807 n >>= 3;
810 return p;
814 /* Convert unsigned binary to ascii. */
816 static const char *
817 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
819 char *p;
821 assert (len >= GFC_BTOA_BUF_SIZE);
823 if (n == 0)
824 return "0";
826 p = buffer + GFC_BTOA_BUF_SIZE - 1;
827 *p = '\0';
829 while (n != 0)
831 *--p = '0' + (n & 1);
832 n >>= 1;
835 return p;
838 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
839 to convert large reals with kind sizes that exceed the largest integer type
840 available on certain platforms. In these cases, byte by byte conversion is
841 performed. Endianess is taken into account. */
843 /* Conversion to binary. */
845 static const char *
846 btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
848 char *q;
849 int i, j;
851 q = buffer;
852 if (big_endian)
854 const char *p = s;
855 for (i = 0; i < len; i++)
857 char c = *p;
859 /* Test for zero. Needed by write_boz later. */
860 if (*p != 0)
861 *n = 1;
863 for (j = 0; j < 8; j++)
865 *q++ = (c & 128) ? '1' : '0';
866 c <<= 1;
868 p++;
871 else
873 const char *p = s + len - 1;
874 for (i = 0; i < len; i++)
876 char c = *p;
878 /* Test for zero. Needed by write_boz later. */
879 if (*p != 0)
880 *n = 1;
882 for (j = 0; j < 8; j++)
884 *q++ = (c & 128) ? '1' : '0';
885 c <<= 1;
887 p--;
891 *q = '\0';
893 if (*n == 0)
894 return "0";
896 /* Move past any leading zeros. */
897 while (*buffer == '0')
898 buffer++;
900 return buffer;
904 /* Conversion to octal. */
906 static const char *
907 otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
909 char *q;
910 int i, j, k;
911 uint8_t octet;
913 q = buffer + GFC_OTOA_BUF_SIZE - 1;
914 *q = '\0';
915 i = k = octet = 0;
917 if (big_endian)
919 const char *p = s + len - 1;
920 char c = *p;
921 while (i < len)
923 /* Test for zero. Needed by write_boz later. */
924 if (*p != 0)
925 *n = 1;
927 for (j = 0; j < 3 && i < len; j++)
929 octet |= (c & 1) << j;
930 c >>= 1;
931 if (++k > 7)
933 i++;
934 k = 0;
935 c = *--p;
938 *--q = '0' + octet;
939 octet = 0;
942 else
944 const char *p = s;
945 char c = *p;
946 while (i < len)
948 /* Test for zero. Needed by write_boz later. */
949 if (*p != 0)
950 *n = 1;
952 for (j = 0; j < 3 && i < len; j++)
954 octet |= (c & 1) << j;
955 c >>= 1;
956 if (++k > 7)
958 i++;
959 k = 0;
960 c = *++p;
963 *--q = '0' + octet;
964 octet = 0;
968 if (*n == 0)
969 return "0";
971 /* Move past any leading zeros. */
972 while (*q == '0')
973 q++;
975 return q;
978 /* Conversion to hexidecimal. */
980 static const char *
981 ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
983 static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
984 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
986 char *q;
987 uint8_t h, l;
988 int i;
990 q = buffer;
992 if (big_endian)
994 const char *p = s;
995 for (i = 0; i < len; i++)
997 /* Test for zero. Needed by write_boz later. */
998 if (*p != 0)
999 *n = 1;
1001 h = (*p >> 4) & 0x0F;
1002 l = *p++ & 0x0F;
1003 *q++ = a[h];
1004 *q++ = a[l];
1007 else
1009 const char *p = s + len - 1;
1010 for (i = 0; i < len; i++)
1012 /* Test for zero. Needed by write_boz later. */
1013 if (*p != 0)
1014 *n = 1;
1016 h = (*p >> 4) & 0x0F;
1017 l = *p-- & 0x0F;
1018 *q++ = a[h];
1019 *q++ = a[l];
1023 *q = '\0';
1025 if (*n == 0)
1026 return "0";
1028 /* Move past any leading zeros. */
1029 while (*buffer == '0')
1030 buffer++;
1032 return buffer;
1036 void
1037 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1039 write_decimal (dtp, f, p, len, (void *) gfc_itoa);
1043 void
1044 write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1046 const char *p;
1047 char itoa_buf[GFC_BTOA_BUF_SIZE];
1048 GFC_UINTEGER_LARGEST n = 0;
1050 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1052 p = btoa_big (source, itoa_buf, len, &n);
1053 write_boz (dtp, f, p, n);
1055 else
1057 n = extract_uint (source, len);
1058 p = btoa (n, itoa_buf, sizeof (itoa_buf));
1059 write_boz (dtp, f, p, n);
1064 void
1065 write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1067 const char *p;
1068 char itoa_buf[GFC_OTOA_BUF_SIZE];
1069 GFC_UINTEGER_LARGEST n = 0;
1071 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1073 p = otoa_big (source, itoa_buf, len, &n);
1074 write_boz (dtp, f, p, n);
1076 else
1078 n = extract_uint (source, len);
1079 p = otoa (n, itoa_buf, sizeof (itoa_buf));
1080 write_boz (dtp, f, p, n);
1084 void
1085 write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1087 const char *p;
1088 char itoa_buf[GFC_XTOA_BUF_SIZE];
1089 GFC_UINTEGER_LARGEST n = 0;
1091 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1093 p = ztoa_big (source, itoa_buf, len, &n);
1094 write_boz (dtp, f, p, n);
1096 else
1098 n = extract_uint (source, len);
1099 p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
1100 write_boz (dtp, f, p, n);
1105 void
1106 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1108 write_float (dtp, f, p, len, 0);
1112 void
1113 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1115 write_float (dtp, f, p, len, 0);
1119 void
1120 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1122 write_float (dtp, f, p, len, 0);
1126 void
1127 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1129 write_float (dtp, f, p, len, 0);
1133 void
1134 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1136 write_float (dtp, f, p, len, 0);
1140 /* Take care of the X/TR descriptor. */
1142 void
1143 write_x (st_parameter_dt *dtp, int len, int nspaces)
1145 char *p;
1147 p = write_block (dtp, len);
1148 if (p == NULL)
1149 return;
1150 if (nspaces > 0 && len - nspaces >= 0)
1152 if (unlikely (is_char4_unit (dtp)))
1154 gfc_char4_t *p4 = (gfc_char4_t *) p;
1155 memset4 (&p4[len - nspaces], ' ', nspaces);
1157 else
1158 memset (&p[len - nspaces], ' ', nspaces);
1163 /* List-directed writing. */
1166 /* Write a single character to the output. Returns nonzero if
1167 something goes wrong. */
1169 static int
1170 write_char (st_parameter_dt *dtp, int c)
1172 char *p;
1174 p = write_block (dtp, 1);
1175 if (p == NULL)
1176 return 1;
1177 if (unlikely (is_char4_unit (dtp)))
1179 gfc_char4_t *p4 = (gfc_char4_t *) p;
1180 *p4 = c;
1181 return 0;
1184 *p = (uchar) c;
1186 return 0;
1190 /* Write a list-directed logical value. */
1192 static void
1193 write_logical (st_parameter_dt *dtp, const char *source, int length)
1195 write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1199 /* Write a list-directed integer value. */
1201 static void
1202 write_integer (st_parameter_dt *dtp, const char *source, int length)
1204 char *p;
1205 const char *q;
1206 int digits;
1207 int width;
1208 char itoa_buf[GFC_ITOA_BUF_SIZE];
1210 q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
1212 switch (length)
1214 case 1:
1215 width = 4;
1216 break;
1218 case 2:
1219 width = 6;
1220 break;
1222 case 4:
1223 width = 11;
1224 break;
1226 case 8:
1227 width = 20;
1228 break;
1230 default:
1231 width = 0;
1232 break;
1235 digits = strlen (q);
1237 if (width < digits)
1238 width = digits;
1239 p = write_block (dtp, width);
1240 if (p == NULL)
1241 return;
1243 if (unlikely (is_char4_unit (dtp)))
1245 gfc_char4_t *p4 = (gfc_char4_t *) p;
1246 if (dtp->u.p.no_leading_blank)
1248 memcpy4 (p4, q, digits);
1249 memset4 (p4 + digits, ' ', width - digits);
1251 else
1253 memset4 (p4, ' ', width - digits);
1254 memcpy4 (p4 + width - digits, q, digits);
1256 return;
1259 if (dtp->u.p.no_leading_blank)
1261 memcpy (p, q, digits);
1262 memset (p + digits, ' ', width - digits);
1264 else
1266 memset (p, ' ', width - digits);
1267 memcpy (p + width - digits, q, digits);
1272 /* Write a list-directed string. We have to worry about delimiting
1273 the strings if the file has been opened in that mode. */
1275 #define DELIM 1
1276 #define NODELIM 0
1278 static void
1279 write_character (st_parameter_dt *dtp, const char *source, int kind, int length, int mode)
1281 int i, extra;
1282 char *p, d;
1284 if (mode == DELIM)
1286 switch (dtp->u.p.current_unit->delim_status)
1288 case DELIM_APOSTROPHE:
1289 d = '\'';
1290 break;
1291 case DELIM_QUOTE:
1292 d = '"';
1293 break;
1294 default:
1295 d = ' ';
1296 break;
1299 else
1300 d = ' ';
1302 if (kind == 1)
1304 if (d == ' ')
1305 extra = 0;
1306 else
1308 extra = 2;
1310 for (i = 0; i < length; i++)
1311 if (source[i] == d)
1312 extra++;
1315 p = write_block (dtp, length + extra);
1316 if (p == NULL)
1317 return;
1319 if (unlikely (is_char4_unit (dtp)))
1321 gfc_char4_t d4 = (gfc_char4_t) d;
1322 gfc_char4_t *p4 = (gfc_char4_t *) p;
1324 if (d4 == ' ')
1325 memcpy4 (p4, source, length);
1326 else
1328 *p4++ = d4;
1330 for (i = 0; i < length; i++)
1332 *p4++ = (gfc_char4_t) source[i];
1333 if (source[i] == d)
1334 *p4++ = d4;
1337 *p4 = d4;
1339 return;
1342 if (d == ' ')
1343 memcpy (p, source, length);
1344 else
1346 *p++ = d;
1348 for (i = 0; i < length; i++)
1350 *p++ = source[i];
1351 if (source[i] == d)
1352 *p++ = d;
1355 *p = d;
1358 else
1360 if (d == ' ')
1362 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1363 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1364 else
1365 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1367 else
1369 p = write_block (dtp, 1);
1370 *p = d;
1372 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1373 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1374 else
1375 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1377 p = write_block (dtp, 1);
1378 *p = d;
1384 /* Set an fnode to default format. */
1386 static void
1387 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
1389 f->format = FMT_G;
1390 switch (length)
1392 case 4:
1393 f->u.real.w = 16;
1394 f->u.real.d = 9;
1395 f->u.real.e = 2;
1396 break;
1397 case 8:
1398 f->u.real.w = 25;
1399 f->u.real.d = 17;
1400 f->u.real.e = 3;
1401 break;
1402 case 10:
1403 f->u.real.w = 30;
1404 f->u.real.d = 21;
1405 f->u.real.e = 4;
1406 break;
1407 case 16:
1408 f->u.real.w = 45;
1409 f->u.real.d = 36;
1410 f->u.real.e = 4;
1411 break;
1412 default:
1413 internal_error (&dtp->common, "bad real kind");
1414 break;
1418 /* Output a real number with default format. To guarantee that a
1419 binary -> decimal -> binary roundtrip conversion recovers the
1420 original value, IEEE 754-2008 requires 9, 17, 21 and 36 significant
1421 digits for REAL kinds 4, 8, 10, and 16, respectively. Thus, we use
1422 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4 for
1423 REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1424 Fortran standard requires outputting an extra digit when the scale
1425 factor is 1 and when the magnitude of the value is such that E
1426 editing is used. However, gfortran compensates for this, and thus
1427 for list formatted the same number of significant digits is
1428 generated both when using F and E editing. */
1430 void
1431 write_real (st_parameter_dt *dtp, const char *source, int length)
1433 fnode f ;
1434 int org_scale = dtp->u.p.scale_factor;
1435 dtp->u.p.scale_factor = 1;
1436 set_fnode_default (dtp, &f, length);
1437 write_float (dtp, &f, source , length, 1);
1438 dtp->u.p.scale_factor = org_scale;
1441 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1442 compensate for the extra digit. */
1444 void
1445 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1447 fnode f;
1448 int comp_d;
1449 set_fnode_default (dtp, &f, length);
1450 if (d > 0)
1451 f.u.real.d = d;
1453 /* Compensate for extra digits when using scale factor, d is not
1454 specified, and the magnitude is such that E editing is used. */
1455 if (dtp->u.p.scale_factor > 0 && d == 0)
1456 comp_d = 1;
1457 else
1458 comp_d = 0;
1459 dtp->u.p.g0_no_blanks = 1;
1460 write_float (dtp, &f, source , length, comp_d);
1461 dtp->u.p.g0_no_blanks = 0;
1465 static void
1466 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1468 char semi_comma =
1469 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1471 if (write_char (dtp, '('))
1472 return;
1473 write_real (dtp, source, kind);
1475 if (write_char (dtp, semi_comma))
1476 return;
1477 write_real (dtp, source + size / 2, kind);
1479 write_char (dtp, ')');
1483 /* Write the separator between items. */
1485 static void
1486 write_separator (st_parameter_dt *dtp)
1488 char *p;
1490 p = write_block (dtp, options.separator_len);
1491 if (p == NULL)
1492 return;
1493 if (unlikely (is_char4_unit (dtp)))
1495 gfc_char4_t *p4 = (gfc_char4_t *) p;
1496 memcpy4 (p4, options.separator, options.separator_len);
1498 else
1499 memcpy (p, options.separator, options.separator_len);
1503 /* Write an item with list formatting.
1504 TODO: handle skipping to the next record correctly, particularly
1505 with strings. */
1507 static void
1508 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1509 size_t size)
1511 if (dtp->u.p.current_unit == NULL)
1512 return;
1514 if (dtp->u.p.first_item)
1516 dtp->u.p.first_item = 0;
1517 write_char (dtp, ' ');
1519 else
1521 if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1522 (dtp->u.p.current_unit->delim_status != DELIM_NONE
1523 && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
1524 write_separator (dtp);
1527 switch (type)
1529 case BT_INTEGER:
1530 write_integer (dtp, p, kind);
1531 break;
1532 case BT_LOGICAL:
1533 write_logical (dtp, p, kind);
1534 break;
1535 case BT_CHARACTER:
1536 write_character (dtp, p, kind, size, DELIM);
1537 break;
1538 case BT_REAL:
1539 write_real (dtp, p, kind);
1540 break;
1541 case BT_COMPLEX:
1542 write_complex (dtp, p, kind, size);
1543 break;
1544 default:
1545 internal_error (&dtp->common, "list_formatted_write(): Bad type");
1548 fbuf_flush_list (dtp->u.p.current_unit, LIST_WRITING);
1549 dtp->u.p.char_flag = (type == BT_CHARACTER);
1553 void
1554 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1555 size_t size, size_t nelems)
1557 size_t elem;
1558 char *tmp;
1559 size_t stride = type == BT_CHARACTER ?
1560 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1562 tmp = (char *) p;
1564 /* Big loop over all the elements. */
1565 for (elem = 0; elem < nelems; elem++)
1567 dtp->u.p.item_count++;
1568 list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1572 /* NAMELIST OUTPUT
1574 nml_write_obj writes a namelist object to the output stream. It is called
1575 recursively for derived type components:
1576 obj = is the namelist_info for the current object.
1577 offset = the offset relative to the address held by the object for
1578 derived type arrays.
1579 base = is the namelist_info of the derived type, when obj is a
1580 component.
1581 base_name = the full name for a derived type, including qualifiers
1582 if any.
1583 The returned value is a pointer to the object beyond the last one
1584 accessed, including nested derived types. Notice that the namelist is
1585 a linear linked list of objects, including derived types and their
1586 components. A tree, of sorts, is implied by the compound names of
1587 the derived type components and this is how this function recurses through
1588 the list. */
1590 /* A generous estimate of the number of characters needed to print
1591 repeat counts and indices, including commas, asterices and brackets. */
1593 #define NML_DIGITS 20
1595 static void
1596 namelist_write_newline (st_parameter_dt *dtp)
1598 if (!is_internal_unit (dtp))
1600 #ifdef HAVE_CRLF
1601 write_character (dtp, "\r\n", 1, 2, NODELIM);
1602 #else
1603 write_character (dtp, "\n", 1, 1, NODELIM);
1604 #endif
1605 return;
1608 if (is_array_io (dtp))
1610 gfc_offset record;
1611 int finished;
1612 char *p;
1613 int length = dtp->u.p.current_unit->bytes_left;
1615 p = write_block (dtp, length);
1616 if (p == NULL)
1617 return;
1619 if (unlikely (is_char4_unit (dtp)))
1621 gfc_char4_t *p4 = (gfc_char4_t *) p;
1622 memset4 (p4, ' ', length);
1624 else
1625 memset (p, ' ', length);
1627 /* Now that the current record has been padded out,
1628 determine where the next record in the array is. */
1629 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1630 &finished);
1631 if (finished)
1632 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1633 else
1635 /* Now seek to this record */
1636 record = record * dtp->u.p.current_unit->recl;
1638 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1640 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1641 return;
1644 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1647 else
1648 write_character (dtp, " ", 1, 1, NODELIM);
1652 static namelist_info *
1653 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1654 namelist_info * base, char * base_name)
1656 int rep_ctr;
1657 int num;
1658 int nml_carry;
1659 int len;
1660 index_type obj_size;
1661 index_type nelem;
1662 size_t dim_i;
1663 size_t clen;
1664 index_type elem_ctr;
1665 size_t obj_name_len;
1666 void * p;
1667 char cup;
1668 char * obj_name;
1669 char * ext_name;
1670 char * q;
1671 size_t ext_name_len;
1672 char rep_buff[NML_DIGITS];
1673 namelist_info * cmp;
1674 namelist_info * retval = obj->next;
1675 size_t base_name_len;
1676 size_t base_var_name_len;
1677 size_t tot_len;
1679 /* Set the character to be used to separate values
1680 to a comma or semi-colon. */
1682 char semi_comma =
1683 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1685 /* Write namelist variable names in upper case. If a derived type,
1686 nothing is output. If a component, base and base_name are set. */
1688 if (obj->type != BT_DERIVED)
1690 namelist_write_newline (dtp);
1691 write_character (dtp, " ", 1, 1, NODELIM);
1693 len = 0;
1694 if (base)
1696 len = strlen (base->var_name);
1697 base_name_len = strlen (base_name);
1698 for (dim_i = 0; dim_i < base_name_len; dim_i++)
1700 cup = toupper ((int) base_name[dim_i]);
1701 write_character (dtp, &cup, 1, 1, NODELIM);
1704 clen = strlen (obj->var_name);
1705 for (dim_i = len; dim_i < clen; dim_i++)
1707 cup = toupper ((int) obj->var_name[dim_i]);
1708 if (cup == '+')
1709 cup = '%';
1710 write_character (dtp, &cup, 1, 1, NODELIM);
1712 write_character (dtp, "=", 1, 1, NODELIM);
1715 /* Counts the number of data output on a line, including names. */
1717 num = 1;
1719 len = obj->len;
1721 switch (obj->type)
1724 case BT_REAL:
1725 obj_size = size_from_real_kind (len);
1726 break;
1728 case BT_COMPLEX:
1729 obj_size = size_from_complex_kind (len);
1730 break;
1732 case BT_CHARACTER:
1733 obj_size = obj->string_length;
1734 break;
1736 default:
1737 obj_size = len;
1740 if (obj->var_rank)
1741 obj_size = obj->size;
1743 /* Set the index vector and count the number of elements. */
1745 nelem = 1;
1746 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1748 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
1749 nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
1752 /* Main loop to output the data held in the object. */
1754 rep_ctr = 1;
1755 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1758 /* Build the pointer to the data value. The offset is passed by
1759 recursive calls to this function for arrays of derived types.
1760 Is NULL otherwise. */
1762 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1763 p += offset;
1765 /* Check for repeat counts of intrinsic types. */
1767 if ((elem_ctr < (nelem - 1)) &&
1768 (obj->type != BT_DERIVED) &&
1769 !memcmp (p, (void*)(p + obj_size ), obj_size ))
1771 rep_ctr++;
1774 /* Execute a repeated output. Note the flag no_leading_blank that
1775 is used in the functions used to output the intrinsic types. */
1777 else
1779 if (rep_ctr > 1)
1781 snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
1782 write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
1783 dtp->u.p.no_leading_blank = 1;
1785 num++;
1787 /* Output the data, if an intrinsic type, or recurse into this
1788 routine to treat derived types. */
1790 switch (obj->type)
1793 case BT_INTEGER:
1794 write_integer (dtp, p, len);
1795 break;
1797 case BT_LOGICAL:
1798 write_logical (dtp, p, len);
1799 break;
1801 case BT_CHARACTER:
1802 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1803 write_character (dtp, p, 4, obj->string_length, DELIM);
1804 else
1805 write_character (dtp, p, 1, obj->string_length, DELIM);
1806 break;
1808 case BT_REAL:
1809 write_real (dtp, p, len);
1810 break;
1812 case BT_COMPLEX:
1813 dtp->u.p.no_leading_blank = 0;
1814 num++;
1815 write_complex (dtp, p, len, obj_size);
1816 break;
1818 case BT_DERIVED:
1820 /* To treat a derived type, we need to build two strings:
1821 ext_name = the name, including qualifiers that prepends
1822 component names in the output - passed to
1823 nml_write_obj.
1824 obj_name = the derived type name with no qualifiers but %
1825 appended. This is used to identify the
1826 components. */
1828 /* First ext_name => get length of all possible components */
1830 base_name_len = base_name ? strlen (base_name) : 0;
1831 base_var_name_len = base ? strlen (base->var_name) : 0;
1832 ext_name_len = base_name_len + base_var_name_len
1833 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
1834 ext_name = xmalloc (ext_name_len);
1836 if (base_name)
1837 memcpy (ext_name, base_name, base_name_len);
1838 clen = strlen (obj->var_name + base_var_name_len);
1839 memcpy (ext_name + base_name_len,
1840 obj->var_name + base_var_name_len, clen);
1842 /* Append the qualifier. */
1844 tot_len = base_name_len + clen;
1845 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1847 if (!dim_i)
1849 ext_name[tot_len] = '(';
1850 tot_len++;
1852 snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
1853 (int) obj->ls[dim_i].idx);
1854 tot_len += strlen (ext_name + tot_len);
1855 ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
1856 tot_len++;
1859 ext_name[tot_len] = '\0';
1860 for (q = ext_name; *q; q++)
1861 if (*q == '+')
1862 *q = '%';
1864 /* Now obj_name. */
1866 obj_name_len = strlen (obj->var_name) + 1;
1867 obj_name = xmalloc (obj_name_len + 1);
1868 memcpy (obj_name, obj->var_name, obj_name_len-1);
1869 memcpy (obj_name + obj_name_len-1, "%", 2);
1871 /* Now loop over the components. Update the component pointer
1872 with the return value from nml_write_obj => this loop jumps
1873 past nested derived types. */
1875 for (cmp = obj->next;
1876 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1877 cmp = retval)
1879 retval = nml_write_obj (dtp, cmp,
1880 (index_type)(p - obj->mem_pos),
1881 obj, ext_name);
1884 free (obj_name);
1885 free (ext_name);
1886 goto obj_loop;
1888 default:
1889 internal_error (&dtp->common, "Bad type for namelist write");
1892 /* Reset the leading blank suppression, write a comma (or semi-colon)
1893 and, if 5 values have been output, write a newline and advance
1894 to column 2. Reset the repeat counter. */
1896 dtp->u.p.no_leading_blank = 0;
1897 if (obj->type == BT_CHARACTER)
1899 if (dtp->u.p.nml_delim != '\0')
1900 write_character (dtp, &semi_comma, 1, 1, NODELIM);
1902 else
1903 write_character (dtp, &semi_comma, 1, 1, NODELIM);
1904 if (num > 5)
1906 num = 0;
1907 if (dtp->u.p.nml_delim == '\0')
1908 write_character (dtp, &semi_comma, 1, 1, NODELIM);
1909 namelist_write_newline (dtp);
1910 write_character (dtp, " ", 1, 1, NODELIM);
1912 rep_ctr = 1;
1915 /* Cycle through and increment the index vector. */
1917 obj_loop:
1919 nml_carry = 1;
1920 for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
1922 obj->ls[dim_i].idx += nml_carry ;
1923 nml_carry = 0;
1924 if (obj->ls[dim_i].idx > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
1926 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
1927 nml_carry = 1;
1932 /* Return a pointer beyond the furthest object accessed. */
1934 return retval;
1938 /* This is the entry function for namelist writes. It outputs the name
1939 of the namelist and iterates through the namelist by calls to
1940 nml_write_obj. The call below has dummys in the arguments used in
1941 the treatment of derived types. */
1943 void
1944 namelist_write (st_parameter_dt *dtp)
1946 namelist_info * t1, *t2, *dummy = NULL;
1947 index_type i;
1948 index_type dummy_offset = 0;
1949 char c;
1950 char * dummy_name = NULL;
1952 /* Set the delimiter for namelist output. */
1953 switch (dtp->u.p.current_unit->delim_status)
1955 case DELIM_APOSTROPHE:
1956 dtp->u.p.nml_delim = '\'';
1957 break;
1958 case DELIM_QUOTE:
1959 case DELIM_UNSPECIFIED:
1960 dtp->u.p.nml_delim = '"';
1961 break;
1962 default:
1963 dtp->u.p.nml_delim = '\0';
1966 write_character (dtp, "&", 1, 1, NODELIM);
1968 /* Write namelist name in upper case - f95 std. */
1969 for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1971 c = toupper ((int) dtp->namelist_name[i]);
1972 write_character (dtp, &c, 1 ,1, NODELIM);
1975 if (dtp->u.p.ionml != NULL)
1977 t1 = dtp->u.p.ionml;
1978 while (t1 != NULL)
1980 t2 = t1;
1981 t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1985 namelist_write_newline (dtp);
1986 write_character (dtp, " /", 1, 2, NODELIM);
1989 #undef NML_DIGITS