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