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
6This file is part of the GNU Fortran runtime library (libgfortran).
7
8Libgfortran is free software; you can redistribute it and/or modify
9it under the terms of the GNU General Public License as published by
10the Free Software Foundation; either version 3, or (at your option)
11any later version.
12
13Libgfortran is distributed in the hope that it will be useful,
14but WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16GNU General Public License for more details.
17
18Under Section 7 of GPL version 3, you are granted additional
19permissions described in the GCC Runtime Library Exception, version
203.1, as published by the Free Software Foundation.
21
22You should have received a copy of the GNU General Public License and
23a copy of the GCC Runtime Library Exception along with this program;
24see 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
37typedef unsigned char uchar;
38
39/* Helper functions for character(kind=4) internal units.  These are needed
40   by write_float.def.  */
41
42static void
43memcpy4 (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
57static void
58write_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
145static void
146write_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
237static void
238write_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
313static char *
314write_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
362void
363
364write_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
474void
475write_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
551static GFC_INTEGER_LARGEST
552extract_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
605static GFC_UINTEGER_LARGEST
606extract_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
661void
662write_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
688static void
689write_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
797static void
798write_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
951static const char *
952otoa (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
976static const char *
977btoa (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
1005static const char *
1006btoa_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
1064static const char *
1065otoa_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
1138static const char *
1139ztoa_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
1194void
1195write_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
1201void
1202write_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
1225void
1226write_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
1245void
1246write_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
1267void
1268write_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
1294static int
1295write_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
1317static void
1318write_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
1326static void
1327write_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
1371static void
1372write_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
1480static int
1481get_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.  */
1494static int
1495size_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
1526static char *
1527select_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
1543static char *
1544select_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
1556static void
1557write_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
1573static void
1574write_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
1599void
1600write_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
1606void
1607write_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
1613void
1614write_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
1620void
1621write_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
1627void
1628write_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
1636static void
1637set_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
1687void
1688write_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
1722void
1723write_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
1775static void
1776write_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
1840static void
1841write_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
1862static void
1863list_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
1949void
1950list_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
1991static void
1992namelist_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
2048static namelist_info *
2049nml_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
2368obj_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
2394void
2395namelist_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