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