Fix aarch64_evpc_tbl guard (PR 85910)
[official-gcc.git] / libgfortran / io / write.c
blobdc6a234f42e958751beee5facaaf28b60abf1826
1 /* Copyright (C) 2002-2018 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>
35 #define star_fill(p, n) memset(p, '*', n)
37 typedef unsigned char uchar;
39 /* Helper functions for character(kind=4) internal units. These are needed
40 by write_float.def. */
42 static void
43 memcpy4 (gfc_char4_t *dest, const char *source, int k)
45 int j;
47 const char *p = source;
48 for (j = 0; j < k; j++)
49 *dest++ = (gfc_char4_t) *p++;
52 /* This include contains the heart and soul of formatted floating point. */
53 #include "write_float.def"
55 /* Write out default char4. */
57 static void
58 write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
59 int src_len, int w_len)
61 char *p;
62 int j, k = 0;
63 gfc_char4_t c;
64 uchar d;
66 /* Take care of preceding blanks. */
67 if (w_len > src_len)
69 k = w_len - src_len;
70 p = write_block (dtp, k);
71 if (p == NULL)
72 return;
73 if (is_char4_unit (dtp))
75 gfc_char4_t *p4 = (gfc_char4_t *) p;
76 memset4 (p4, ' ', k);
78 else
79 memset (p, ' ', k);
82 /* Get ready to handle delimiters if needed. */
83 switch (dtp->u.p.current_unit->delim_status)
85 case DELIM_APOSTROPHE:
86 d = '\'';
87 break;
88 case DELIM_QUOTE:
89 d = '"';
90 break;
91 default:
92 d = ' ';
93 break;
96 /* Now process the remaining characters, one at a time. */
97 for (j = 0; j < src_len; j++)
99 c = source[j];
100 if (is_char4_unit (dtp))
102 gfc_char4_t *q;
103 /* Handle delimiters if any. */
104 if (c == d && d != ' ')
106 p = write_block (dtp, 2);
107 if (p == NULL)
108 return;
109 q = (gfc_char4_t *) p;
110 *q++ = c;
112 else
114 p = write_block (dtp, 1);
115 if (p == NULL)
116 return;
117 q = (gfc_char4_t *) p;
119 *q = c;
121 else
123 /* Handle delimiters if any. */
124 if (c == d && d != ' ')
126 p = write_block (dtp, 2);
127 if (p == NULL)
128 return;
129 *p++ = (uchar) c;
131 else
133 p = write_block (dtp, 1);
134 if (p == NULL)
135 return;
137 *p = c > 255 ? '?' : (uchar) c;
143 /* Write out UTF-8 converted from char4. */
145 static void
146 write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
147 int src_len, int w_len)
149 char *p;
150 int j, k = 0;
151 gfc_char4_t c;
152 static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
153 static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
154 int nbytes;
155 uchar buf[6], d, *q;
157 /* Take care of preceding blanks. */
158 if (w_len > src_len)
160 k = w_len - src_len;
161 p = write_block (dtp, k);
162 if (p == NULL)
163 return;
164 memset (p, ' ', k);
167 /* Get ready to handle delimiters if needed. */
168 switch (dtp->u.p.current_unit->delim_status)
170 case DELIM_APOSTROPHE:
171 d = '\'';
172 break;
173 case DELIM_QUOTE:
174 d = '"';
175 break;
176 default:
177 d = ' ';
178 break;
181 /* Now process the remaining characters, one at a time. */
182 for (j = k; j < src_len; j++)
184 c = source[j];
185 if (c < 0x80)
187 /* Handle the delimiters if any. */
188 if (c == d && d != ' ')
190 p = write_block (dtp, 2);
191 if (p == NULL)
192 return;
193 *p++ = (uchar) c;
195 else
197 p = write_block (dtp, 1);
198 if (p == NULL)
199 return;
201 *p = (uchar) c;
203 else
205 /* Convert to UTF-8 sequence. */
206 nbytes = 1;
207 q = &buf[6];
211 *--q = ((c & 0x3F) | 0x80);
212 c >>= 6;
213 nbytes++;
215 while (c >= 0x3F || (c & limits[nbytes-1]));
217 *--q = (c | masks[nbytes-1]);
219 p = write_block (dtp, nbytes);
220 if (p == NULL)
221 return;
223 while (q < &buf[6])
224 *p++ = *q++;
230 /* Check the first character in source if we are using CC_FORTRAN
231 and set the cc.type appropriately. The cc.type is used later by write_cc
232 to determine the output start-of-record, and next_record_cc to determine the
233 output end-of-record.
234 This function is called before the output buffer is allocated, so alloc_len
235 is set to the appropriate size to allocate. */
237 static void
238 write_check_cc (st_parameter_dt *dtp, const char **source, size_t *alloc_len)
240 /* Only valid for CARRIAGECONTROL=FORTRAN. */
241 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN
242 || alloc_len == NULL || source == NULL)
243 return;
245 /* Peek at the first character. */
246 int c = (*alloc_len > 0) ? (*source)[0] : EOF;
247 if (c != EOF)
249 /* The start-of-record character which will be printed. */
250 dtp->u.p.cc.u.start = '\n';
251 /* The number of characters to print at the start-of-record.
252 len > 1 means copy the SOR character multiple times.
253 len == 0 means no SOR will be output. */
254 dtp->u.p.cc.len = 1;
256 switch (c)
258 case '+':
259 dtp->u.p.cc.type = CCF_OVERPRINT;
260 dtp->u.p.cc.len = 0;
261 break;
262 case '-':
263 dtp->u.p.cc.type = CCF_ONE_LF;
264 dtp->u.p.cc.len = 1;
265 break;
266 case '0':
267 dtp->u.p.cc.type = CCF_TWO_LF;
268 dtp->u.p.cc.len = 2;
269 break;
270 case '1':
271 dtp->u.p.cc.type = CCF_PAGE_FEED;
272 dtp->u.p.cc.len = 1;
273 dtp->u.p.cc.u.start = '\f';
274 break;
275 case '$':
276 dtp->u.p.cc.type = CCF_PROMPT;
277 dtp->u.p.cc.len = 1;
278 break;
279 case '\0':
280 dtp->u.p.cc.type = CCF_OVERPRINT_NOA;
281 dtp->u.p.cc.len = 0;
282 break;
283 default:
284 /* In the default case we copy ONE_LF. */
285 dtp->u.p.cc.type = CCF_DEFAULT;
286 dtp->u.p.cc.len = 1;
287 break;
290 /* We add n-1 to alloc_len so our write buffer is the right size.
291 We are replacing the first character, and possibly prepending some
292 additional characters. Note for n==0, we actually subtract one from
293 alloc_len, which is correct, since that character is skipped. */
294 if (*alloc_len > 0)
296 *source += 1;
297 *alloc_len += dtp->u.p.cc.len - 1;
299 /* If we have no input, there is no first character to replace. Make
300 sure we still allocate enough space for the start-of-record string. */
301 else
302 *alloc_len = dtp->u.p.cc.len;
307 /* Write the start-of-record character(s) for CC_FORTRAN.
308 Also adjusts the 'cc' struct to contain the end-of-record character
309 for next_record_cc.
310 The source_len is set to the remaining length to copy from the source,
311 after the start-of-record string was inserted. */
313 static char *
314 write_cc (st_parameter_dt *dtp, char *p, size_t *source_len)
316 /* Only valid for CARRIAGECONTROL=FORTRAN. */
317 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN || source_len == NULL)
318 return p;
320 /* Write the start-of-record string to the output buffer. Note that len is
321 never more than 2. */
322 if (dtp->u.p.cc.len > 0)
324 *(p++) = dtp->u.p.cc.u.start;
325 if (dtp->u.p.cc.len > 1)
326 *(p++) = dtp->u.p.cc.u.start;
328 /* source_len comes from write_check_cc where it is set to the full
329 allocated length of the output buffer. Therefore we subtract off the
330 length of the SOR string to obtain the remaining source length. */
331 *source_len -= dtp->u.p.cc.len;
334 /* Common case. */
335 dtp->u.p.cc.len = 1;
336 dtp->u.p.cc.u.end = '\r';
338 /* Update end-of-record character for next_record_w. */
339 switch (dtp->u.p.cc.type)
341 case CCF_PROMPT:
342 case CCF_OVERPRINT_NOA:
343 /* No end-of-record. */
344 dtp->u.p.cc.len = 0;
345 dtp->u.p.cc.u.end = '\0';
346 break;
347 case CCF_OVERPRINT:
348 case CCF_ONE_LF:
349 case CCF_TWO_LF:
350 case CCF_PAGE_FEED:
351 case CCF_DEFAULT:
352 default:
353 /* Carriage return. */
354 dtp->u.p.cc.len = 1;
355 dtp->u.p.cc.u.end = '\r';
356 break;
359 return p;
362 void
364 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
366 size_t wlen;
367 char *p;
369 wlen = f->u.string.length < 0
370 || (f->format == FMT_G && f->u.string.length == 0)
371 ? len : (size_t) f->u.string.length;
373 #ifdef HAVE_CRLF
374 /* If this is formatted STREAM IO convert any embedded line feed characters
375 to CR_LF on systems that use that sequence for newlines. See F2003
376 Standard sections 10.6.3 and 9.9 for further information. */
377 if (is_stream_io (dtp))
379 const char crlf[] = "\r\n";
380 size_t q, bytes;
381 q = bytes = 0;
383 /* Write out any padding if needed. */
384 if (len < wlen)
386 p = write_block (dtp, wlen - len);
387 if (p == NULL)
388 return;
389 memset (p, ' ', wlen - len);
392 /* Scan the source string looking for '\n' and convert it if found. */
393 for (size_t i = 0; i < wlen; i++)
395 if (source[i] == '\n')
397 /* Write out the previously scanned characters in the string. */
398 if (bytes > 0)
400 p = write_block (dtp, bytes);
401 if (p == NULL)
402 return;
403 memcpy (p, &source[q], bytes);
404 q += bytes;
405 bytes = 0;
408 /* Write out the CR_LF sequence. */
409 q++;
410 p = write_block (dtp, 2);
411 if (p == NULL)
412 return;
413 memcpy (p, crlf, 2);
415 else
416 bytes++;
419 /* Write out any remaining bytes if no LF was found. */
420 if (bytes > 0)
422 p = write_block (dtp, bytes);
423 if (p == NULL)
424 return;
425 memcpy (p, &source[q], bytes);
428 else
430 #endif
431 if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
432 write_check_cc (dtp, &source, &wlen);
434 p = write_block (dtp, wlen);
435 if (p == NULL)
436 return;
438 if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
439 p = write_cc (dtp, p, &wlen);
441 if (unlikely (is_char4_unit (dtp)))
443 gfc_char4_t *p4 = (gfc_char4_t *) p;
444 if (wlen < len)
445 memcpy4 (p4, source, wlen);
446 else
448 memset4 (p4, ' ', wlen - len);
449 memcpy4 (p4 + wlen - len, source, len);
451 return;
454 if (wlen < len)
455 memcpy (p, source, wlen);
456 else
458 memset (p, ' ', wlen - len);
459 memcpy (p + wlen - len, source, len);
461 #ifdef HAVE_CRLF
463 #endif
467 /* The primary difference between write_a_char4 and write_a is that we have to
468 deal with writing from the first byte of the 4-byte character and pay
469 attention to the most significant bytes. For ENCODING="default" write the
470 lowest significant byte. If the 3 most significant bytes contain
471 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
472 to the UTF-8 encoded string before writing out. */
474 void
475 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
477 size_t wlen;
478 gfc_char4_t *q;
480 wlen = f->u.string.length < 0
481 || (f->format == FMT_G && f->u.string.length == 0)
482 ? len : (size_t) f->u.string.length;
484 q = (gfc_char4_t *) source;
485 #ifdef HAVE_CRLF
486 /* If this is formatted STREAM IO convert any embedded line feed characters
487 to CR_LF on systems that use that sequence for newlines. See F2003
488 Standard sections 10.6.3 and 9.9 for further information. */
489 if (is_stream_io (dtp))
491 const gfc_char4_t crlf[] = {0x000d,0x000a};
492 size_t bytes;
493 gfc_char4_t *qq;
494 bytes = 0;
496 /* Write out any padding if needed. */
497 if (len < wlen)
499 char *p;
500 p = write_block (dtp, wlen - len);
501 if (p == NULL)
502 return;
503 memset (p, ' ', wlen - len);
506 /* Scan the source string looking for '\n' and convert it if found. */
507 qq = (gfc_char4_t *) source;
508 for (size_t i = 0; i < wlen; i++)
510 if (qq[i] == '\n')
512 /* Write out the previously scanned characters in the string. */
513 if (bytes > 0)
515 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
516 write_utf8_char4 (dtp, q, bytes, 0);
517 else
518 write_default_char4 (dtp, q, bytes, 0);
519 bytes = 0;
522 /* Write out the CR_LF sequence. */
523 write_default_char4 (dtp, crlf, 2, 0);
525 else
526 bytes++;
529 /* Write out any remaining bytes if no LF was found. */
530 if (bytes > 0)
532 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
533 write_utf8_char4 (dtp, q, bytes, 0);
534 else
535 write_default_char4 (dtp, q, bytes, 0);
538 else
540 #endif
541 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
542 write_utf8_char4 (dtp, q, len, wlen);
543 else
544 write_default_char4 (dtp, q, len, wlen);
545 #ifdef HAVE_CRLF
547 #endif
551 static GFC_INTEGER_LARGEST
552 extract_int (const void *p, int len)
554 GFC_INTEGER_LARGEST i = 0;
556 if (p == NULL)
557 return i;
559 switch (len)
561 case 1:
563 GFC_INTEGER_1 tmp;
564 memcpy ((void *) &tmp, p, len);
565 i = tmp;
567 break;
568 case 2:
570 GFC_INTEGER_2 tmp;
571 memcpy ((void *) &tmp, p, len);
572 i = tmp;
574 break;
575 case 4:
577 GFC_INTEGER_4 tmp;
578 memcpy ((void *) &tmp, p, len);
579 i = tmp;
581 break;
582 case 8:
584 GFC_INTEGER_8 tmp;
585 memcpy ((void *) &tmp, p, len);
586 i = tmp;
588 break;
589 #ifdef HAVE_GFC_INTEGER_16
590 case 16:
592 GFC_INTEGER_16 tmp;
593 memcpy ((void *) &tmp, p, len);
594 i = tmp;
596 break;
597 #endif
598 default:
599 internal_error (NULL, "bad integer kind");
602 return i;
605 static GFC_UINTEGER_LARGEST
606 extract_uint (const void *p, int len)
608 GFC_UINTEGER_LARGEST i = 0;
610 if (p == NULL)
611 return i;
613 switch (len)
615 case 1:
617 GFC_INTEGER_1 tmp;
618 memcpy ((void *) &tmp, p, len);
619 i = (GFC_UINTEGER_1) tmp;
621 break;
622 case 2:
624 GFC_INTEGER_2 tmp;
625 memcpy ((void *) &tmp, p, len);
626 i = (GFC_UINTEGER_2) tmp;
628 break;
629 case 4:
631 GFC_INTEGER_4 tmp;
632 memcpy ((void *) &tmp, p, len);
633 i = (GFC_UINTEGER_4) tmp;
635 break;
636 case 8:
638 GFC_INTEGER_8 tmp;
639 memcpy ((void *) &tmp, p, len);
640 i = (GFC_UINTEGER_8) tmp;
642 break;
643 #ifdef HAVE_GFC_INTEGER_16
644 case 10:
645 case 16:
647 GFC_INTEGER_16 tmp = 0;
648 memcpy ((void *) &tmp, p, len);
649 i = (GFC_UINTEGER_16) tmp;
651 break;
652 #endif
653 default:
654 internal_error (NULL, "bad integer kind");
657 return i;
661 void
662 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
664 char *p;
665 int wlen;
666 GFC_INTEGER_LARGEST n;
668 wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
670 p = write_block (dtp, wlen);
671 if (p == NULL)
672 return;
674 n = extract_int (source, len);
676 if (unlikely (is_char4_unit (dtp)))
678 gfc_char4_t *p4 = (gfc_char4_t *) p;
679 memset4 (p4, ' ', wlen -1);
680 p4[wlen - 1] = (n) ? 'T' : 'F';
681 return;
684 memset (p, ' ', wlen -1);
685 p[wlen - 1] = (n) ? 'T' : 'F';
689 static void
690 write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
692 int w, m, digits, nzero, nblank;
693 char *p;
695 w = f->u.integer.w;
696 m = f->u.integer.m;
698 /* Special case: */
700 if (m == 0 && n == 0)
702 if (w == 0)
703 w = 1;
705 p = write_block (dtp, w);
706 if (p == NULL)
707 return;
708 if (unlikely (is_char4_unit (dtp)))
710 gfc_char4_t *p4 = (gfc_char4_t *) p;
711 memset4 (p4, ' ', w);
713 else
714 memset (p, ' ', w);
715 goto done;
718 digits = strlen (q);
720 /* Select a width if none was specified. The idea here is to always
721 print something. */
723 if (w == 0)
724 w = ((digits < m) ? m : digits);
726 p = write_block (dtp, w);
727 if (p == NULL)
728 return;
730 nzero = 0;
731 if (digits < m)
732 nzero = m - digits;
734 /* See if things will work. */
736 nblank = w - (nzero + digits);
738 if (unlikely (is_char4_unit (dtp)))
740 gfc_char4_t *p4 = (gfc_char4_t *) p;
741 if (nblank < 0)
743 memset4 (p4, '*', w);
744 return;
747 if (!dtp->u.p.no_leading_blank)
749 memset4 (p4, ' ', nblank);
750 q += nblank;
751 memset4 (p4, '0', nzero);
752 q += nzero;
753 memcpy4 (p4, q, digits);
755 else
757 memset4 (p4, '0', nzero);
758 q += nzero;
759 memcpy4 (p4, q, digits);
760 q += digits;
761 memset4 (p4, ' ', nblank);
762 dtp->u.p.no_leading_blank = 0;
764 return;
767 if (nblank < 0)
769 star_fill (p, w);
770 goto done;
773 if (!dtp->u.p.no_leading_blank)
775 memset (p, ' ', nblank);
776 p += nblank;
777 memset (p, '0', nzero);
778 p += nzero;
779 memcpy (p, q, digits);
781 else
783 memset (p, '0', nzero);
784 p += nzero;
785 memcpy (p, q, digits);
786 p += digits;
787 memset (p, ' ', nblank);
788 dtp->u.p.no_leading_blank = 0;
791 done:
792 return;
795 static void
796 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
797 int len,
798 const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
800 GFC_INTEGER_LARGEST n = 0;
801 int w, m, digits, nsign, nzero, nblank;
802 char *p;
803 const char *q;
804 sign_t sign;
805 char itoa_buf[GFC_BTOA_BUF_SIZE];
807 w = f->u.integer.w;
808 m = f->format == FMT_G ? -1 : f->u.integer.m;
810 n = extract_int (source, len);
812 /* Special case: */
813 if (m == 0 && n == 0)
815 if (w == 0)
816 w = 1;
818 p = write_block (dtp, w);
819 if (p == NULL)
820 return;
821 if (unlikely (is_char4_unit (dtp)))
823 gfc_char4_t *p4 = (gfc_char4_t *) p;
824 memset4 (p4, ' ', w);
826 else
827 memset (p, ' ', w);
828 goto done;
831 sign = calculate_sign (dtp, n < 0);
832 if (n < 0)
833 n = -n;
834 nsign = sign == S_NONE ? 0 : 1;
836 /* conv calls itoa which sets the negative sign needed
837 by write_integer. The sign '+' or '-' is set below based on sign
838 calculated above, so we just point past the sign in the string
839 before proceeding to avoid double signs in corner cases.
840 (see PR38504) */
841 q = conv (n, itoa_buf, sizeof (itoa_buf));
842 if (*q == '-')
843 q++;
845 digits = strlen (q);
847 /* Select a width if none was specified. The idea here is to always
848 print something. */
850 if (w == 0)
851 w = ((digits < m) ? m : digits) + nsign;
853 p = write_block (dtp, w);
854 if (p == NULL)
855 return;
857 nzero = 0;
858 if (digits < m)
859 nzero = m - digits;
861 /* See if things will work. */
863 nblank = w - (nsign + nzero + digits);
865 if (unlikely (is_char4_unit (dtp)))
867 gfc_char4_t *p4 = (gfc_char4_t *)p;
868 if (nblank < 0)
870 memset4 (p4, '*', w);
871 goto done;
874 if (!dtp->u.p.namelist_mode)
876 memset4 (p4, ' ', nblank);
877 p4 += nblank;
880 switch (sign)
882 case S_PLUS:
883 *p4++ = '+';
884 break;
885 case S_MINUS:
886 *p4++ = '-';
887 break;
888 case S_NONE:
889 break;
892 memset4 (p4, '0', nzero);
893 p4 += nzero;
895 memcpy4 (p4, q, digits);
896 return;
898 if (dtp->u.p.namelist_mode)
900 p4 += digits;
901 memset4 (p4, ' ', nblank);
905 if (nblank < 0)
907 star_fill (p, w);
908 goto done;
911 if (!dtp->u.p.namelist_mode)
913 memset (p, ' ', nblank);
914 p += nblank;
917 switch (sign)
919 case S_PLUS:
920 *p++ = '+';
921 break;
922 case S_MINUS:
923 *p++ = '-';
924 break;
925 case S_NONE:
926 break;
929 memset (p, '0', nzero);
930 p += nzero;
932 memcpy (p, q, digits);
934 if (dtp->u.p.namelist_mode)
936 p += digits;
937 memset (p, ' ', nblank);
940 done:
941 return;
945 /* Convert unsigned octal to ascii. */
947 static const char *
948 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
950 char *p;
952 assert (len >= GFC_OTOA_BUF_SIZE);
954 if (n == 0)
955 return "0";
957 p = buffer + GFC_OTOA_BUF_SIZE - 1;
958 *p = '\0';
960 while (n != 0)
962 *--p = '0' + (n & 7);
963 n >>= 3;
966 return p;
970 /* Convert unsigned binary to ascii. */
972 static const char *
973 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
975 char *p;
977 assert (len >= GFC_BTOA_BUF_SIZE);
979 if (n == 0)
980 return "0";
982 p = buffer + GFC_BTOA_BUF_SIZE - 1;
983 *p = '\0';
985 while (n != 0)
987 *--p = '0' + (n & 1);
988 n >>= 1;
991 return p;
994 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
995 to convert large reals with kind sizes that exceed the largest integer type
996 available on certain platforms. In these cases, byte by byte conversion is
997 performed. Endianess is taken into account. */
999 /* Conversion to binary. */
1001 static const char *
1002 btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
1004 char *q;
1005 int i, j;
1007 q = buffer;
1008 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
1010 const char *p = s;
1011 for (i = 0; i < len; i++)
1013 char c = *p;
1015 /* Test for zero. Needed by write_boz later. */
1016 if (*p != 0)
1017 *n = 1;
1019 for (j = 0; j < 8; j++)
1021 *q++ = (c & 128) ? '1' : '0';
1022 c <<= 1;
1024 p++;
1027 else
1029 const char *p = s + len - 1;
1030 for (i = 0; i < len; i++)
1032 char c = *p;
1034 /* Test for zero. Needed by write_boz later. */
1035 if (*p != 0)
1036 *n = 1;
1038 for (j = 0; j < 8; j++)
1040 *q++ = (c & 128) ? '1' : '0';
1041 c <<= 1;
1043 p--;
1047 *q = '\0';
1049 if (*n == 0)
1050 return "0";
1052 /* Move past any leading zeros. */
1053 while (*buffer == '0')
1054 buffer++;
1056 return buffer;
1060 /* Conversion to octal. */
1062 static const char *
1063 otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
1065 char *q;
1066 int i, j, k;
1067 uint8_t octet;
1069 q = buffer + GFC_OTOA_BUF_SIZE - 1;
1070 *q = '\0';
1071 i = k = octet = 0;
1073 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
1075 const char *p = s + len - 1;
1076 char c = *p;
1077 while (i < len)
1079 /* Test for zero. Needed by write_boz later. */
1080 if (*p != 0)
1081 *n = 1;
1083 for (j = 0; j < 3 && i < len; j++)
1085 octet |= (c & 1) << j;
1086 c >>= 1;
1087 if (++k > 7)
1089 i++;
1090 k = 0;
1091 c = *--p;
1094 *--q = '0' + octet;
1095 octet = 0;
1098 else
1100 const char *p = s;
1101 char c = *p;
1102 while (i < len)
1104 /* Test for zero. Needed by write_boz later. */
1105 if (*p != 0)
1106 *n = 1;
1108 for (j = 0; j < 3 && i < len; j++)
1110 octet |= (c & 1) << j;
1111 c >>= 1;
1112 if (++k > 7)
1114 i++;
1115 k = 0;
1116 c = *++p;
1119 *--q = '0' + octet;
1120 octet = 0;
1124 if (*n == 0)
1125 return "0";
1127 /* Move past any leading zeros. */
1128 while (*q == '0')
1129 q++;
1131 return q;
1134 /* Conversion to hexidecimal. */
1136 static const char *
1137 ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
1139 static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
1140 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1142 char *q;
1143 uint8_t h, l;
1144 int i;
1146 q = buffer;
1148 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
1150 const char *p = s;
1151 for (i = 0; i < len; i++)
1153 /* Test for zero. Needed by write_boz later. */
1154 if (*p != 0)
1155 *n = 1;
1157 h = (*p >> 4) & 0x0F;
1158 l = *p++ & 0x0F;
1159 *q++ = a[h];
1160 *q++ = a[l];
1163 else
1165 const char *p = s + len - 1;
1166 for (i = 0; i < len; i++)
1168 /* Test for zero. Needed by write_boz later. */
1169 if (*p != 0)
1170 *n = 1;
1172 h = (*p >> 4) & 0x0F;
1173 l = *p-- & 0x0F;
1174 *q++ = a[h];
1175 *q++ = a[l];
1179 *q = '\0';
1181 if (*n == 0)
1182 return "0";
1184 /* Move past any leading zeros. */
1185 while (*buffer == '0')
1186 buffer++;
1188 return buffer;
1192 void
1193 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1195 write_decimal (dtp, f, p, len, (void *) gfc_itoa);
1199 void
1200 write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1202 const char *p;
1203 char itoa_buf[GFC_BTOA_BUF_SIZE];
1204 GFC_UINTEGER_LARGEST n = 0;
1206 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1208 p = btoa_big (source, itoa_buf, len, &n);
1209 write_boz (dtp, f, p, n);
1211 else
1213 n = extract_uint (source, len);
1214 p = btoa (n, itoa_buf, sizeof (itoa_buf));
1215 write_boz (dtp, f, p, n);
1220 void
1221 write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1223 const char *p;
1224 char itoa_buf[GFC_OTOA_BUF_SIZE];
1225 GFC_UINTEGER_LARGEST n = 0;
1227 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1229 p = otoa_big (source, itoa_buf, len, &n);
1230 write_boz (dtp, f, p, n);
1232 else
1234 n = extract_uint (source, len);
1235 p = otoa (n, itoa_buf, sizeof (itoa_buf));
1236 write_boz (dtp, f, p, n);
1240 void
1241 write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1243 const char *p;
1244 char itoa_buf[GFC_XTOA_BUF_SIZE];
1245 GFC_UINTEGER_LARGEST n = 0;
1247 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1249 p = ztoa_big (source, itoa_buf, len, &n);
1250 write_boz (dtp, f, p, n);
1252 else
1254 n = extract_uint (source, len);
1255 p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
1256 write_boz (dtp, f, p, n);
1260 /* Take care of the X/TR descriptor. */
1262 void
1263 write_x (st_parameter_dt *dtp, int len, int nspaces)
1265 char *p;
1267 p = write_block (dtp, len);
1268 if (p == NULL)
1269 return;
1270 if (nspaces > 0 && len - nspaces >= 0)
1272 if (unlikely (is_char4_unit (dtp)))
1274 gfc_char4_t *p4 = (gfc_char4_t *) p;
1275 memset4 (&p4[len - nspaces], ' ', nspaces);
1277 else
1278 memset (&p[len - nspaces], ' ', nspaces);
1283 /* List-directed writing. */
1286 /* Write a single character to the output. Returns nonzero if
1287 something goes wrong. */
1289 static int
1290 write_char (st_parameter_dt *dtp, int c)
1292 char *p;
1294 p = write_block (dtp, 1);
1295 if (p == NULL)
1296 return 1;
1297 if (unlikely (is_char4_unit (dtp)))
1299 gfc_char4_t *p4 = (gfc_char4_t *) p;
1300 *p4 = c;
1301 return 0;
1304 *p = (uchar) c;
1306 return 0;
1310 /* Write a list-directed logical value. */
1312 static void
1313 write_logical (st_parameter_dt *dtp, const char *source, int length)
1315 write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1319 /* Write a list-directed integer value. */
1321 static void
1322 write_integer (st_parameter_dt *dtp, const char *source, int kind)
1324 int width;
1325 fnode f;
1327 switch (kind)
1329 case 1:
1330 width = 4;
1331 break;
1333 case 2:
1334 width = 6;
1335 break;
1337 case 4:
1338 width = 11;
1339 break;
1341 case 8:
1342 width = 20;
1343 break;
1345 default:
1346 width = 0;
1347 break;
1349 f.u.integer.w = width;
1350 f.u.integer.m = -1;
1351 f.format = FMT_NONE;
1352 write_decimal (dtp, &f, source, kind, (void *) gfc_itoa);
1356 /* Write a list-directed string. We have to worry about delimiting
1357 the strings if the file has been opened in that mode. */
1359 #define DELIM 1
1360 #define NODELIM 0
1362 static void
1363 write_character (st_parameter_dt *dtp, const char *source, int kind, size_t length, int mode)
1365 size_t extra;
1366 char *p, d;
1368 if (mode == DELIM)
1370 switch (dtp->u.p.current_unit->delim_status)
1372 case DELIM_APOSTROPHE:
1373 d = '\'';
1374 break;
1375 case DELIM_QUOTE:
1376 d = '"';
1377 break;
1378 default:
1379 d = ' ';
1380 break;
1383 else
1384 d = ' ';
1386 if (kind == 1)
1388 if (d == ' ')
1389 extra = 0;
1390 else
1392 extra = 2;
1394 for (size_t i = 0; i < length; i++)
1395 if (source[i] == d)
1396 extra++;
1399 p = write_block (dtp, length + extra);
1400 if (p == NULL)
1401 return;
1403 if (unlikely (is_char4_unit (dtp)))
1405 gfc_char4_t d4 = (gfc_char4_t) d;
1406 gfc_char4_t *p4 = (gfc_char4_t *) p;
1408 if (d4 == ' ')
1409 memcpy4 (p4, source, length);
1410 else
1412 *p4++ = d4;
1414 for (size_t i = 0; i < length; i++)
1416 *p4++ = (gfc_char4_t) source[i];
1417 if (source[i] == d)
1418 *p4++ = d4;
1421 *p4 = d4;
1423 return;
1426 if (d == ' ')
1427 memcpy (p, source, length);
1428 else
1430 *p++ = d;
1432 for (size_t i = 0; i < length; i++)
1434 *p++ = source[i];
1435 if (source[i] == d)
1436 *p++ = d;
1439 *p = d;
1442 else
1444 if (d == ' ')
1446 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1447 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1448 else
1449 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1451 else
1453 p = write_block (dtp, 1);
1454 *p = d;
1456 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1457 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1458 else
1459 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1461 p = write_block (dtp, 1);
1462 *p = d;
1467 /* Floating point helper functions. */
1469 #define BUF_STACK_SZ 384
1471 static int
1472 get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
1474 if (f->format != FMT_EN)
1475 return determine_precision (dtp, f, kind);
1476 else
1477 return determine_en_precision (dtp, f, source, kind);
1480 /* 4932 is the maximum exponent of long double and quad precision, 3
1481 extra characters for the sign, the decimal point, and the
1482 trailing null. Extra digits are added by the calling functions for
1483 requested precision. Likewise for float and double. F0 editing produces
1484 full precision output. */
1485 static int
1486 size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
1488 int size;
1490 if (f->format == FMT_F && f->u.real.w == 0)
1492 switch (kind)
1494 case 4:
1495 size = 38 + 3; /* These constants shown for clarity. */
1496 break;
1497 case 8:
1498 size = 308 + 3;
1499 break;
1500 case 10:
1501 size = 4932 + 3;
1502 break;
1503 case 16:
1504 size = 4932 + 3;
1505 break;
1506 default:
1507 internal_error (&dtp->common, "bad real kind");
1508 break;
1511 else
1512 size = f->u.real.w + 1; /* One byte for a NULL character. */
1514 return size;
1517 static char *
1518 select_buffer (st_parameter_dt *dtp, const fnode *f, int precision,
1519 char *buf, size_t *size, int kind)
1521 char *result;
1523 /* The buffer needs at least one more byte to allow room for
1524 normalizing and 1 to hold null terminator. */
1525 *size = size_from_kind (dtp, f, kind) + precision + 1 + 1;
1527 if (*size > BUF_STACK_SZ)
1528 result = xmalloc (*size);
1529 else
1530 result = buf;
1531 return result;
1534 static char *
1535 select_string (st_parameter_dt *dtp, const fnode *f, char *buf, size_t *size,
1536 int kind)
1538 char *result;
1539 *size = size_from_kind (dtp, f, kind) + f->u.real.d + 1;
1540 if (*size > BUF_STACK_SZ)
1541 result = xmalloc (*size);
1542 else
1543 result = buf;
1544 return result;
1547 static void
1548 write_float_string (st_parameter_dt *dtp, char *fstr, size_t len)
1550 char *p = write_block (dtp, len);
1551 if (p == NULL)
1552 return;
1554 if (unlikely (is_char4_unit (dtp)))
1556 gfc_char4_t *p4 = (gfc_char4_t *) p;
1557 memcpy4 (p4, fstr, len);
1558 return;
1560 memcpy (p, fstr, len);
1564 static void
1565 write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
1567 char buf_stack[BUF_STACK_SZ];
1568 char str_buf[BUF_STACK_SZ];
1569 char *buffer, *result;
1570 size_t buf_size, res_len, flt_str_len;
1572 /* Precision for snprintf call. */
1573 int precision = get_precision (dtp, f, source, kind);
1575 /* String buffer to hold final result. */
1576 result = select_string (dtp, f, str_buf, &res_len, kind);
1578 buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
1580 get_float_string (dtp, f, source , kind, 0, buffer,
1581 precision, buf_size, result, &flt_str_len);
1582 write_float_string (dtp, result, flt_str_len);
1584 if (buf_size > BUF_STACK_SZ)
1585 free (buffer);
1586 if (res_len > BUF_STACK_SZ)
1587 free (result);
1590 void
1591 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1593 write_float_0 (dtp, f, p, len);
1597 void
1598 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1600 write_float_0 (dtp, f, p, len);
1604 void
1605 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1607 write_float_0 (dtp, f, p, len);
1611 void
1612 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1614 write_float_0 (dtp, f, p, len);
1618 void
1619 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1621 write_float_0 (dtp, f, p, len);
1625 /* Set an fnode to default format. */
1627 static void
1628 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
1630 f->format = FMT_G;
1631 switch (length)
1633 case 4:
1634 f->u.real.w = 16;
1635 f->u.real.d = 9;
1636 f->u.real.e = 2;
1637 break;
1638 case 8:
1639 f->u.real.w = 25;
1640 f->u.real.d = 17;
1641 f->u.real.e = 3;
1642 break;
1643 case 10:
1644 f->u.real.w = 30;
1645 f->u.real.d = 21;
1646 f->u.real.e = 4;
1647 break;
1648 case 16:
1649 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1650 #if GFC_REAL_16_DIGITS == 113
1651 f->u.real.w = 45;
1652 f->u.real.d = 36;
1653 f->u.real.e = 4;
1654 #else
1655 f->u.real.w = 41;
1656 f->u.real.d = 32;
1657 f->u.real.e = 4;
1658 #endif
1659 break;
1660 default:
1661 internal_error (&dtp->common, "bad real kind");
1662 break;
1666 /* Output a real number with default format.
1667 To guarantee that a binary -> decimal -> binary roundtrip conversion
1668 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1669 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1670 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1671 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1672 Fortran standard requires outputting an extra digit when the scale
1673 factor is 1 and when the magnitude of the value is such that E
1674 editing is used. However, gfortran compensates for this, and thus
1675 for list formatted the same number of significant digits is
1676 generated both when using F and E editing. */
1678 void
1679 write_real (st_parameter_dt *dtp, const char *source, int kind)
1681 fnode f ;
1682 char buf_stack[BUF_STACK_SZ];
1683 char str_buf[BUF_STACK_SZ];
1684 char *buffer, *result;
1685 size_t buf_size, res_len, flt_str_len;
1686 int orig_scale = dtp->u.p.scale_factor;
1687 dtp->u.p.scale_factor = 1;
1688 set_fnode_default (dtp, &f, kind);
1690 /* Precision for snprintf call. */
1691 int precision = get_precision (dtp, &f, source, kind);
1693 /* String buffer to hold final result. */
1694 result = select_string (dtp, &f, str_buf, &res_len, kind);
1696 /* Scratch buffer to hold final result. */
1697 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
1699 get_float_string (dtp, &f, source , kind, 1, buffer,
1700 precision, buf_size, result, &flt_str_len);
1701 write_float_string (dtp, result, flt_str_len);
1703 dtp->u.p.scale_factor = orig_scale;
1704 if (buf_size > BUF_STACK_SZ)
1705 free (buffer);
1706 if (res_len > BUF_STACK_SZ)
1707 free (result);
1710 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1711 compensate for the extra digit. */
1713 void
1714 write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
1716 fnode f;
1717 char buf_stack[BUF_STACK_SZ];
1718 char str_buf[BUF_STACK_SZ];
1719 char *buffer, *result;
1720 size_t buf_size, res_len, flt_str_len;
1721 int comp_d;
1722 set_fnode_default (dtp, &f, kind);
1724 if (d > 0)
1725 f.u.real.d = d;
1727 /* Compensate for extra digits when using scale factor, d is not
1728 specified, and the magnitude is such that E editing is used. */
1729 if (dtp->u.p.scale_factor > 0 && d == 0)
1730 comp_d = 1;
1731 else
1732 comp_d = 0;
1733 dtp->u.p.g0_no_blanks = 1;
1735 /* Precision for snprintf call. */
1736 int precision = get_precision (dtp, &f, source, kind);
1738 /* String buffer to hold final result. */
1739 result = select_string (dtp, &f, str_buf, &res_len, kind);
1741 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
1743 get_float_string (dtp, &f, source , kind, comp_d, buffer,
1744 precision, buf_size, result, &flt_str_len);
1745 write_float_string (dtp, result, flt_str_len);
1747 dtp->u.p.g0_no_blanks = 0;
1748 if (buf_size > BUF_STACK_SZ)
1749 free (buffer);
1750 if (res_len > BUF_STACK_SZ)
1751 free (result);
1755 static void
1756 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1758 char semi_comma =
1759 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1761 /* Set for no blanks so we get a string result with no leading
1762 blanks. We will pad left later. */
1763 dtp->u.p.g0_no_blanks = 1;
1765 fnode f ;
1766 char buf_stack[BUF_STACK_SZ];
1767 char str1_buf[BUF_STACK_SZ];
1768 char str2_buf[BUF_STACK_SZ];
1769 char *buffer, *result1, *result2;
1770 size_t buf_size, res_len1, res_len2, flt_str_len1, flt_str_len2;
1771 int width, lblanks, orig_scale = dtp->u.p.scale_factor;
1773 dtp->u.p.scale_factor = 1;
1774 set_fnode_default (dtp, &f, kind);
1776 /* Set width for two values, parenthesis, and comma. */
1777 width = 2 * f.u.real.w + 3;
1779 /* Set for no blanks so we get a string result with no leading
1780 blanks. We will pad left later. */
1781 dtp->u.p.g0_no_blanks = 1;
1783 /* Precision for snprintf call. */
1784 int precision = get_precision (dtp, &f, source, kind);
1786 /* String buffers to hold final result. */
1787 result1 = select_string (dtp, &f, str1_buf, &res_len1, kind);
1788 result2 = select_string (dtp, &f, str2_buf, &res_len2, kind);
1790 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
1792 get_float_string (dtp, &f, source , kind, 0, buffer,
1793 precision, buf_size, result1, &flt_str_len1);
1794 get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
1795 precision, buf_size, result2, &flt_str_len2);
1796 if (!dtp->u.p.namelist_mode)
1798 lblanks = width - flt_str_len1 - flt_str_len2 - 3;
1799 write_x (dtp, lblanks, lblanks);
1801 write_char (dtp, '(');
1802 write_float_string (dtp, result1, flt_str_len1);
1803 write_char (dtp, semi_comma);
1804 write_float_string (dtp, result2, flt_str_len2);
1805 write_char (dtp, ')');
1807 dtp->u.p.scale_factor = orig_scale;
1808 dtp->u.p.g0_no_blanks = 0;
1809 if (buf_size > BUF_STACK_SZ)
1810 free (buffer);
1811 if (res_len1 > BUF_STACK_SZ)
1812 free (result1);
1813 if (res_len2 > BUF_STACK_SZ)
1814 free (result2);
1818 /* Write the separator between items. */
1820 static void
1821 write_separator (st_parameter_dt *dtp)
1823 char *p;
1825 p = write_block (dtp, options.separator_len);
1826 if (p == NULL)
1827 return;
1828 if (unlikely (is_char4_unit (dtp)))
1830 gfc_char4_t *p4 = (gfc_char4_t *) p;
1831 memcpy4 (p4, options.separator, options.separator_len);
1833 else
1834 memcpy (p, options.separator, options.separator_len);
1838 /* Write an item with list formatting.
1839 TODO: handle skipping to the next record correctly, particularly
1840 with strings. */
1842 static void
1843 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1844 size_t size)
1846 if (dtp->u.p.current_unit == NULL)
1847 return;
1849 if (dtp->u.p.first_item)
1851 dtp->u.p.first_item = 0;
1852 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
1853 write_char (dtp, ' ');
1855 else
1857 if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1858 (dtp->u.p.current_unit->delim_status != DELIM_NONE
1859 && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
1860 write_separator (dtp);
1863 switch (type)
1865 case BT_INTEGER:
1866 write_integer (dtp, p, kind);
1867 break;
1868 case BT_LOGICAL:
1869 write_logical (dtp, p, kind);
1870 break;
1871 case BT_CHARACTER:
1872 write_character (dtp, p, kind, size, DELIM);
1873 break;
1874 case BT_REAL:
1875 write_real (dtp, p, kind);
1876 break;
1877 case BT_COMPLEX:
1878 write_complex (dtp, p, kind, size);
1879 break;
1880 case BT_CLASS:
1882 int unit = dtp->u.p.current_unit->unit_number;
1883 char iotype[] = "LISTDIRECTED";
1884 gfc_charlen_type iotype_len = 12;
1885 char tmp_iomsg[IOMSG_LEN] = "";
1886 char *child_iomsg;
1887 gfc_charlen_type child_iomsg_len;
1888 int noiostat;
1889 int *child_iostat = NULL;
1890 gfc_full_array_i4 vlist;
1892 GFC_DESCRIPTOR_DATA(&vlist) = NULL;
1893 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
1895 /* Set iostat, intent(out). */
1896 noiostat = 0;
1897 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
1898 dtp->common.iostat : &noiostat;
1900 /* Set iomsge, intent(inout). */
1901 if (dtp->common.flags & IOPARM_HAS_IOMSG)
1903 child_iomsg = dtp->common.iomsg;
1904 child_iomsg_len = dtp->common.iomsg_len;
1906 else
1908 child_iomsg = tmp_iomsg;
1909 child_iomsg_len = IOMSG_LEN;
1912 /* Call the user defined formatted WRITE procedure. */
1913 dtp->u.p.current_unit->child_dtio++;
1914 dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
1915 child_iostat, child_iomsg,
1916 iotype_len, child_iomsg_len);
1917 dtp->u.p.current_unit->child_dtio--;
1919 break;
1920 default:
1921 internal_error (&dtp->common, "list_formatted_write(): Bad type");
1924 fbuf_flush_list (dtp->u.p.current_unit, LIST_WRITING);
1925 dtp->u.p.char_flag = (type == BT_CHARACTER);
1929 void
1930 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1931 size_t size, size_t nelems)
1933 size_t elem;
1934 char *tmp;
1935 size_t stride = type == BT_CHARACTER ?
1936 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1938 tmp = (char *) p;
1940 /* Big loop over all the elements. */
1941 for (elem = 0; elem < nelems; elem++)
1943 dtp->u.p.item_count++;
1944 list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1948 /* NAMELIST OUTPUT
1950 nml_write_obj writes a namelist object to the output stream. It is called
1951 recursively for derived type components:
1952 obj = is the namelist_info for the current object.
1953 offset = the offset relative to the address held by the object for
1954 derived type arrays.
1955 base = is the namelist_info of the derived type, when obj is a
1956 component.
1957 base_name = the full name for a derived type, including qualifiers
1958 if any.
1959 The returned value is a pointer to the object beyond the last one
1960 accessed, including nested derived types. Notice that the namelist is
1961 a linear linked list of objects, including derived types and their
1962 components. A tree, of sorts, is implied by the compound names of
1963 the derived type components and this is how this function recurses through
1964 the list. */
1966 /* A generous estimate of the number of characters needed to print
1967 repeat counts and indices, including commas, asterices and brackets. */
1969 #define NML_DIGITS 20
1971 static void
1972 namelist_write_newline (st_parameter_dt *dtp)
1974 if (!is_internal_unit (dtp))
1976 #ifdef HAVE_CRLF
1977 write_character (dtp, "\r\n", 1, 2, NODELIM);
1978 #else
1979 write_character (dtp, "\n", 1, 1, NODELIM);
1980 #endif
1981 return;
1984 if (is_array_io (dtp))
1986 gfc_offset record;
1987 int finished;
1988 char *p;
1989 int length = dtp->u.p.current_unit->bytes_left;
1991 p = write_block (dtp, length);
1992 if (p == NULL)
1993 return;
1995 if (unlikely (is_char4_unit (dtp)))
1997 gfc_char4_t *p4 = (gfc_char4_t *) p;
1998 memset4 (p4, ' ', length);
2000 else
2001 memset (p, ' ', length);
2003 /* Now that the current record has been padded out,
2004 determine where the next record in the array is. */
2005 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2006 &finished);
2007 if (finished)
2008 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2009 else
2011 /* Now seek to this record */
2012 record = record * dtp->u.p.current_unit->recl;
2014 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
2016 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2017 return;
2020 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2023 else
2024 write_character (dtp, " ", 1, 1, NODELIM);
2028 static namelist_info *
2029 nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
2030 namelist_info *base, char *base_name)
2032 int rep_ctr;
2033 int num;
2034 int nml_carry;
2035 int len;
2036 index_type obj_size;
2037 index_type nelem;
2038 size_t dim_i;
2039 size_t clen;
2040 index_type elem_ctr;
2041 size_t obj_name_len;
2042 void *p;
2043 char cup;
2044 char *obj_name;
2045 char *ext_name;
2046 char *q;
2047 size_t ext_name_len;
2048 char rep_buff[NML_DIGITS];
2049 namelist_info *cmp;
2050 namelist_info *retval = obj->next;
2051 size_t base_name_len;
2052 size_t base_var_name_len;
2053 size_t tot_len;
2055 /* Set the character to be used to separate values
2056 to a comma or semi-colon. */
2058 char semi_comma =
2059 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
2061 /* Write namelist variable names in upper case. If a derived type,
2062 nothing is output. If a component, base and base_name are set. */
2064 if (obj->type != BT_DERIVED || obj->dtio_sub != NULL)
2066 namelist_write_newline (dtp);
2067 write_character (dtp, " ", 1, 1, NODELIM);
2069 len = 0;
2070 if (base)
2072 len = strlen (base->var_name);
2073 base_name_len = strlen (base_name);
2074 for (dim_i = 0; dim_i < base_name_len; dim_i++)
2076 cup = toupper ((int) base_name[dim_i]);
2077 write_character (dtp, &cup, 1, 1, NODELIM);
2080 clen = strlen (obj->var_name);
2081 for (dim_i = len; dim_i < clen; dim_i++)
2083 cup = toupper ((int) obj->var_name[dim_i]);
2084 if (cup == '+')
2085 cup = '%';
2086 write_character (dtp, &cup, 1, 1, NODELIM);
2088 write_character (dtp, "=", 1, 1, NODELIM);
2091 /* Counts the number of data output on a line, including names. */
2093 num = 1;
2095 len = obj->len;
2097 switch (obj->type)
2100 case BT_REAL:
2101 obj_size = size_from_real_kind (len);
2102 break;
2104 case BT_COMPLEX:
2105 obj_size = size_from_complex_kind (len);
2106 break;
2108 case BT_CHARACTER:
2109 obj_size = obj->string_length;
2110 break;
2112 default:
2113 obj_size = len;
2116 if (obj->var_rank)
2117 obj_size = obj->size;
2119 /* Set the index vector and count the number of elements. */
2121 nelem = 1;
2122 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
2124 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
2125 nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
2128 /* Main loop to output the data held in the object. */
2130 rep_ctr = 1;
2131 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
2134 /* Build the pointer to the data value. The offset is passed by
2135 recursive calls to this function for arrays of derived types.
2136 Is NULL otherwise. */
2138 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
2139 p += offset;
2141 /* Check for repeat counts of intrinsic types. */
2143 if ((elem_ctr < (nelem - 1)) &&
2144 (obj->type != BT_DERIVED) &&
2145 !memcmp (p, (void *)(p + obj_size ), obj_size ))
2147 rep_ctr++;
2150 /* Execute a repeated output. Note the flag no_leading_blank that
2151 is used in the functions used to output the intrinsic types. */
2153 else
2155 if (rep_ctr > 1)
2157 snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
2158 write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
2159 dtp->u.p.no_leading_blank = 1;
2161 num++;
2163 /* Output the data, if an intrinsic type, or recurse into this
2164 routine to treat derived types. */
2166 switch (obj->type)
2169 case BT_INTEGER:
2170 write_integer (dtp, p, len);
2171 break;
2173 case BT_LOGICAL:
2174 write_logical (dtp, p, len);
2175 break;
2177 case BT_CHARACTER:
2178 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
2179 write_character (dtp, p, 4, obj->string_length, DELIM);
2180 else
2181 write_character (dtp, p, 1, obj->string_length, DELIM);
2182 break;
2184 case BT_REAL:
2185 write_real (dtp, p, len);
2186 break;
2188 case BT_COMPLEX:
2189 dtp->u.p.no_leading_blank = 0;
2190 num++;
2191 write_complex (dtp, p, len, obj_size);
2192 break;
2194 case BT_DERIVED:
2195 case BT_CLASS:
2196 /* To treat a derived type, we need to build two strings:
2197 ext_name = the name, including qualifiers that prepends
2198 component names in the output - passed to
2199 nml_write_obj.
2200 obj_name = the derived type name with no qualifiers but %
2201 appended. This is used to identify the
2202 components. */
2204 /* First ext_name => get length of all possible components */
2205 if (obj->dtio_sub != NULL)
2207 int unit = dtp->u.p.current_unit->unit_number;
2208 char iotype[] = "NAMELIST";
2209 gfc_charlen_type iotype_len = 8;
2210 char tmp_iomsg[IOMSG_LEN] = "";
2211 char *child_iomsg;
2212 gfc_charlen_type child_iomsg_len;
2213 int noiostat;
2214 int *child_iostat = NULL;
2215 gfc_full_array_i4 vlist;
2216 formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
2218 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
2220 /* Set iostat, intent(out). */
2221 noiostat = 0;
2222 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
2223 dtp->common.iostat : &noiostat;
2225 /* Set iomsg, intent(inout). */
2226 if (dtp->common.flags & IOPARM_HAS_IOMSG)
2228 child_iomsg = dtp->common.iomsg;
2229 child_iomsg_len = dtp->common.iomsg_len;
2231 else
2233 child_iomsg = tmp_iomsg;
2234 child_iomsg_len = IOMSG_LEN;
2237 /* Call the user defined formatted WRITE procedure. */
2238 dtp->u.p.current_unit->child_dtio++;
2239 if (obj->type == BT_DERIVED)
2241 /* Build a class container. */
2242 gfc_class list_obj;
2243 list_obj.data = p;
2244 list_obj.vptr = obj->vtable;
2245 list_obj.len = 0;
2246 dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
2247 child_iostat, child_iomsg,
2248 iotype_len, child_iomsg_len);
2250 else
2252 dtio_ptr (p, &unit, iotype, &vlist,
2253 child_iostat, child_iomsg,
2254 iotype_len, child_iomsg_len);
2256 dtp->u.p.current_unit->child_dtio--;
2258 goto obj_loop;
2261 base_name_len = base_name ? strlen (base_name) : 0;
2262 base_var_name_len = base ? strlen (base->var_name) : 0;
2263 ext_name_len = base_name_len + base_var_name_len
2264 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
2265 ext_name = xmalloc (ext_name_len);
2267 if (base_name)
2268 memcpy (ext_name, base_name, base_name_len);
2269 clen = strlen (obj->var_name + base_var_name_len);
2270 memcpy (ext_name + base_name_len,
2271 obj->var_name + base_var_name_len, clen);
2273 /* Append the qualifier. */
2275 tot_len = base_name_len + clen;
2276 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
2278 if (!dim_i)
2280 ext_name[tot_len] = '(';
2281 tot_len++;
2283 snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
2284 (int) obj->ls[dim_i].idx);
2285 tot_len += strlen (ext_name + tot_len);
2286 ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
2287 tot_len++;
2290 ext_name[tot_len] = '\0';
2291 for (q = ext_name; *q; q++)
2292 if (*q == '+')
2293 *q = '%';
2295 /* Now obj_name. */
2297 obj_name_len = strlen (obj->var_name) + 1;
2298 obj_name = xmalloc (obj_name_len + 1);
2299 memcpy (obj_name, obj->var_name, obj_name_len-1);
2300 memcpy (obj_name + obj_name_len-1, "%", 2);
2302 /* Now loop over the components. Update the component pointer
2303 with the return value from nml_write_obj => this loop jumps
2304 past nested derived types. */
2306 for (cmp = obj->next;
2307 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
2308 cmp = retval)
2310 retval = nml_write_obj (dtp, cmp,
2311 (index_type)(p - obj->mem_pos),
2312 obj, ext_name);
2315 free (obj_name);
2316 free (ext_name);
2317 goto obj_loop;
2319 default:
2320 internal_error (&dtp->common, "Bad type for namelist write");
2323 /* Reset the leading blank suppression, write a comma (or semi-colon)
2324 and, if 5 values have been output, write a newline and advance
2325 to column 2. Reset the repeat counter. */
2327 dtp->u.p.no_leading_blank = 0;
2328 if (obj->type == BT_CHARACTER)
2330 if (dtp->u.p.nml_delim != '\0')
2331 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2333 else
2334 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2335 if (num > 5)
2337 num = 0;
2338 if (dtp->u.p.nml_delim == '\0')
2339 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2340 namelist_write_newline (dtp);
2341 write_character (dtp, " ", 1, 1, NODELIM);
2343 rep_ctr = 1;
2346 /* Cycle through and increment the index vector. */
2348 obj_loop:
2350 nml_carry = 1;
2351 for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
2353 obj->ls[dim_i].idx += nml_carry ;
2354 nml_carry = 0;
2355 if (obj->ls[dim_i].idx > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
2357 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
2358 nml_carry = 1;
2363 /* Return a pointer beyond the furthest object accessed. */
2365 return retval;
2369 /* This is the entry function for namelist writes. It outputs the name
2370 of the namelist and iterates through the namelist by calls to
2371 nml_write_obj. The call below has dummys in the arguments used in
2372 the treatment of derived types. */
2374 void
2375 namelist_write (st_parameter_dt *dtp)
2377 namelist_info *t1, *t2, *dummy = NULL;
2378 index_type dummy_offset = 0;
2379 char c;
2380 char *dummy_name = NULL;
2382 /* Set the delimiter for namelist output. */
2383 switch (dtp->u.p.current_unit->delim_status)
2385 case DELIM_APOSTROPHE:
2386 dtp->u.p.nml_delim = '\'';
2387 break;
2388 case DELIM_QUOTE:
2389 case DELIM_UNSPECIFIED:
2390 dtp->u.p.nml_delim = '"';
2391 break;
2392 default:
2393 dtp->u.p.nml_delim = '\0';
2396 write_character (dtp, "&", 1, 1, NODELIM);
2398 /* Write namelist name in upper case - f95 std. */
2399 for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ )
2401 c = toupper ((int) dtp->namelist_name[i]);
2402 write_character (dtp, &c, 1 ,1, NODELIM);
2405 if (dtp->u.p.ionml != NULL)
2407 t1 = dtp->u.p.ionml;
2408 while (t1 != NULL)
2410 t2 = t1;
2411 t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
2415 namelist_write_newline (dtp);
2416 write_character (dtp, " /", 1, 2, NODELIM);
2419 #undef NML_DIGITS