1 /* Copyright (C) 2002-2023 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
5
6 This file is part of the GNU Fortran runtime library (libgfortran).
7
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.
12
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.
17
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.
21
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/>. */
26
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
34 #define star_fill(p, n) memset(p, '*', n)
35
36 typedef unsigned char uchar;
37
38 /* Helper functions for character(kind=4) internal units. These are needed
39 by write_float.def. */
40
41 static void
42 memcpy4 (gfc_char4_t *dest, const char *source, int k)
43 {
44 int j;
45
46 const char *p = source;
47 for (j = 0; j < k; j++)
48 *dest++ = (gfc_char4_t) *p++;
49 }
50
51 /* This include contains the heart and soul of formatted floating point. */
52 #include "write_float.def"
53
54 /* Write out default char4. */
55
56 static void
57 write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
58 int src_len, int w_len)
59 {
60 char *p;
61 int j, k = 0;
62 gfc_char4_t c;
63 uchar d;
64
65 /* Take care of preceding blanks. */
66 if (w_len > src_len)
67 {
68 k = w_len - src_len;
69 p = write_block (dtp, k);
70 if (p == NULL)
71 return;
72 if (is_char4_unit (dtp))
73 {
74 gfc_char4_t *p4 = (gfc_char4_t *) p;
75 memset4 (p4, ' ', k);
76 }
77 else
78 memset (p, ' ', k);
79 }
80
81 /* Get ready to handle delimiters if needed. */
82 switch (dtp->u.p.current_unit->delim_status)
83 {
84 case DELIM_APOSTROPHE:
85 d = '\'';
86 break;
87 case DELIM_QUOTE:
88 d = '"';
89 break;
90 default:
91 d = ' ';
92 break;
93 }
94
95 /* Now process the remaining characters, one at a time. */
96 for (j = 0; j < src_len; j++)
97 {
98 c = source[j];
99 if (is_char4_unit (dtp))
100 {
101 gfc_char4_t *q;
102 /* Handle delimiters if any. */
103 if (c == d && d != ' ')
104 {
105 p = write_block (dtp, 2);
106 if (p == NULL)
107 return;
108 q = (gfc_char4_t *) p;
109 *q++ = c;
110 }
111 else
112 {
113 p = write_block (dtp, 1);
114 if (p == NULL)
115 return;
116 q = (gfc_char4_t *) p;
117 }
118 *q = c;
119 }
120 else
121 {
122 /* Handle delimiters if any. */
123 if (c == d && d != ' ')
124 {
125 p = write_block (dtp, 2);
126 if (p == NULL)
127 return;
128 *p++ = (uchar) c;
129 }
130 else
131 {
132 p = write_block (dtp, 1);
133 if (p == NULL)
134 return;
135 }
136 *p = c > 255 ? '?' : (uchar) c;
137 }
138 }
139 }
140
141
142 /* Write out UTF-8 converted from char4. */
143
144 static void
145 write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
146 int src_len, int w_len)
147 {
148 char *p;
149 int j, k = 0;
150 gfc_char4_t c;
151 static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
152 static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
153 int nbytes;
154 uchar buf[6], d, *q;
155
156 /* Take care of preceding blanks. */
157 if (w_len > src_len)
158 {
159 k = w_len - src_len;
160 p = write_block (dtp, k);
161 if (p == NULL)
162 return;
163 memset (p, ' ', k);
164 }
165
166 /* Get ready to handle delimiters if needed. */
167 switch (dtp->u.p.current_unit->delim_status)
168 {
169 case DELIM_APOSTROPHE:
170 d = '\'';
171 break;
172 case DELIM_QUOTE:
173 d = '"';
174 break;
175 default:
176 d = ' ';
177 break;
178 }
179
180 /* Now process the remaining characters, one at a time. */
181 for (j = k; j < src_len; j++)
182 {
183 c = source[j];
184 if (c < 0x80)
185 {
186 /* Handle the delimiters if any. */
187 if (c == d && d != ' ')
188 {
189 p = write_block (dtp, 2);
190 if (p == NULL)
191 return;
192 *p++ = (uchar) c;
193 }
194 else
195 {
196 p = write_block (dtp, 1);
197 if (p == NULL)
198 return;
199 }
200 *p = (uchar) c;
201 }
202 else
203 {
204 /* Convert to UTF-8 sequence. */
205 nbytes = 1;
206 q = &buf[6];
207
208 do
209 {
210 *--q = ((c & 0x3F) | 0x80);
211 c >>= 6;
212 nbytes++;
213 }
214 while (c >= 0x3F || (c & limits[nbytes-1]));
215
216 *--q = (c | masks[nbytes-1]);
217
218 p = write_block (dtp, nbytes);
219 if (p == NULL)
220 return;
221
222 while (q < &buf[6])
223 *p++ = *q++;
224 }
225 }
226 }
227
228
229 /* Check the first character in source if we are using CC_FORTRAN
230 and set the cc.type appropriately. The cc.type is used later by write_cc
231 to determine the output start-of-record, and next_record_cc to determine the
232 output end-of-record.
233 This function is called before the output buffer is allocated, so alloc_len
234 is set to the appropriate size to allocate. */
235
236 static void
237 write_check_cc (st_parameter_dt *dtp, const char **source, size_t *alloc_len)
238 {
239 /* Only valid for CARRIAGECONTROL=FORTRAN. */
240 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN
241 || alloc_len == NULL || source == NULL)
242 return;
243
244 /* Peek at the first character. */
245 int c = (*alloc_len > 0) ? (*source)[0] : EOF;
246 if (c != EOF)
247 {
248 /* The start-of-record character which will be printed. */
249 dtp->u.p.cc.u.start = '\n';
250 /* The number of characters to print at the start-of-record.
251 len > 1 means copy the SOR character multiple times.
252 len == 0 means no SOR will be output. */
253 dtp->u.p.cc.len = 1;
254
255 switch (c)
256 {
257 case '+':
258 dtp->u.p.cc.type = CCF_OVERPRINT;
259 dtp->u.p.cc.len = 0;
260 break;
261 case '-':
262 dtp->u.p.cc.type = CCF_ONE_LF;
263 dtp->u.p.cc.len = 1;
264 break;
265 case '0':
266 dtp->u.p.cc.type = CCF_TWO_LF;
267 dtp->u.p.cc.len = 2;
268 break;
269 case '1':
270 dtp->u.p.cc.type = CCF_PAGE_FEED;
271 dtp->u.p.cc.len = 1;
272 dtp->u.p.cc.u.start = '\f';
273 break;
274 case '$':
275 dtp->u.p.cc.type = CCF_PROMPT;
276 dtp->u.p.cc.len = 1;
277 break;
278 case '\0':
279 dtp->u.p.cc.type = CCF_OVERPRINT_NOA;
280 dtp->u.p.cc.len = 0;
281 break;
282 default:
283 /* In the default case we copy ONE_LF. */
284 dtp->u.p.cc.type = CCF_DEFAULT;
285 dtp->u.p.cc.len = 1;
286 break;
287 }
288
289 /* We add n-1 to alloc_len so our write buffer is the right size.
290 We are replacing the first character, and possibly prepending some
291 additional characters. Note for n==0, we actually subtract one from
292 alloc_len, which is correct, since that character is skipped. */
293 if (*alloc_len > 0)
294 {
295 *source += 1;
296 *alloc_len += dtp->u.p.cc.len - 1;
297 }
298 /* If we have no input, there is no first character to replace. Make
299 sure we still allocate enough space for the start-of-record string. */
300 else
301 *alloc_len = dtp->u.p.cc.len;
302 }
303 }
304
305
306 /* Write the start-of-record character(s) for CC_FORTRAN.
307 Also adjusts the 'cc' struct to contain the end-of-record character
308 for next_record_cc.
309 The source_len is set to the remaining length to copy from the source,
310 after the start-of-record string was inserted. */
311
312 static char *
313 write_cc (st_parameter_dt *dtp, char *p, size_t *source_len)
314 {
315 /* Only valid for CARRIAGECONTROL=FORTRAN. */
316 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN || source_len == NULL)
317 return p;
318
319 /* Write the start-of-record string to the output buffer. Note that len is
320 never more than 2. */
321 if (dtp->u.p.cc.len > 0)
322 {
323 *(p++) = dtp->u.p.cc.u.start;
324 if (dtp->u.p.cc.len > 1)
325 *(p++) = dtp->u.p.cc.u.start;
326
327 /* source_len comes from write_check_cc where it is set to the full
328 allocated length of the output buffer. Therefore we subtract off the
329 length of the SOR string to obtain the remaining source length. */
330 *source_len -= dtp->u.p.cc.len;
331 }
332
333 /* Common case. */
334 dtp->u.p.cc.len = 1;
335 dtp->u.p.cc.u.end = '\r';
336
337 /* Update end-of-record character for next_record_w. */
338 switch (dtp->u.p.cc.type)
339 {
340 case CCF_PROMPT:
341 case CCF_OVERPRINT_NOA:
342 /* No end-of-record. */
343 dtp->u.p.cc.len = 0;
344 dtp->u.p.cc.u.end = '\0';
345 break;
346 case CCF_OVERPRINT:
347 case CCF_ONE_LF:
348 case CCF_TWO_LF:
349 case CCF_PAGE_FEED:
350 case CCF_DEFAULT:
351 default:
352 /* Carriage return. */
353 dtp->u.p.cc.len = 1;
354 dtp->u.p.cc.u.end = '\r';
355 break;
356 }
357
358 return p;
359 }
360
361 void
362
363 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
364 {
365 size_t wlen;
366 char *p;
367
368 wlen = f->u.string.length < 0
369 || (f->format == FMT_G && f->u.string.length == 0)
370 ? len : (size_t) f->u.string.length;
371
372 #ifdef HAVE_CRLF
373 /* If this is formatted STREAM IO convert any embedded line feed characters
374 to CR_LF on systems that use that sequence for newlines. See F2003
375 Standard sections 10.6.3 and 9.9 for further information. */
376 if (is_stream_io (dtp))
377 {
378 const char crlf[] = "\r\n";
379 size_t q, bytes;
380 q = bytes = 0;
381
382 /* Write out any padding if needed. */
383 if (len < wlen)
384 {
385 p = write_block (dtp, wlen - len);
386 if (p == NULL)
387 return;
388 memset (p, ' ', wlen - len);
389 }
390
391 /* Scan the source string looking for '\n' and convert it if found. */
392 for (size_t i = 0; i < wlen; i++)
393 {
394 if (source[i] == '\n')
395 {
396 /* Write out the previously scanned characters in the string. */
397 if (bytes > 0)
398 {
399 p = write_block (dtp, bytes);
400 if (p == NULL)
401 return;
402 memcpy (p, &source[q], bytes);
403 q += bytes;
404 bytes = 0;
405 }
406
407 /* Write out the CR_LF sequence. */
408 q++;
409 p = write_block (dtp, 2);
410 if (p == NULL)
411 return;
412 memcpy (p, crlf, 2);
413 }
414 else
415 bytes++;
416 }
417
418 /* Write out any remaining bytes if no LF was found. */
419 if (bytes > 0)
420 {
421 p = write_block (dtp, bytes);
422 if (p == NULL)
423 return;
424 memcpy (p, &source[q], bytes);
425 }
426 }
427 else
428 {
429 #endif
430 if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
431 write_check_cc (dtp, &source, &wlen);
432
433 p = write_block (dtp, wlen);
434 if (p == NULL)
435 return;
436
437 if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
438 p = write_cc (dtp, p, &wlen);
439
440 if (unlikely (is_char4_unit (dtp)))
441 {
442 gfc_char4_t *p4 = (gfc_char4_t *) p;
443 if (wlen < len)
444 memcpy4 (p4, source, wlen);
445 else
446 {
447 memset4 (p4, ' ', wlen - len);
448 memcpy4 (p4 + wlen - len, source, len);
449 }
450 return;
451 }
452
453 if (wlen < len)
454 memcpy (p, source, wlen);
455 else
456 {
457 memset (p, ' ', wlen - len);
458 memcpy (p + wlen - len, source, len);
459 }
460 #ifdef HAVE_CRLF
461 }
462 #endif
463 }
464
465
466 /* The primary difference between write_a_char4 and write_a is that we have to
467 deal with writing from the first byte of the 4-byte character and pay
468 attention to the most significant bytes. For ENCODING="default" write the
469 lowest significant byte. If the 3 most significant bytes contain
470 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
471 to the UTF-8 encoded string before writing out. */
472
473 void
474 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
475 {
476 size_t wlen;
477 gfc_char4_t *q;
478
479 wlen = f->u.string.length < 0
480 || (f->format == FMT_G && f->u.string.length == 0)
481 ? len : (size_t) f->u.string.length;
482
483 q = (gfc_char4_t *) source;
484 #ifdef HAVE_CRLF
485 /* If this is formatted STREAM IO convert any embedded line feed characters
486 to CR_LF on systems that use that sequence for newlines. See F2003
487 Standard sections 10.6.3 and 9.9 for further information. */
488 if (is_stream_io (dtp))
489 {
490 const gfc_char4_t crlf[] = {0x000d,0x000a};
491 size_t bytes;
492 gfc_char4_t *qq;
493 bytes = 0;
494
495 /* Write out any padding if needed. */
496 if (len < wlen)
497 {
498 char *p;
499 p = write_block (dtp, wlen - len);
500 if (p == NULL)
501 return;
502 memset (p, ' ', wlen - len);
503 }
504
505 /* Scan the source string looking for '\n' and convert it if found. */
506 qq = (gfc_char4_t *) source;
507 for (size_t i = 0; i < wlen; i++)
508 {
509 if (qq[i] == '\n')
510 {
511 /* Write out the previously scanned characters in the string. */
512 if (bytes > 0)
513 {
514 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
515 write_utf8_char4 (dtp, q, bytes, 0);
516 else
517 write_default_char4 (dtp, q, bytes, 0);
518 bytes = 0;
519 }
520
521 /* Write out the CR_LF sequence. */
522 write_default_char4 (dtp, crlf, 2, 0);
523 }
524 else
525 bytes++;
526 }
527
528 /* Write out any remaining bytes if no LF was found. */
529 if (bytes > 0)
530 {
531 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
532 write_utf8_char4 (dtp, q, bytes, 0);
533 else
534 write_default_char4 (dtp, q, bytes, 0);
535 }
536 }
537 else
538 {
539 #endif
540 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
541 write_utf8_char4 (dtp, q, len, wlen);
542 else
543 write_default_char4 (dtp, q, len, wlen);
544 #ifdef HAVE_CRLF
545 }
546 #endif
547 }
548
549
550 static GFC_INTEGER_LARGEST
551 extract_int (const void *p, int len)
552 {
553 GFC_INTEGER_LARGEST i = 0;
554
555 if (p == NULL)
556 return i;
557
558 switch (len)
559 {
560 case 1:
561 {
562 GFC_INTEGER_1 tmp;
563 memcpy ((void *) &tmp, p, len);
564 i = tmp;
565 }
566 break;
567 case 2:
568 {
569 GFC_INTEGER_2 tmp;
570 memcpy ((void *) &tmp, p, len);
571 i = tmp;
572 }
573 break;
574 case 4:
575 {
576 GFC_INTEGER_4 tmp;
577 memcpy ((void *) &tmp, p, len);
578 i = tmp;
579 }
580 break;
581 case 8:
582 {
583 GFC_INTEGER_8 tmp;
584 memcpy ((void *) &tmp, p, len);
585 i = tmp;
586 }
587 break;
588 #ifdef HAVE_GFC_INTEGER_16
589 case 16:
590 {
591 GFC_INTEGER_16 tmp;
592 memcpy ((void *) &tmp, p, len);
593 i = tmp;
594 }
595 break;
596 #endif
597 default:
598 internal_error (NULL, "bad integer kind");
599 }
600
601 return i;
602 }
603
604 static GFC_UINTEGER_LARGEST
605 extract_uint (const void *p, int len)
606 {
607 GFC_UINTEGER_LARGEST i = 0;
608
609 if (p == NULL)
610 return i;
611
612 switch (len)
613 {
614 case 1:
615 {
616 GFC_INTEGER_1 tmp;
617 memcpy ((void *) &tmp, p, len);
618 i = (GFC_UINTEGER_1) tmp;
619 }
620 break;
621 case 2:
622 {
623 GFC_INTEGER_2 tmp;
624 memcpy ((void *) &tmp, p, len);
625 i = (GFC_UINTEGER_2) tmp;
626 }
627 break;
628 case 4:
629 {
630 GFC_INTEGER_4 tmp;
631 memcpy ((void *) &tmp, p, len);
632 i = (GFC_UINTEGER_4) tmp;
633 }
634 break;
635 case 8:
636 {
637 GFC_INTEGER_8 tmp;
638 memcpy ((void *) &tmp, p, len);
639 i = (GFC_UINTEGER_8) tmp;
640 }
641 break;
642 #ifdef HAVE_GFC_INTEGER_16
643 case 10:
644 case 16:
645 {
646 GFC_INTEGER_16 tmp = 0;
647 memcpy ((void *) &tmp, p, len);
648 i = (GFC_UINTEGER_16) tmp;
649 }
650 break;
651 # ifdef HAVE_GFC_REAL_17
652 case 17:
653 {
654 GFC_INTEGER_16 tmp = 0;
655 memcpy ((void *) &tmp, p, 16);
656 i = (GFC_UINTEGER_16) tmp;
657 }
658 break;
659 # endif
660 #endif
661 default:
662 internal_error (NULL, "bad integer kind");
663 }
664
665 return i;
666 }
667
668
669 void
670 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
671 {
672 char *p;
673 int wlen;
674 GFC_INTEGER_LARGEST n;
675
676 wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
677
678 p = write_block (dtp, wlen);
679 if (p == NULL)
680 return;
681
682 n = extract_int (source, len);
683
684 if (unlikely (is_char4_unit (dtp)))
685 {
686 gfc_char4_t *p4 = (gfc_char4_t *) p;
687 memset4 (p4, ' ', wlen -1);
688 p4[wlen - 1] = (n) ? 'T' : 'F';
689 return;
690 }
691
692 memset (p, ' ', wlen -1);
693 p[wlen - 1] = (n) ? 'T' : 'F';
694 }
695
696 static void
697 write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len)
698 {
699 int w, m, digits, nzero, nblank;
700 char *p;
701
702 w = f->u.integer.w;
703 m = f->u.integer.m;
704
705 /* Special case: */
706
707 if (m == 0 && n == 0)
708 {
709 if (w == 0)
710 w = 1;
711
712 p = write_block (dtp, w);
713 if (p == NULL)
714 return;
715 if (unlikely (is_char4_unit (dtp)))
716 {
717 gfc_char4_t *p4 = (gfc_char4_t *) p;
718 memset4 (p4, ' ', w);
719 }
720 else
721 memset (p, ' ', w);
722 goto done;
723 }
724
725 digits = strlen (q);
726
727 /* Select a width if none was specified. The idea here is to always
728 print something. */
729
730 if (w == DEFAULT_WIDTH)
731 w = default_width_for_integer (len);
732
733 if (w == 0)
734 w = ((digits < m) ? m : digits);
735
736 p = write_block (dtp, w);
737 if (p == NULL)
738 return;
739
740 nzero = 0;
741 if (digits < m)
742 nzero = m - digits;
743
744 /* See if things will work. */
745
746 nblank = w - (nzero + digits);
747
748 if (unlikely (is_char4_unit (dtp)))
749 {
750 gfc_char4_t *p4 = (gfc_char4_t *) p;
751 if (nblank < 0)
752 {
753 memset4 (p4, '*', w);
754 return;
755 }
756
757 if (!dtp->u.p.no_leading_blank)
758 {
759 memset4 (p4, ' ', nblank);
760 q += nblank;
761 memset4 (p4, '0', nzero);
762 q += nzero;
763 memcpy4 (p4, q, digits);
764 }
765 else
766 {
767 memset4 (p4, '0', nzero);
768 q += nzero;
769 memcpy4 (p4, q, digits);
770 q += digits;
771 memset4 (p4, ' ', nblank);
772 dtp->u.p.no_leading_blank = 0;
773 }
774 return;
775 }
776
777 if (nblank < 0)
778 {
779 star_fill (p, w);
780 goto done;
781 }
782
783 if (!dtp->u.p.no_leading_blank)
784 {
785 memset (p, ' ', nblank);
786 p += nblank;
787 memset (p, '0', nzero);
788 p += nzero;
789 memcpy (p, q, digits);
790 }
791 else
792 {
793 memset (p, '0', nzero);
794 p += nzero;
795 memcpy (p, q, digits);
796 p += digits;
797 memset (p, ' ', nblank);
798 dtp->u.p.no_leading_blank = 0;
799 }
800
801 done:
802 return;
803 }
804
805 static void
806 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
807 int len)
808 {
809 GFC_INTEGER_LARGEST n = 0;
810 GFC_UINTEGER_LARGEST absn;
811 int w, m, digits, nsign, nzero, nblank;
812 char *p;
813 const char *q;
814 sign_t sign;
815 char itoa_buf[GFC_BTOA_BUF_SIZE];
816
817 w = f->u.integer.w;
818 m = f->format == FMT_G ? -1 : f->u.integer.m;
819
820 n = extract_int (source, len);
821
822 /* Special case: */
823 if (m == 0 && n == 0)
824 {
825 if (w == 0)
826 w = 1;
827
828 p = write_block (dtp, w);
829 if (p == NULL)
830 return;
831 if (unlikely (is_char4_unit (dtp)))
832 {
833 gfc_char4_t *p4 = (gfc_char4_t *) p;
834 memset4 (p4, ' ', w);
835 }
836 else
837 memset (p, ' ', w);
838 goto done;
839 }
840
841 sign = calculate_sign (dtp, n < 0);
842 if (n < 0)
843 /* Use unsigned to protect from overflow. */
844 absn = -(GFC_UINTEGER_LARGEST) n;
845 else
846 absn = n;
847 nsign = sign == S_NONE ? 0 : 1;
848
849 /* gfc_itoa() converts the nonnegative value to decimal representation. */
850 q = gfc_itoa (absn, itoa_buf, sizeof (itoa_buf));
851 digits = strlen (q);
852
853 /* Select a width if none was specified. The idea here is to always
854 print something. */
855 if (w == DEFAULT_WIDTH)
856 w = default_width_for_integer (len);
857
858 if (w == 0)
859 w = ((digits < m) ? m : digits) + nsign;
860
861 p = write_block (dtp, w);
862 if (p == NULL)
863 return;
864
865 nzero = 0;
866 if (digits < m)
867 nzero = m - digits;
868
869 /* See if things will work. */
870
871 nblank = w - (nsign + nzero + digits);
872
873 if (unlikely (is_char4_unit (dtp)))
874 {
875 gfc_char4_t *p4 = (gfc_char4_t *)p;
876 if (nblank < 0)
877 {
878 memset4 (p4, '*', w);
879 goto done;
880 }
881
882 if (!dtp->u.p.namelist_mode)
883 {
884 memset4 (p4, ' ', nblank);
885 p4 += nblank;
886 }
887
888 switch (sign)
889 {
890 case S_PLUS:
891 *p4++ = '+';
892 break;
893 case S_MINUS:
894 *p4++ = '-';
895 break;
896 case S_NONE:
897 break;
898 }
899
900 memset4 (p4, '0', nzero);
901 p4 += nzero;
902
903 memcpy4 (p4, q, digits);
904 return;
905
906 if (dtp->u.p.namelist_mode)
907 {
908 p4 += digits;
909 memset4 (p4, ' ', nblank);
910 }
911 }
912
913 if (nblank < 0)
914 {
915 star_fill (p, w);
916 goto done;
917 }
918
919 if (!dtp->u.p.namelist_mode)
920 {
921 memset (p, ' ', nblank);
922 p += nblank;
923 }
924
925 switch (sign)
926 {
927 case S_PLUS:
928 *p++ = '+';
929 break;
930 case S_MINUS:
931 *p++ = '-';
932 break;
933 case S_NONE:
934 break;
935 }
936
937 memset (p, '0', nzero);
938 p += nzero;
939
940 memcpy (p, q, digits);
941
942 if (dtp->u.p.namelist_mode)
943 {
944 p += digits;
945 memset (p, ' ', nblank);
946 }
947
948 done:
949 return;
950 }
951
952
953 /* Convert hexadecimal to ASCII. */
954
955 static const char *
956 xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
957 {
958 int digit;
959 char *p;
960
961 assert (len >= GFC_XTOA_BUF_SIZE);
962
963 if (n == 0)
964 return "0";
965
966 p = buffer + GFC_XTOA_BUF_SIZE - 1;
967 *p = '\0';
968
969 while (n != 0)
970 {
971 digit = n & 0xF;
972 if (digit > 9)
973 digit += 'A' - '0' - 10;
974
975 *--p = '0' + digit;
976 n >>= 4;
977 }
978
979 return p;
980 }
981
982
983 /* Convert unsigned octal to ASCII. */
984
985 static const char *
986 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
987 {
988 char *p;
989
990 assert (len >= GFC_OTOA_BUF_SIZE);
991
992 if (n == 0)
993 return "0";
994
995 p = buffer + GFC_OTOA_BUF_SIZE - 1;
996 *p = '\0';
997
998 while (n != 0)
999 {
1000 *--p = '0' + (n & 7);
1001 n >>= 3;
1002 }
1003
1004 return p;
1005 }
1006
1007
1008 /* Convert unsigned binary to ASCII. */
1009
1010 static const char *
1011 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
1012 {
1013 char *p;
1014
1015 assert (len >= GFC_BTOA_BUF_SIZE);
1016
1017 if (n == 0)
1018 return "0";
1019
1020 p = buffer + GFC_BTOA_BUF_SIZE - 1;
1021 *p = '\0';
1022
1023 while (n != 0)
1024 {
1025 *--p = '0' + (n & 1);
1026 n >>= 1;
1027 }
1028
1029 return p;
1030 }
1031
1032 /* The following three functions, btoa_big, otoa_big, and xtoa_big, are needed
1033 to convert large reals with kind sizes that exceed the largest integer type
1034 available on certain platforms. In these cases, byte by byte conversion is
1035 performed. Endianess is taken into account. */
1036
1037 /* Conversion to binary. */
1038
1039 static const char *
1040 btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
1041 {
1042 char *q;
1043 int i, j;
1044
1045 q = buffer;
1046 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
1047 {
1048 const char *p = s;
1049 for (i = 0; i < len; i++)
1050 {
1051 char c = *p;
1052
1053 /* Test for zero. Needed by write_boz later. */
1054 if (*p != 0)
1055 *n = 1;
1056
1057 for (j = 0; j < 8; j++)
1058 {
1059 *q++ = (c & 128) ? '1' : '0';
1060 c <<= 1;
1061 }
1062 p++;
1063 }
1064 }
1065 else
1066 {
1067 const char *p = s + len - 1;
1068 for (i = 0; i < len; i++)
1069 {
1070 char c = *p;
1071
1072 /* Test for zero. Needed by write_boz later. */
1073 if (*p != 0)
1074 *n = 1;
1075
1076 for (j = 0; j < 8; j++)
1077 {
1078 *q++ = (c & 128) ? '1' : '0';
1079 c <<= 1;
1080 }
1081 p--;
1082 }
1083 }
1084
1085 if (*n == 0)
1086 return "0";
1087
1088 /* Move past any leading zeros. */
1089 while (*buffer == '0')
1090 buffer++;
1091
1092 return buffer;
1093
1094 }
1095
1096 /* Conversion to octal. */
1097
1098 static const char *
1099 otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
1100 {
1101 char *q;
1102 int i, j, k;
1103 uint8_t octet;
1104
1105 q = buffer + GFC_OTOA_BUF_SIZE - 1;
1106 *q = '\0';
1107 i = k = octet = 0;
1108
1109 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
1110 {
1111 const char *p = s + len - 1;
1112 char c = *p;
1113 while (i < len)
1114 {
1115 /* Test for zero. Needed by write_boz later. */
1116 if (*p != 0)
1117 *n = 1;
1118
1119 for (j = 0; j < 3 && i < len; j++)
1120 {
1121 octet |= (c & 1) << j;
1122 c >>= 1;
1123 if (++k > 7)
1124 {
1125 i++;
1126 k = 0;
1127 c = *--p;
1128 }
1129 }
1130 *--q = '0' + octet;
1131 octet = 0;
1132 }
1133 }
1134 else
1135 {
1136 const char *p = s;
1137 char c = *p;
1138 while (i < len)
1139 {
1140 /* Test for zero. Needed by write_boz later. */
1141 if (*p != 0)
1142 *n = 1;
1143
1144 for (j = 0; j < 3 && i < len; j++)
1145 {
1146 octet |= (c & 1) << j;
1147 c >>= 1;
1148 if (++k > 7)
1149 {
1150 i++;
1151 k = 0;
1152 c = *++p;
1153 }
1154 }
1155 *--q = '0' + octet;
1156 octet = 0;
1157 }
1158 }
1159
1160 if (*n == 0)
1161 return "0";
1162
1163 /* Move past any leading zeros. */
1164 while (*q == '0')
1165 q++;
1166
1167 return q;
1168 }
1169
1170 /* Conversion to hexadecimal. */
1171
1172 static const char *
1173 xtoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
1174 {
1175 static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
1176 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1177
1178 char *q;
1179 uint8_t h, l;
1180 int i;
1181
1182 q = buffer;
1183
1184 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
1185 {
1186 const char *p = s;
1187 for (i = 0; i < len; i++)
1188 {
1189 /* Test for zero. Needed by write_boz later. */
1190 if (*p != 0)
1191 *n = 1;
1192
1193 h = (*p >> 4) & 0x0F;
1194 l = *p++ & 0x0F;
1195 *q++ = a[h];
1196 *q++ = a[l];
1197 }
1198 }
1199 else
1200 {
1201 const char *p = s + len - 1;
1202 for (i = 0; i < len; i++)
1203 {
1204 /* Test for zero. Needed by write_boz later. */
1205 if (*p != 0)
1206 *n = 1;
1207
1208 h = (*p >> 4) & 0x0F;
1209 l = *p-- & 0x0F;
1210 *q++ = a[h];
1211 *q++ = a[l];
1212 }
1213 }
1214
1215 /* write_z, which calls xtoa_big, is called from transfer.c,
1216 formatted_transfer_scalar_write. There it is passed the kind as
1217 argument, which means a maximum of 16. The buffer is large
1218 enough, but the compiler does not know that, so shut up the
1219 warning here. */
1220 #pragma GCC diagnostic push
1221 #pragma GCC diagnostic ignored "-Wstringop-overflow"
1222 *q = '\0';
1223 #pragma GCC diagnostic pop
1224
1225 if (*n == 0)
1226 return "0";
1227
1228 /* Move past any leading zeros. */
1229 while (*buffer == '0')
1230 buffer++;
1231
1232 return buffer;
1233 }
1234
1235
1236 void
1237 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1238 {
1239 write_decimal (dtp, f, p, len);
1240 }
1241
1242
1243 void
1244 write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1245 {
1246 const char *p;
1247 char itoa_buf[GFC_BTOA_BUF_SIZE];
1248 GFC_UINTEGER_LARGEST n = 0;
1249
1250 /* Ensure we end up with a null terminated string. */
1251 memset(itoa_buf, '\0', GFC_BTOA_BUF_SIZE);
1252
1253 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1254 {
1255 p = btoa_big (source, itoa_buf, len, &n);
1256 write_boz (dtp, f, p, n, len);
1257 }
1258 else
1259 {
1260 n = extract_uint (source, len);
1261 p = btoa (n, itoa_buf, sizeof (itoa_buf));
1262 write_boz (dtp, f, p, n, len);
1263 }
1264 }
1265
1266
1267 void
1268 write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1269 {
1270 const char *p;
1271 char itoa_buf[GFC_OTOA_BUF_SIZE];
1272 GFC_UINTEGER_LARGEST n = 0;
1273
1274 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1275 {
1276 p = otoa_big (source, itoa_buf, len, &n);
1277 write_boz (dtp, f, p, n, len);
1278 }
1279 else
1280 {
1281 n = extract_uint (source, len);
1282 p = otoa (n, itoa_buf, sizeof (itoa_buf));
1283 write_boz (dtp, f, p, n, len);
1284 }
1285 }
1286
1287 void
1288 write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1289 {
1290 const char *p;
1291 char itoa_buf[GFC_XTOA_BUF_SIZE];
1292 GFC_UINTEGER_LARGEST n = 0;
1293
1294 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1295 {
1296 p = xtoa_big (source, itoa_buf, len, &n);
1297 write_boz (dtp, f, p, n, len);
1298 }
1299 else
1300 {
1301 n = extract_uint (source, len);
1302 p = xtoa (n, itoa_buf, sizeof (itoa_buf));
1303 write_boz (dtp, f, p, n, len);
1304 }
1305 }
1306
1307 /* Take care of the X/TR descriptor. */
1308
1309 void
1310 write_x (st_parameter_dt *dtp, int len, int nspaces)
1311 {
1312 char *p;
1313
1314 p = write_block (dtp, len);
1315 if (p == NULL)
1316 return;
1317 if (nspaces > 0 && len - nspaces >= 0)
1318 {
1319 if (unlikely (is_char4_unit (dtp)))
1320 {
1321 gfc_char4_t *p4 = (gfc_char4_t *) p;
1322 memset4 (&p4[len - nspaces], ' ', nspaces);
1323 }
1324 else
1325 memset (&p[len - nspaces], ' ', nspaces);
1326 }
1327 }
1328
1329
1330 /* List-directed writing. */
1331
1332
1333 /* Write a single character to the output. Returns nonzero if
1334 something goes wrong. */
1335
1336 static int
1337 write_char (st_parameter_dt *dtp, int c)
1338 {
1339 char *p;
1340
1341 p = write_block (dtp, 1);
1342 if (p == NULL)
1343 return 1;
1344 if (unlikely (is_char4_unit (dtp)))
1345 {
1346 gfc_char4_t *p4 = (gfc_char4_t *) p;
1347 *p4 = c;
1348 return 0;
1349 }
1350
1351 *p = (uchar) c;
1352
1353 return 0;
1354 }
1355
1356
1357 /* Write a list-directed logical value. */
1358
1359 static void
1360 write_logical (st_parameter_dt *dtp, const char *source, int length)
1361 {
1362 write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1363 }
1364
1365
1366 /* Write a list-directed integer value. */
1367
1368 static void
1369 write_integer (st_parameter_dt *dtp, const char *source, int kind)
1370 {
1371 int width;
1372 fnode f;
1373
1374 switch (kind)
1375 {
1376 case 1:
1377 width = 4;
1378 break;
1379
1380 case 2:
1381 width = 6;
1382 break;
1383
1384 case 4:
1385 width = 11;
1386 break;
1387
1388 case 8:
1389 width = 20;
1390 break;
1391
1392 case 16:
1393 width = 40;
1394 break;
1395
1396 default:
1397 width = 0;
1398 break;
1399 }
1400 f.u.integer.w = width;
1401 f.u.integer.m = -1;
1402 f.format = FMT_NONE;
1403 write_decimal (dtp, &f, source, kind);
1404 }
1405
1406
1407 /* Write a list-directed string. We have to worry about delimiting
1408 the strings if the file has been opened in that mode. */
1409
1410 #define DELIM 1
1411 #define NODELIM 0
1412
1413 static void
1414 write_character (st_parameter_dt *dtp, const char *source, int kind, size_t length, int mode)
1415 {
1416 size_t extra;
1417 char *p, d;
1418
1419 if (mode == DELIM)
1420 {
1421 switch (dtp->u.p.current_unit->delim_status)
1422 {
1423 case DELIM_APOSTROPHE:
1424 d = '\'';
1425 break;
1426 case DELIM_QUOTE:
1427 d = '"';
1428 break;
1429 default:
1430 d = ' ';
1431 break;
1432 }
1433 }
1434 else
1435 d = ' ';
1436
1437 if (kind == 1)
1438 {
1439 if (d == ' ')
1440 extra = 0;
1441 else
1442 {
1443 extra = 2;
1444
1445 for (size_t i = 0; i < length; i++)
1446 if (source[i] == d)
1447 extra++;
1448 }
1449
1450 p = write_block (dtp, length + extra);
1451 if (p == NULL)
1452 return;
1453
1454 if (unlikely (is_char4_unit (dtp)))
1455 {
1456 gfc_char4_t d4 = (gfc_char4_t) d;
1457 gfc_char4_t *p4 = (gfc_char4_t *) p;
1458
1459 if (d4 == ' ')
1460 memcpy4 (p4, source, length);
1461 else
1462 {
1463 *p4++ = d4;
1464
1465 for (size_t i = 0; i < length; i++)
1466 {
1467 *p4++ = (gfc_char4_t) source[i];
1468 if (source[i] == d)
1469 *p4++ = d4;
1470 }
1471
1472 *p4 = d4;
1473 }
1474 return;
1475 }
1476
1477 if (d == ' ')
1478 memcpy (p, source, length);
1479 else
1480 {
1481 *p++ = d;
1482
1483 for (size_t i = 0; i < length; i++)
1484 {
1485 *p++ = source[i];
1486 if (source[i] == d)
1487 *p++ = d;
1488 }
1489
1490 *p = d;
1491 }
1492 }
1493 else
1494 {
1495 if (d == ' ')
1496 {
1497 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1498 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1499 else
1500 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1501 }
1502 else
1503 {
1504 p = write_block (dtp, 1);
1505 *p = d;
1506
1507 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1508 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1509 else
1510 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1511
1512 p = write_block (dtp, 1);
1513 *p = d;
1514 }
1515 }
1516 }
1517
1518 /* Floating point helper functions. */
1519
1520 #define BUF_STACK_SZ 384
1521
1522 static int
1523 get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
1524 {
1525 if (f->format != FMT_EN)
1526 return determine_precision (dtp, f, kind);
1527 else
1528 return determine_en_precision (dtp, f, source, kind);
1529 }
1530
1531 /* 4932 is the maximum exponent of long double and quad precision, 3
1532 extra characters for the sign, the decimal point, and the
1533 trailing null. Extra digits are added by the calling functions for
1534 requested precision. Likewise for float and double. F0 editing produces
1535 full precision output. */
1536 static int
1537 size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
1538 {
1539 int size;
1540
1541 if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH)
1542 {
1543 switch (kind)
1544 {
1545 case 4:
1546 size = 38 + 3; /* These constants shown for clarity. */
1547 break;
1548 case 8:
1549 size = 308 + 3;
1550 break;
1551 case 10:
1552 size = 4932 + 3;
1553 break;
1554 case 16:
1555 #ifdef HAVE_GFC_REAL_17
1556 case 17:
1557 #endif
1558 size = 4932 + 3;
1559 break;
1560 default:
1561 internal_error (&dtp->common, "bad real kind");
1562 break;
1563 }
1564 }
1565 else
1566 size = f->u.real.w + 1; /* One byte for a NULL character. */
1567
1568 return size;
1569 }
1570
1571 static char *
1572 select_buffer (st_parameter_dt *dtp, const fnode *f, int precision,
1573 char *buf, size_t *size, int kind)
1574 {
1575 char *result;
1576
1577 /* The buffer needs at least one more byte to allow room for
1578 normalizing and 1 to hold null terminator. */
1579 *size = size_from_kind (dtp, f, kind) + precision + 1 + 1;
1580
1581 if (*size > BUF_STACK_SZ)
1582 result = xmalloc (*size);
1583 else
1584 result = buf;
1585 return result;
1586 }
1587
1588 static char *
1589 select_string (st_parameter_dt *dtp, const fnode *f, char *buf, size_t *size,
1590 int kind)
1591 {
1592 char *result;
1593 *size = size_from_kind (dtp, f, kind) + f->u.real.d + 1;
1594 if (*size > BUF_STACK_SZ)
1595 result = xmalloc (*size);
1596 else
1597 result = buf;
1598 return result;
1599 }
1600
1601 static void
1602 write_float_string (st_parameter_dt *dtp, char *fstr, size_t len)
1603 {
1604 char *p = write_block (dtp, len);
1605 if (p == NULL)
1606 return;
1607
1608 if (unlikely (is_char4_unit (dtp)))
1609 {
1610 gfc_char4_t *p4 = (gfc_char4_t *) p;
1611 memcpy4 (p4, fstr, len);
1612 return;
1613 }
1614 memcpy (p, fstr, len);
1615 }
1616
1617
1618 static void
1619 write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
1620 {
1621 char buf_stack[BUF_STACK_SZ];
1622 char str_buf[BUF_STACK_SZ];
1623 char *buffer, *result;
1624 size_t buf_size, res_len, flt_str_len;
1625
1626 /* Precision for snprintf call. */
1627 int precision = get_precision (dtp, f, source, kind);
1628
1629 /* String buffer to hold final result. */
1630 result = select_string (dtp, f, str_buf, &res_len, kind);
1631
1632 buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
1633
1634 get_float_string (dtp, f, source , kind, 0, buffer,
1635 precision, buf_size, result, &flt_str_len);
1636 write_float_string (dtp, result, flt_str_len);
1637
1638 if (buf_size > BUF_STACK_SZ)
1639 free (buffer);
1640 if (res_len > BUF_STACK_SZ)
1641 free (result);
1642 }
1643
1644 void
1645 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1646 {
1647 write_float_0 (dtp, f, p, len);
1648 }
1649
1650
1651 void
1652 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1653 {
1654 write_float_0 (dtp, f, p, len);
1655 }
1656
1657
1658 void
1659 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1660 {
1661 write_float_0 (dtp, f, p, len);
1662 }
1663
1664
1665 void
1666 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1667 {
1668 write_float_0 (dtp, f, p, len);
1669 }
1670
1671
1672 void
1673 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1674 {
1675 write_float_0 (dtp, f, p, len);
1676 }
1677
1678
1679 /* Set an fnode to default format. */
1680
1681 static void
1682 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
1683 {
1684 f->format = FMT_G;
1685 switch (length)
1686 {
1687 case 4:
1688 f->u.real.w = 16;
1689 f->u.real.d = 9;
1690 f->u.real.e = 2;
1691 break;
1692 case 8:
1693 f->u.real.w = 25;
1694 f->u.real.d = 17;
1695 f->u.real.e = 3;
1696 break;
1697 case 10:
1698 f->u.real.w = 30;
1699 f->u.real.d = 21;
1700 f->u.real.e = 4;
1701 break;
1702 case 16:
1703 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1704 #if GFC_REAL_16_DIGITS == 113
1705 f->u.real.w = 45;
1706 f->u.real.d = 36;
1707 f->u.real.e = 4;
1708 #else
1709 f->u.real.w = 41;
1710 f->u.real.d = 32;
1711 f->u.real.e = 4;
1712 #endif
1713 break;
1714 #ifdef HAVE_GFC_REAL_17
1715 case 17:
1716 f->u.real.w = 45;
1717 f->u.real.d = 36;
1718 f->u.real.e = 4;
1719 break;
1720 #endif
1721 default:
1722 internal_error (&dtp->common, "bad real kind");
1723 break;
1724 }
1725 }
1726
1727 /* Output a real number with default format.
1728 To guarantee that a binary -> decimal -> binary roundtrip conversion
1729 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1730 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1731 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1732 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1733 Fortran standard requires outputting an extra digit when the scale
1734 factor is 1 and when the magnitude of the value is such that E
1735 editing is used. However, gfortran compensates for this, and thus
1736 for list formatted the same number of significant digits is
1737 generated both when using F and E editing. */
1738
1739 void
1740 write_real (st_parameter_dt *dtp, const char *source, int kind)
1741 {
1742 fnode f ;
1743 char buf_stack[BUF_STACK_SZ];
1744 char str_buf[BUF_STACK_SZ];
1745 char *buffer, *result;
1746 size_t buf_size, res_len, flt_str_len;
1747 int orig_scale = dtp->u.p.scale_factor;
1748 dtp->u.p.scale_factor = 1;
1749 set_fnode_default (dtp, &f, kind);
1750
1751 /* Precision for snprintf call. */
1752 int precision = get_precision (dtp, &f, source, kind);
1753
1754 /* String buffer to hold final result. */
1755 result = select_string (dtp, &f, str_buf, &res_len, kind);
1756
1757 /* Scratch buffer to hold final result. */
1758 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
1759
1760 get_float_string (dtp, &f, source , kind, 1, buffer,
1761 precision, buf_size, result, &flt_str_len);
1762 write_float_string (dtp, result, flt_str_len);
1763
1764 dtp->u.p.scale_factor = orig_scale;
1765 if (buf_size > BUF_STACK_SZ)
1766 free (buffer);
1767 if (res_len > BUF_STACK_SZ)
1768 free (result);
1769 }
1770
1771 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1772 compensate for the extra digit. */
1773
1774 void
1775 write_real_w0 (st_parameter_dt *dtp, const char *source, int kind,
1776 const fnode* f)
1777 {
1778 fnode ff;
1779 char buf_stack[BUF_STACK_SZ];
1780 char str_buf[BUF_STACK_SZ];
1781 char *buffer, *result;
1782 size_t buf_size, res_len, flt_str_len;
1783 int comp_d = 0;
1784
1785 set_fnode_default (dtp, &ff, kind);
1786
1787 if (f->u.real.d > 0)
1788 ff.u.real.d = f->u.real.d;
1789 ff.format = f->format;
1790
1791 /* For FMT_G, Compensate for extra digits when using scale factor, d
1792 is not specified, and the magnitude is such that E editing
1793 is used. */
1794 if (f->format == FMT_G)
1795 {
1796 if (dtp->u.p.scale_factor > 0 && f->u.real.d == 0)
1797 comp_d = 1;
1798 else
1799 comp_d = 0;
1800 }
1801
1802 if (f->u.real.e >= 0)
1803 ff.u.real.e = f->u.real.e;
1804
1805 dtp->u.p.g0_no_blanks = 1;
1806
1807 /* Precision for snprintf call. */
1808 int precision = get_precision (dtp, &ff, source, kind);
1809
1810 /* String buffer to hold final result. */
1811 result = select_string (dtp, &ff, str_buf, &res_len, kind);
1812
1813 buffer = select_buffer (dtp, &ff, precision, buf_stack, &buf_size, kind);
1814
1815 get_float_string (dtp, &ff, source , kind, comp_d, buffer,
1816 precision, buf_size, result, &flt_str_len);
1817 write_float_string (dtp, result, flt_str_len);
1818
1819 dtp->u.p.g0_no_blanks = 0;
1820 if (buf_size > BUF_STACK_SZ)
1821 free (buffer);
1822 if (res_len > BUF_STACK_SZ)
1823 free (result);
1824 }
1825
1826
1827 static void
1828 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1829 {
1830 char semi_comma =
1831 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1832
1833 /* Set for no blanks so we get a string result with no leading
1834 blanks. We will pad left later. */
1835 dtp->u.p.g0_no_blanks = 1;
1836
1837 fnode f ;
1838 char buf_stack[BUF_STACK_SZ];
1839 char str1_buf[BUF_STACK_SZ];
1840 char str2_buf[BUF_STACK_SZ];
1841 char *buffer, *result1, *result2;
1842 size_t buf_size, res_len1, res_len2, flt_str_len1, flt_str_len2;
1843 int width, lblanks, orig_scale = dtp->u.p.scale_factor;
1844
1845 dtp->u.p.scale_factor = 1;
1846 set_fnode_default (dtp, &f, kind);
1847
1848 /* Set width for two values, parenthesis, and comma. */
1849 width = 2 * f.u.real.w + 3;
1850
1851 /* Set for no blanks so we get a string result with no leading
1852 blanks. We will pad left later. */
1853 dtp->u.p.g0_no_blanks = 1;
1854
1855 /* Precision for snprintf call. */
1856 int precision = get_precision (dtp, &f, source, kind);
1857
1858 /* String buffers to hold final result. */
1859 result1 = select_string (dtp, &f, str1_buf, &res_len1, kind);
1860 result2 = select_string (dtp, &f, str2_buf, &res_len2, kind);
1861
1862 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
1863
1864 get_float_string (dtp, &f, source , kind, 0, buffer,
1865 precision, buf_size, result1, &flt_str_len1);
1866 get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
1867 precision, buf_size, result2, &flt_str_len2);
1868 if (!dtp->u.p.namelist_mode)
1869 {
1870 lblanks = width - flt_str_len1 - flt_str_len2 - 3;
1871 write_x (dtp, lblanks, lblanks);
1872 }
1873 write_char (dtp, '(');
1874 write_float_string (dtp, result1, flt_str_len1);
1875 write_char (dtp, semi_comma);
1876 write_float_string (dtp, result2, flt_str_len2);
1877 write_char (dtp, ')');
1878
1879 dtp->u.p.scale_factor = orig_scale;
1880 dtp->u.p.g0_no_blanks = 0;
1881 if (buf_size > BUF_STACK_SZ)
1882 free (buffer);
1883 if (res_len1 > BUF_STACK_SZ)
1884 free (result1);
1885 if (res_len2 > BUF_STACK_SZ)
1886 free (result2);
1887 }
1888
1889
1890 /* Write the separator between items. */
1891
1892 static void
1893 write_separator (st_parameter_dt *dtp)
1894 {
1895 char *p;
1896
1897 p = write_block (dtp, options.separator_len);
1898 if (p == NULL)
1899 return;
1900 if (unlikely (is_char4_unit (dtp)))
1901 {
1902 gfc_char4_t *p4 = (gfc_char4_t *) p;
1903 memcpy4 (p4, options.separator, options.separator_len);
1904 }
1905 else
1906 memcpy (p, options.separator, options.separator_len);
1907 }
1908
1909
1910 /* Write an item with list formatting.
1911 TODO: handle skipping to the next record correctly, particularly
1912 with strings. */
1913
1914 static void
1915 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1916 size_t size)
1917 {
1918 if (dtp->u.p.current_unit == NULL)
1919 return;
1920
1921 if (dtp->u.p.first_item)
1922 {
1923 dtp->u.p.first_item = 0;
1924 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
1925 write_char (dtp, ' ');
1926 }
1927 else
1928 {
1929 if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1930 (dtp->u.p.current_unit->delim_status != DELIM_NONE
1931 && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
1932 write_separator (dtp);
1933 }
1934
1935 switch (type)
1936 {
1937 case BT_INTEGER:
1938 write_integer (dtp, p, kind);
1939 break;
1940 case BT_LOGICAL:
1941 write_logical (dtp, p, kind);
1942 break;
1943 case BT_CHARACTER:
1944 write_character (dtp, p, kind, size, DELIM);
1945 break;
1946 case BT_REAL:
1947 write_real (dtp, p, kind);
1948 break;
1949 case BT_COMPLEX:
1950 write_complex (dtp, p, kind, size);
1951 break;
1952 case BT_CLASS:
1953 {
1954 int unit = dtp->u.p.current_unit->unit_number;
1955 char iotype[] = "LISTDIRECTED";
1956 gfc_charlen_type iotype_len = 12;
1957 char tmp_iomsg[IOMSG_LEN] = "";
1958 char *child_iomsg;
1959 gfc_charlen_type child_iomsg_len;
1960 int noiostat;
1961 int *child_iostat = NULL;
1962 gfc_full_array_i4 vlist;
1963
1964 GFC_DESCRIPTOR_DATA(&vlist) = NULL;
1965 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
1966
1967 /* Set iostat, intent(out). */
1968 noiostat = 0;
1969 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
1970 dtp->common.iostat : &noiostat;
1971
1972 /* Set iomsge, intent(inout). */
1973 if (dtp->common.flags & IOPARM_HAS_IOMSG)
1974 {
1975 child_iomsg = dtp->common.iomsg;
1976 child_iomsg_len = dtp->common.iomsg_len;
1977 }
1978 else
1979 {
1980 child_iomsg = tmp_iomsg;
1981 child_iomsg_len = IOMSG_LEN;
1982 }
1983
1984 /* Call the user defined formatted WRITE procedure. */
1985 dtp->u.p.current_unit->child_dtio++;
1986 dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
1987 child_iostat, child_iomsg,
1988 iotype_len, child_iomsg_len);
1989 dtp->u.p.current_unit->child_dtio--;
1990 }
1991 break;
1992 default:
1993 internal_error (&dtp->common, "list_formatted_write(): Bad type");
1994 }
1995
1996 fbuf_flush_list (dtp->u.p.current_unit, LIST_WRITING);
1997 dtp->u.p.char_flag = (type == BT_CHARACTER);
1998 }
1999
2000
2001 void
2002 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
2003 size_t size, size_t nelems)
2004 {
2005 size_t elem;
2006 char *tmp;
2007 size_t stride = type == BT_CHARACTER ?
2008 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
2009
2010 tmp = (char *) p;
2011
2012 /* Big loop over all the elements. */
2013 for (elem = 0; elem < nelems; elem++)
2014 {
2015 dtp->u.p.item_count++;
2016 list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
2017 }
2018 }
2019
2020 /* NAMELIST OUTPUT
2021
2022 nml_write_obj writes a namelist object to the output stream. It is called
2023 recursively for derived type components:
2024 obj = is the namelist_info for the current object.
2025 offset = the offset relative to the address held by the object for
2026 derived type arrays.
2027 base = is the namelist_info of the derived type, when obj is a
2028 component.
2029 base_name = the full name for a derived type, including qualifiers
2030 if any.
2031 The returned value is a pointer to the object beyond the last one
2032 accessed, including nested derived types. Notice that the namelist is
2033 a linear linked list of objects, including derived types and their
2034 components. A tree, of sorts, is implied by the compound names of
2035 the derived type components and this is how this function recurses through
2036 the list. */
2037
2038 /* A generous estimate of the number of characters needed to print
2039 repeat counts and indices, including commas, asterices and brackets. */
2040
2041 #define NML_DIGITS 20
2042
2043 static void
2044 namelist_write_newline (st_parameter_dt *dtp)
2045 {
2046 if (!is_internal_unit (dtp))
2047 {
2048 #ifdef HAVE_CRLF
2049 write_character (dtp, "\r\n", 1, 2, NODELIM);
2050 #else
2051 write_character (dtp, "\n", 1, 1, NODELIM);
2052 #endif
2053 return;
2054 }
2055
2056 if (is_array_io (dtp))
2057 {
2058 gfc_offset record;
2059 int finished;
2060 char *p;
2061 int length = dtp->u.p.current_unit->bytes_left;
2062
2063 p = write_block (dtp, length);
2064 if (p == NULL)
2065 return;
2066
2067 if (unlikely (is_char4_unit (dtp)))
2068 {
2069 gfc_char4_t *p4 = (gfc_char4_t *) p;
2070 memset4 (p4, ' ', length);
2071 }
2072 else
2073 memset (p, ' ', length);
2074
2075 /* Now that the current record has been padded out,
2076 determine where the next record in the array is. */
2077 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2078 &finished);
2079 if (finished)
2080 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2081 else
2082 {
2083 /* Now seek to this record */
2084 record = record * dtp->u.p.current_unit->recl;
2085
2086 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
2087 {
2088 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2089 return;
2090 }
2091
2092 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2093 }
2094 }
2095 else
2096 write_character (dtp, " ", 1, 1, NODELIM);
2097 }
2098
2099
2100 static namelist_info *
2101 nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
2102 namelist_info *base, char *base_name)
2103 {
2104 int rep_ctr;
2105 int num;
2106 int nml_carry;
2107 int len;
2108 index_type obj_size;
2109 index_type nelem;
2110 size_t dim_i;
2111 size_t clen;
2112 index_type elem_ctr;
2113 size_t obj_name_len;
2114 void *p;
2115 char cup;
2116 char *obj_name;
2117 char *ext_name;
2118 char *q;
2119 size_t ext_name_len;
2120 char rep_buff[NML_DIGITS];
2121 namelist_info *cmp;
2122 namelist_info *retval = obj->next;
2123 size_t base_name_len;
2124 size_t base_var_name_len;
2125 size_t tot_len;
2126
2127 /* Set the character to be used to separate values
2128 to a comma or semi-colon. */
2129
2130 char semi_comma =
2131 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
2132
2133 /* Write namelist variable names in upper case. If a derived type,
2134 nothing is output. If a component, base and base_name are set. */
2135
2136 if (obj->type != BT_DERIVED || obj->dtio_sub != NULL)
2137 {
2138 namelist_write_newline (dtp);
2139 write_character (dtp, " ", 1, 1, NODELIM);
2140
2141 len = 0;
2142 if (base)
2143 {
2144 len = strlen (base->var_name);
2145 base_name_len = strlen (base_name);
2146 for (dim_i = 0; dim_i < base_name_len; dim_i++)
2147 {
2148 cup = safe_toupper (base_name[dim_i]);
2149 write_character (dtp, &cup, 1, 1, NODELIM);
2150 }
2151 }
2152 clen = strlen (obj->var_name);
2153 for (dim_i = len; dim_i < clen; dim_i++)
2154 {
2155 cup = safe_toupper (obj->var_name[dim_i]);
2156 if (cup == '+')
2157 cup = '%';
2158 write_character (dtp, &cup, 1, 1, NODELIM);
2159 }
2160 write_character (dtp, "=", 1, 1, NODELIM);
2161 }
2162
2163 /* Counts the number of data output on a line, including names. */
2164
2165 num = 1;
2166
2167 len = obj->len;
2168
2169 switch (obj->type)
2170 {
2171
2172 case BT_REAL:
2173 obj_size = size_from_real_kind (len);
2174 break;
2175
2176 case BT_COMPLEX:
2177 obj_size = size_from_complex_kind (len);
2178 break;
2179
2180 case BT_CHARACTER:
2181 obj_size = obj->string_length;
2182 break;
2183
2184 default:
2185 obj_size = len;
2186 }
2187
2188 if (obj->var_rank)
2189 obj_size = obj->size;
2190
2191 /* Set the index vector and count the number of elements. */
2192
2193 nelem = 1;
2194 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
2195 {
2196 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
2197 nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
2198 }
2199
2200 /* Main loop to output the data held in the object. */
2201
2202 rep_ctr = 1;
2203 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
2204 {
2205
2206 /* Build the pointer to the data value. The offset is passed by
2207 recursive calls to this function for arrays of derived types.
2208 Is NULL otherwise. */
2209
2210 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
2211 p += offset;
2212
2213 /* Check for repeat counts of intrinsic types. */
2214
2215 if ((elem_ctr < (nelem - 1)) &&
2216 (obj->type != BT_DERIVED) &&
2217 !memcmp (p, (void *)(p + obj_size ), obj_size ))
2218 {
2219 rep_ctr++;
2220 }
2221
2222 /* Execute a repeated output. Note the flag no_leading_blank that
2223 is used in the functions used to output the intrinsic types. */
2224
2225 else
2226 {
2227 if (rep_ctr > 1)
2228 {
2229 snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
2230 write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
2231 dtp->u.p.no_leading_blank = 1;
2232 }
2233 num++;
2234
2235 /* Output the data, if an intrinsic type, or recurse into this
2236 routine to treat derived types. */
2237
2238 switch (obj->type)
2239 {
2240
2241 case BT_INTEGER:
2242 write_integer (dtp, p, len);
2243 break;
2244
2245 case BT_LOGICAL:
2246 write_logical (dtp, p, len);
2247 break;
2248
2249 case BT_CHARACTER:
2250 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
2251 write_character (dtp, p, 4, obj->string_length, DELIM);
2252 else
2253 write_character (dtp, p, 1, obj->string_length, DELIM);
2254 break;
2255
2256 case BT_REAL:
2257 write_real (dtp, p, len);
2258 break;
2259
2260 case BT_COMPLEX:
2261 dtp->u.p.no_leading_blank = 0;
2262 num++;
2263 write_complex (dtp, p, len, obj_size);
2264 break;
2265
2266 case BT_DERIVED:
2267 case BT_CLASS:
2268 /* To treat a derived type, we need to build two strings:
2269 ext_name = the name, including qualifiers that prepends
2270 component names in the output - passed to
2271 nml_write_obj.
2272 obj_name = the derived type name with no qualifiers but %
2273 appended. This is used to identify the
2274 components. */
2275
2276 /* First ext_name => get length of all possible components */
2277 if (obj->dtio_sub != NULL)
2278 {
2279 int unit = dtp->u.p.current_unit->unit_number;
2280 char iotype[] = "NAMELIST";
2281 gfc_charlen_type iotype_len = 8;
2282 char tmp_iomsg[IOMSG_LEN] = "";
2283 char *child_iomsg;
2284 gfc_charlen_type child_iomsg_len;
2285 int noiostat;
2286 int *child_iostat = NULL;
2287 gfc_full_array_i4 vlist;
2288 formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
2289
2290 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
2291
2292 /* Set iostat, intent(out). */
2293 noiostat = 0;
2294 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
2295 dtp->common.iostat : &noiostat;
2296
2297 /* Set iomsg, intent(inout). */
2298 if (dtp->common.flags & IOPARM_HAS_IOMSG)
2299 {
2300 child_iomsg = dtp->common.iomsg;
2301 child_iomsg_len = dtp->common.iomsg_len;
2302 }
2303 else
2304 {
2305 child_iomsg = tmp_iomsg;
2306 child_iomsg_len = IOMSG_LEN;
2307 }
2308
2309 /* Call the user defined formatted WRITE procedure. */
2310 dtp->u.p.current_unit->child_dtio++;
2311 if (obj->type == BT_DERIVED)
2312 {
2313 /* Build a class container. */
2314 gfc_class list_obj;
2315 list_obj.data = p;
2316 list_obj.vptr = obj->vtable;
2317 list_obj.len = 0;
2318 dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
2319 child_iostat, child_iomsg,
2320 iotype_len, child_iomsg_len);
2321 }
2322 else
2323 {
2324 dtio_ptr (p, &unit, iotype, &vlist,
2325 child_iostat, child_iomsg,
2326 iotype_len, child_iomsg_len);
2327 }
2328 dtp->u.p.current_unit->child_dtio--;
2329
2330 goto obj_loop;
2331 }
2332
2333 base_name_len = base_name ? strlen (base_name) : 0;
2334 base_var_name_len = base ? strlen (base->var_name) : 0;
2335 ext_name_len = base_name_len + base_var_name_len
2336 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
2337 ext_name = xmalloc (ext_name_len);
2338
2339 if (base_name)
2340 memcpy (ext_name, base_name, base_name_len);
2341 clen = strlen (obj->var_name + base_var_name_len);
2342 memcpy (ext_name + base_name_len,
2343 obj->var_name + base_var_name_len, clen);
2344
2345 /* Append the qualifier. */
2346
2347 tot_len = base_name_len + clen;
2348 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
2349 {
2350 if (!dim_i)
2351 {
2352 ext_name[tot_len] = '(';
2353 tot_len++;
2354 }
2355 snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
2356 (int) obj->ls[dim_i].idx);
2357 tot_len += strlen (ext_name + tot_len);
2358 ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
2359 tot_len++;
2360 }
2361
2362 ext_name[tot_len] = '\0';
2363 for (q = ext_name; *q; q++)
2364 if (*q == '+')
2365 *q = '%';
2366
2367 /* Now obj_name. */
2368
2369 obj_name_len = strlen (obj->var_name) + 1;
2370 obj_name = xmalloc (obj_name_len + 1);
2371 memcpy (obj_name, obj->var_name, obj_name_len-1);
2372 memcpy (obj_name + obj_name_len-1, "%", 2);
2373
2374 /* Now loop over the components. Update the component pointer
2375 with the return value from nml_write_obj => this loop jumps
2376 past nested derived types. */
2377
2378 for (cmp = obj->next;
2379 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
2380 cmp = retval)
2381 {
2382 retval = nml_write_obj (dtp, cmp,
2383 (index_type)(p - obj->mem_pos),
2384 obj, ext_name);
2385 }
2386
2387 free (obj_name);
2388 free (ext_name);
2389 goto obj_loop;
2390
2391 default:
2392 internal_error (&dtp->common, "Bad type for namelist write");
2393 }
2394
2395 /* Reset the leading blank suppression, write a comma (or semi-colon)
2396 and, if 5 values have been output, write a newline and advance
2397 to column 2. Reset the repeat counter. */
2398
2399 dtp->u.p.no_leading_blank = 0;
2400 if (obj->type == BT_CHARACTER)
2401 {
2402 if (dtp->u.p.nml_delim != '\0')
2403 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2404 }
2405 else
2406 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2407 if (num > 5)
2408 {
2409 num = 0;
2410 if (dtp->u.p.nml_delim == '\0')
2411 write_character (dtp, &semi_comma, 1, 1, NODELIM);
2412 namelist_write_newline (dtp);
2413 write_character (dtp, " ", 1, 1, NODELIM);
2414 }
2415 rep_ctr = 1;
2416 }
2417
2418 /* Cycle through and increment the index vector. */
2419
2420 obj_loop:
2421
2422 nml_carry = 1;
2423 for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
2424 {
2425 obj->ls[dim_i].idx += nml_carry ;
2426 nml_carry = 0;
2427 if (obj->ls[dim_i].idx > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
2428 {
2429 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
2430 nml_carry = 1;
2431 }
2432 }
2433 }
2434
2435 /* Return a pointer beyond the furthest object accessed. */
2436
2437 return retval;
2438 }
2439
2440
2441 /* This is the entry function for namelist writes. It outputs the name
2442 of the namelist and iterates through the namelist by calls to
2443 nml_write_obj. The call below has dummys in the arguments used in
2444 the treatment of derived types. */
2445
2446 void
2447 namelist_write (st_parameter_dt *dtp)
2448 {
2449 namelist_info *t1, *t2, *dummy = NULL;
2450 index_type dummy_offset = 0;
2451 char c;
2452 char *dummy_name = NULL;
2453
2454 /* Set the delimiter for namelist output. */
2455 switch (dtp->u.p.current_unit->delim_status)
2456 {
2457 case DELIM_APOSTROPHE:
2458 dtp->u.p.nml_delim = '\'';
2459 break;
2460 case DELIM_QUOTE:
2461 case DELIM_UNSPECIFIED:
2462 dtp->u.p.nml_delim = '"';
2463 break;
2464 default:
2465 dtp->u.p.nml_delim = '\0';
2466 }
2467
2468 write_character (dtp, "&", 1, 1, NODELIM);
2469
2470 /* Write namelist name in upper case - f95 std. */
2471 for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ )
2472 {
2473 c = safe_toupper (dtp->namelist_name[i]);
2474 write_character (dtp, &c, 1 ,1, NODELIM);
2475 }
2476
2477 if (dtp->u.p.ionml != NULL)
2478 {
2479 t1 = dtp->u.p.ionml;
2480 while (t1 != NULL)
2481 {
2482 t2 = t1;
2483 t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
2484 }
2485 }
2486
2487 namelist_write_newline (dtp);
2488 write_character (dtp, " /", 1, 2, NODELIM);
2489 }
2490
2491 #undef NML_DIGITS