OSDN Git Service

PR 48488 Fix comments
[pf3gnuchains/gcc-fork.git] / libgfortran / io / write.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4    Namelist output contributed by Paul Thomas
5    F2003 I/O support contributed by Jerry DeLisle
6
7 This file is part of the GNU Fortran runtime library (libgfortran).
8
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
12 any later version.
13
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 GNU General Public License for more details.
18
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
22
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
26 <http://www.gnu.org/licenses/>.  */
27
28 #include "io.h"
29 #include "format.h"
30 #include "unix.h"
31 #include <assert.h>
32 #include <string.h>
33 #include <ctype.h>
34 #include <stdlib.h>
35 #include <stdbool.h>
36 #include <errno.h>
37 #define star_fill(p, n) memset(p, '*', n)
38
39 typedef unsigned char uchar;
40
41 /* Helper functions for character(kind=4) internal units.  These are needed
42    by write_float.def.  */
43
44 static inline void
45 memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
46 {
47   int j;
48   for (j = 0; j < k; j++)
49     *p++ = c;
50 }
51
52 static inline void
53 memcpy4 (gfc_char4_t *dest, const char *source, int k)
54 {
55   int j;
56   
57   const char *p = source;
58   for (j = 0; j < k; j++)
59     *dest++ = (gfc_char4_t) *p++;
60 }
61
62 /* This include contains the heart and soul of formatted floating point.  */
63 #include "write_float.def"
64
65 /* Write out default char4.  */
66
67 static void
68 write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
69                      int src_len, int w_len)
70 {
71   char *p;
72   int j, k = 0;
73   gfc_char4_t c;
74   uchar d;
75       
76   /* Take care of preceding blanks.  */
77   if (w_len > src_len)
78     {
79       k = w_len - src_len;
80       p = write_block (dtp, k);
81       if (p == NULL)
82         return;
83       if (is_char4_unit (dtp))
84         {
85           gfc_char4_t *p4 = (gfc_char4_t *) p;
86           memset4 (p4, ' ', k);
87         }
88       else
89         memset (p, ' ', k);
90     }
91
92   /* Get ready to handle delimiters if needed.  */
93   switch (dtp->u.p.current_unit->delim_status)
94     {
95     case DELIM_APOSTROPHE:
96       d = '\'';
97       break;
98     case DELIM_QUOTE:
99       d = '"';
100       break;
101     default:
102       d = ' ';
103       break;
104     }
105
106   /* Now process the remaining characters, one at a time.  */
107   for (j = 0; j < src_len; j++)
108     {
109       c = source[j];
110       if (is_char4_unit (dtp))
111         {
112           gfc_char4_t *q;
113           /* Handle delimiters if any.  */
114           if (c == d && d != ' ')
115             {
116               p = write_block (dtp, 2);
117               if (p == NULL)
118                 return;
119               q = (gfc_char4_t *) p;
120               *q++ = c;
121             }
122           else
123             {
124               p = write_block (dtp, 1);
125               if (p == NULL)
126                 return;
127               q = (gfc_char4_t *) p;
128             }
129           *q = c;
130         }
131       else
132         {
133           /* Handle delimiters if any.  */
134           if (c == d && d != ' ')
135             {
136               p = write_block (dtp, 2);
137               if (p == NULL)
138                 return;
139               *p++ = (uchar) c;
140             }
141           else
142             {
143               p = write_block (dtp, 1);
144               if (p == NULL)
145                 return;
146             }
147             *p = c > 255 ? '?' : (uchar) c;
148         }
149     }
150 }
151
152
153 /* Write out UTF-8 converted from char4.  */
154
155 static void
156 write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
157                      int src_len, int w_len)
158 {
159   char *p;
160   int j, k = 0;
161   gfc_char4_t c;
162   static const uchar masks[6] =  { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
163   static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
164   int nbytes;
165   uchar buf[6], d, *q; 
166
167   /* Take care of preceding blanks.  */
168   if (w_len > src_len)
169     {
170       k = w_len - src_len;
171       p = write_block (dtp, k);
172       if (p == NULL)
173         return;
174       memset (p, ' ', k);
175     }
176
177   /* Get ready to handle delimiters if needed.  */
178   switch (dtp->u.p.current_unit->delim_status)
179     {
180     case DELIM_APOSTROPHE:
181       d = '\'';
182       break;
183     case DELIM_QUOTE:
184       d = '"';
185       break;
186     default:
187       d = ' ';
188       break;
189     }
190
191   /* Now process the remaining characters, one at a time.  */
192   for (j = k; j < src_len; j++)
193     {
194       c = source[j];
195       if (c < 0x80)
196         {
197           /* Handle the delimiters if any.  */
198           if (c == d && d != ' ')
199             {
200               p = write_block (dtp, 2);
201               if (p == NULL)
202                 return;
203               *p++ = (uchar) c;
204             }
205           else
206             {
207               p = write_block (dtp, 1);
208               if (p == NULL)
209                 return;
210             }
211           *p = (uchar) c;
212         }
213       else
214         {
215           /* Convert to UTF-8 sequence.  */
216           nbytes = 1;
217           q = &buf[6];
218
219           do
220             {
221               *--q = ((c & 0x3F) | 0x80);
222               c >>= 6;
223               nbytes++;
224             }
225           while (c >= 0x3F || (c & limits[nbytes-1]));
226
227           *--q = (c | masks[nbytes-1]);
228
229           p = write_block (dtp, nbytes);
230           if (p == NULL)
231             return;
232
233           while (q < &buf[6])
234             *p++ = *q++;
235         }
236     }
237 }
238
239
240 void
241 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
242 {
243   int wlen;
244   char *p;
245
246   wlen = f->u.string.length < 0
247          || (f->format == FMT_G && f->u.string.length == 0)
248          ? len : f->u.string.length;
249
250 #ifdef HAVE_CRLF
251   /* If this is formatted STREAM IO convert any embedded line feed characters
252      to CR_LF on systems that use that sequence for newlines.  See F2003
253      Standard sections 10.6.3 and 9.9 for further information.  */
254   if (is_stream_io (dtp))
255     {
256       const char crlf[] = "\r\n";
257       int i, q, bytes;
258       q = bytes = 0;
259
260       /* Write out any padding if needed.  */
261       if (len < wlen)
262         {
263           p = write_block (dtp, wlen - len);
264           if (p == NULL)
265             return;
266           memset (p, ' ', wlen - len);
267         }
268
269       /* Scan the source string looking for '\n' and convert it if found.  */
270       for (i = 0; i < wlen; i++)
271         {
272           if (source[i] == '\n')
273             {
274               /* Write out the previously scanned characters in the string.  */
275               if (bytes > 0)
276                 {
277                   p = write_block (dtp, bytes);
278                   if (p == NULL)
279                     return;
280                   memcpy (p, &source[q], bytes);
281                   q += bytes;
282                   bytes = 0;
283                 }
284
285               /* Write out the CR_LF sequence.  */ 
286               q++;
287               p = write_block (dtp, 2);
288               if (p == NULL)
289                 return;
290               memcpy (p, crlf, 2);
291             }
292           else
293             bytes++;
294         }
295
296       /*  Write out any remaining bytes if no LF was found.  */
297       if (bytes > 0)
298         {
299           p = write_block (dtp, bytes);
300           if (p == NULL)
301             return;
302           memcpy (p, &source[q], bytes);
303         }
304     }
305   else
306     {
307 #endif
308       p = write_block (dtp, wlen);
309       if (p == NULL)
310         return;
311
312       if (unlikely (is_char4_unit (dtp)))
313         {
314           gfc_char4_t *p4 = (gfc_char4_t *) p;
315           if (wlen < len)
316             memcpy4 (p4, source, wlen);
317           else
318             {
319               memset4 (p4, ' ', wlen - len);
320               memcpy4 (p4 + wlen - len, source, len);
321             }
322           return;
323         }
324
325       if (wlen < len)
326         memcpy (p, source, wlen);
327       else
328         {
329           memset (p, ' ', wlen - len);
330           memcpy (p + wlen - len, source, len);
331         }
332 #ifdef HAVE_CRLF
333     }
334 #endif
335 }
336
337
338 /* The primary difference between write_a_char4 and write_a is that we have to
339    deal with writing from the first byte of the 4-byte character and pay
340    attention to the most significant bytes.  For ENCODING="default" write the
341    lowest significant byte. If the 3 most significant bytes contain
342    non-zero values, emit a '?'.  For ENCODING="utf-8", convert the UCS-32 value
343    to the UTF-8 encoded string before writing out.  */
344
345 void
346 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
347 {
348   int wlen;
349   gfc_char4_t *q;
350
351   wlen = f->u.string.length < 0
352          || (f->format == FMT_G && f->u.string.length == 0)
353          ? len : f->u.string.length;
354
355   q = (gfc_char4_t *) source;
356 #ifdef HAVE_CRLF
357   /* If this is formatted STREAM IO convert any embedded line feed characters
358      to CR_LF on systems that use that sequence for newlines.  See F2003
359      Standard sections 10.6.3 and 9.9 for further information.  */
360   if (is_stream_io (dtp))
361     {
362       const gfc_char4_t crlf[] = {0x000d,0x000a};
363       int i, bytes;
364       gfc_char4_t *qq;
365       bytes = 0;
366
367       /* Write out any padding if needed.  */
368       if (len < wlen)
369         {
370           char *p;
371           p = write_block (dtp, wlen - len);
372           if (p == NULL)
373             return;
374           memset (p, ' ', wlen - len);
375         }
376
377       /* Scan the source string looking for '\n' and convert it if found.  */
378       qq = (gfc_char4_t *) source;
379       for (i = 0; i < wlen; i++)
380         {
381           if (qq[i] == '\n')
382             {
383               /* Write out the previously scanned characters in the string.  */
384               if (bytes > 0)
385                 {
386                   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
387                     write_utf8_char4 (dtp, q, bytes, 0);
388                   else
389                     write_default_char4 (dtp, q, bytes, 0);
390                   bytes = 0;
391                 }
392
393               /* Write out the CR_LF sequence.  */ 
394               write_default_char4 (dtp, crlf, 2, 0);
395             }
396           else
397             bytes++;
398         }
399
400       /*  Write out any remaining bytes if no LF was found.  */
401       if (bytes > 0)
402         {
403           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
404             write_utf8_char4 (dtp, q, bytes, 0);
405           else
406             write_default_char4 (dtp, q, bytes, 0);
407         }
408     }
409   else
410     {
411 #endif
412       if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
413         write_utf8_char4 (dtp, q, len, wlen);
414       else
415         write_default_char4 (dtp, q, len, wlen);
416 #ifdef HAVE_CRLF
417     }
418 #endif
419 }
420
421
422 static GFC_INTEGER_LARGEST
423 extract_int (const void *p, int len)
424 {
425   GFC_INTEGER_LARGEST i = 0;
426
427   if (p == NULL)
428     return i;
429
430   switch (len)
431     {
432     case 1:
433       {
434         GFC_INTEGER_1 tmp;
435         memcpy ((void *) &tmp, p, len);
436         i = tmp;
437       }
438       break;
439     case 2:
440       {
441         GFC_INTEGER_2 tmp;
442         memcpy ((void *) &tmp, p, len);
443         i = tmp;
444       }
445       break;
446     case 4:
447       {
448         GFC_INTEGER_4 tmp;
449         memcpy ((void *) &tmp, p, len);
450         i = tmp;
451       }
452       break;
453     case 8:
454       {
455         GFC_INTEGER_8 tmp;
456         memcpy ((void *) &tmp, p, len);
457         i = tmp;
458       }
459       break;
460 #ifdef HAVE_GFC_INTEGER_16
461     case 16:
462       {
463         GFC_INTEGER_16 tmp;
464         memcpy ((void *) &tmp, p, len);
465         i = tmp;
466       }
467       break;
468 #endif
469     default:
470       internal_error (NULL, "bad integer kind");
471     }
472
473   return i;
474 }
475
476 static GFC_UINTEGER_LARGEST
477 extract_uint (const void *p, int len)
478 {
479   GFC_UINTEGER_LARGEST i = 0;
480
481   if (p == NULL)
482     return i;
483
484   switch (len)
485     {
486     case 1:
487       {
488         GFC_INTEGER_1 tmp;
489         memcpy ((void *) &tmp, p, len);
490         i = (GFC_UINTEGER_1) tmp;
491       }
492       break;
493     case 2:
494       {
495         GFC_INTEGER_2 tmp;
496         memcpy ((void *) &tmp, p, len);
497         i = (GFC_UINTEGER_2) tmp;
498       }
499       break;
500     case 4:
501       {
502         GFC_INTEGER_4 tmp;
503         memcpy ((void *) &tmp, p, len);
504         i = (GFC_UINTEGER_4) tmp;
505       }
506       break;
507     case 8:
508       {
509         GFC_INTEGER_8 tmp;
510         memcpy ((void *) &tmp, p, len);
511         i = (GFC_UINTEGER_8) tmp;
512       }
513       break;
514 #ifdef HAVE_GFC_INTEGER_16
515     case 10:
516     case 16:
517       {
518         GFC_INTEGER_16 tmp = 0;
519         memcpy ((void *) &tmp, p, len);
520         i = (GFC_UINTEGER_16) tmp;
521       }
522       break;
523 #endif
524     default:
525       internal_error (NULL, "bad integer kind");
526     }
527
528   return i;
529 }
530
531
532 void
533 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
534 {
535   char *p;
536   int wlen;
537   GFC_INTEGER_LARGEST n;
538
539   wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
540   
541   p = write_block (dtp, wlen);
542   if (p == NULL)
543     return;
544
545   n = extract_int (source, len);
546
547   if (unlikely (is_char4_unit (dtp)))
548     {
549       gfc_char4_t *p4 = (gfc_char4_t *) p;
550       memset4 (p4, ' ', wlen -1);
551       p4[wlen - 1] = (n) ? 'T' : 'F';
552       return;
553     }
554
555   memset (p, ' ', wlen -1);
556   p[wlen - 1] = (n) ? 'T' : 'F';
557 }
558
559
560 static void
561 write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
562 {
563   int w, m, digits, nzero, nblank;
564   char *p;
565
566   w = f->u.integer.w;
567   m = f->u.integer.m;
568
569   /* Special case:  */
570
571   if (m == 0 && n == 0)
572     {
573       if (w == 0)
574         w = 1;
575
576       p = write_block (dtp, w);
577       if (p == NULL)
578         return;
579       if (unlikely (is_char4_unit (dtp)))
580         {
581           gfc_char4_t *p4 = (gfc_char4_t *) p;
582           memset4 (p4, ' ', w);
583         }
584       else
585         memset (p, ' ', w);
586       goto done;
587     }
588
589   digits = strlen (q);
590
591   /* Select a width if none was specified.  The idea here is to always
592      print something.  */
593
594   if (w == 0)
595     w = ((digits < m) ? m : digits);
596
597   p = write_block (dtp, w);
598   if (p == NULL)
599     return;
600
601   nzero = 0;
602   if (digits < m)
603     nzero = m - digits;
604
605   /* See if things will work.  */
606
607   nblank = w - (nzero + digits);
608
609   if (unlikely (is_char4_unit (dtp)))
610     {
611       gfc_char4_t *p4 = (gfc_char4_t *) p;
612       if (nblank < 0)
613         {
614           memset4 (p4, '*', w);
615           return;
616         }
617
618       if (!dtp->u.p.no_leading_blank)
619         {
620           memset4 (p4, ' ', nblank);
621           q += nblank;
622           memset4 (p4, '0', nzero);
623           q += nzero;
624           memcpy4 (p4, q, digits);
625         }
626       else
627         {
628           memset4 (p4, '0', nzero);
629           q += nzero;
630           memcpy4 (p4, q, digits);
631           q += digits;
632           memset4 (p4, ' ', nblank);
633           dtp->u.p.no_leading_blank = 0;
634         }
635       return;
636     }
637
638   if (nblank < 0)
639     {
640       star_fill (p, w);
641       goto done;
642     }
643
644   if (!dtp->u.p.no_leading_blank)
645     {
646       memset (p, ' ', nblank);
647       p += nblank;
648       memset (p, '0', nzero);
649       p += nzero;
650       memcpy (p, q, digits);
651     }
652   else
653     {
654       memset (p, '0', nzero);
655       p += nzero;
656       memcpy (p, q, digits);
657       p += digits;
658       memset (p, ' ', nblank);
659       dtp->u.p.no_leading_blank = 0;
660     }
661
662  done:
663   return;
664 }
665
666 static void
667 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
668                int len,
669                const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
670 {
671   GFC_INTEGER_LARGEST n = 0;
672   int w, m, digits, nsign, nzero, nblank;
673   char *p;
674   const char *q;
675   sign_t sign;
676   char itoa_buf[GFC_BTOA_BUF_SIZE];
677
678   w = f->u.integer.w;
679   m = f->format == FMT_G ? -1 : f->u.integer.m;
680
681   n = extract_int (source, len);
682
683   /* Special case:  */
684   if (m == 0 && n == 0)
685     {
686       if (w == 0)
687         w = 1;
688
689       p = write_block (dtp, w);
690       if (p == NULL)
691         return;
692       if (unlikely (is_char4_unit (dtp)))
693         {
694           gfc_char4_t *p4 = (gfc_char4_t *) p;
695           memset4 (p4, ' ', w);
696         }
697       else
698         memset (p, ' ', w);
699       goto done;
700     }
701
702   sign = calculate_sign (dtp, n < 0);
703   if (n < 0)
704     n = -n;
705   nsign = sign == S_NONE ? 0 : 1;
706   
707   /* conv calls itoa which sets the negative sign needed
708      by write_integer. The sign '+' or '-' is set below based on sign
709      calculated above, so we just point past the sign in the string
710      before proceeding to avoid double signs in corner cases.
711      (see PR38504)  */
712   q = conv (n, itoa_buf, sizeof (itoa_buf));
713   if (*q == '-')
714     q++;
715
716   digits = strlen (q);
717
718   /* Select a width if none was specified.  The idea here is to always
719      print something.  */
720
721   if (w == 0)
722     w = ((digits < m) ? m : digits) + nsign;
723
724   p = write_block (dtp, w);
725   if (p == NULL)
726     return;
727
728   nzero = 0;
729   if (digits < m)
730     nzero = m - digits;
731
732   /* See if things will work.  */
733
734   nblank = w - (nsign + nzero + digits);
735
736   if (unlikely (is_char4_unit (dtp)))
737     {
738       gfc_char4_t * p4 = (gfc_char4_t *) p;
739       if (nblank < 0)
740         {
741           memset4 (p4, '*', w);
742           goto done;
743         }
744
745       memset4 (p4, ' ', nblank);
746       p4 += nblank;
747
748       switch (sign)
749         {
750         case S_PLUS:
751           *p4++ = '+';
752           break;
753         case S_MINUS:
754           *p4++ = '-';
755           break;
756         case S_NONE:
757           break;
758         }
759
760       memset4 (p4, '0', nzero);
761       p4 += nzero;
762
763       memcpy4 (p4, q, digits);
764       return;
765     }
766
767   if (nblank < 0)
768     {
769       star_fill (p, w);
770       goto done;
771     }
772
773   memset (p, ' ', nblank);
774   p += nblank;
775
776   switch (sign)
777     {
778     case S_PLUS:
779       *p++ = '+';
780       break;
781     case S_MINUS:
782       *p++ = '-';
783       break;
784     case S_NONE:
785       break;
786     }
787
788   memset (p, '0', nzero);
789   p += nzero;
790
791   memcpy (p, q, digits);
792
793  done:
794   return;
795 }
796
797
798 /* Convert unsigned octal to ascii.  */
799
800 static const char *
801 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
802 {
803   char *p;
804
805   assert (len >= GFC_OTOA_BUF_SIZE);
806
807   if (n == 0)
808     return "0";
809
810   p = buffer + GFC_OTOA_BUF_SIZE - 1;
811   *p = '\0';
812
813   while (n != 0)
814     {
815       *--p = '0' + (n & 7);
816       n >>= 3;
817     }
818
819   return p;
820 }
821
822
823 /* Convert unsigned binary to ascii.  */
824
825 static const char *
826 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
827 {
828   char *p;
829
830   assert (len >= GFC_BTOA_BUF_SIZE);
831
832   if (n == 0)
833     return "0";
834
835   p = buffer + GFC_BTOA_BUF_SIZE - 1;
836   *p = '\0';
837
838   while (n != 0)
839     {
840       *--p = '0' + (n & 1);
841       n >>= 1;
842     }
843
844   return p;
845 }
846
847 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
848    to convert large reals with kind sizes that exceed the largest integer type
849    available on certain platforms.  In these cases, byte by byte conversion is
850    performed. Endianess is taken into account.  */
851
852 /* Conversion to binary.  */
853
854 static const char *
855 btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
856 {
857   char *q;
858   int i, j;
859   
860   q = buffer;
861   if (big_endian)
862     {
863       const char *p = s;
864       for (i = 0; i < len; i++)
865         {
866           char c = *p;
867
868           /* Test for zero. Needed by write_boz later.  */
869           if (*p != 0)
870             *n = 1;
871
872           for (j = 0; j < 8; j++)
873             {
874               *q++ = (c & 128) ? '1' : '0';
875               c <<= 1;
876             }
877           p++;
878         }
879     }
880   else
881     {
882       const char *p = s + len - 1;
883       for (i = 0; i < len; i++)
884         {
885           char c = *p;
886
887           /* Test for zero. Needed by write_boz later.  */
888           if (*p != 0)
889             *n = 1;
890
891           for (j = 0; j < 8; j++)
892             {
893               *q++ = (c & 128) ? '1' : '0';
894               c <<= 1;
895             }
896           p--;
897         }
898     }
899
900   *q = '\0';
901
902   if (*n == 0)
903     return "0";
904
905   /* Move past any leading zeros.  */  
906   while (*buffer == '0')
907     buffer++;
908
909   return buffer;
910
911 }
912
913 /* Conversion to octal.  */
914
915 static const char *
916 otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
917 {
918   char *q;
919   int i, j, k;
920   uint8_t octet;
921
922   q = buffer + GFC_OTOA_BUF_SIZE - 1;
923   *q = '\0';
924   i = k = octet = 0;
925
926   if (big_endian)
927     {
928       const char *p = s + len - 1;
929       char c = *p;
930       while (i < len)
931         {
932           /* Test for zero. Needed by write_boz later.  */
933           if (*p != 0)
934             *n = 1;
935
936           for (j = 0; j < 3 && i < len; j++)
937             {
938               octet |= (c & 1) << j;
939               c >>= 1;
940               if (++k > 7)
941                 {
942                   i++;
943                   k = 0;
944                   c = *--p;
945                 }
946             }
947           *--q = '0' + octet;
948           octet = 0;
949         }
950     }
951   else
952     {
953       const char *p = s;
954       char c = *p;
955       while (i < len)
956         {
957           /* Test for zero. Needed by write_boz later.  */
958           if (*p != 0)
959             *n = 1;
960
961           for (j = 0; j < 3 && i < len; j++)
962             {
963               octet |= (c & 1) << j;
964               c >>= 1;
965               if (++k > 7)
966                 {
967                   i++;
968                   k = 0;
969                   c = *++p;
970                 }
971             }
972           *--q = '0' + octet;
973           octet = 0;
974         }
975     }
976
977   if (*n == 0)
978     return "0";
979
980   /* Move past any leading zeros.  */  
981   while (*q == '0')
982     q++;
983
984   return q;
985 }
986
987 /* Conversion to hexidecimal.  */
988
989 static const char *
990 ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
991 {
992   static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
993     '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
994
995   char *q;
996   uint8_t h, l;
997   int i;
998   
999   q = buffer;
1000   
1001   if (big_endian)
1002     {
1003       const char *p = s;
1004       for (i = 0; i < len; i++)
1005         {
1006           /* Test for zero. Needed by write_boz later.  */
1007           if (*p != 0)
1008             *n = 1;
1009
1010           h = (*p >> 4) & 0x0F;
1011           l = *p++ & 0x0F;
1012           *q++ = a[h];
1013           *q++ = a[l];
1014         }
1015     }
1016   else
1017     {
1018       const char *p = s + len - 1;
1019       for (i = 0; i < len; i++)
1020         {
1021           /* Test for zero. Needed by write_boz later.  */
1022           if (*p != 0)
1023             *n = 1;
1024
1025           h = (*p >> 4) & 0x0F;
1026           l = *p-- & 0x0F;
1027           *q++ = a[h];
1028           *q++ = a[l];
1029         }
1030     }
1031
1032   *q = '\0';
1033   
1034   if (*n == 0)
1035     return "0";
1036     
1037   /* Move past any leading zeros.  */  
1038   while (*buffer == '0')
1039     buffer++;
1040
1041   return buffer;
1042 }
1043
1044 /* gfc_itoa()-- Integer to decimal conversion.
1045    The itoa function is a widespread non-standard extension to standard
1046    C, often declared in <stdlib.h>.  Even though the itoa defined here
1047    is a static function we take care not to conflict with any prior
1048    non-static declaration.  Hence the 'gfc_' prefix, which is normally
1049    reserved for functions with external linkage.  */
1050
1051 static const char *
1052 gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
1053 {
1054   int negative;
1055   char *p;
1056   GFC_UINTEGER_LARGEST t;
1057
1058   assert (len >= GFC_ITOA_BUF_SIZE);
1059
1060   if (n == 0)
1061     return "0";
1062
1063   negative = 0;
1064   t = n;
1065   if (n < 0)
1066     {
1067       negative = 1;
1068       t = -n; /*must use unsigned to protect from overflow*/
1069     }
1070
1071   p = buffer + GFC_ITOA_BUF_SIZE - 1;
1072   *p = '\0';
1073
1074   while (t != 0)
1075     {
1076       *--p = '0' + (t % 10);
1077       t /= 10;
1078     }
1079
1080   if (negative)
1081     *--p = '-';
1082   return p;
1083 }
1084
1085
1086 void
1087 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1088 {
1089   write_decimal (dtp, f, p, len, (void *) gfc_itoa);
1090 }
1091
1092
1093 void
1094 write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1095 {
1096   const char *p;
1097   char itoa_buf[GFC_BTOA_BUF_SIZE];
1098   GFC_UINTEGER_LARGEST n = 0;
1099
1100   if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1101     {
1102       p = btoa_big (source, itoa_buf, len, &n);
1103       write_boz (dtp, f, p, n);
1104     }
1105   else
1106     {
1107       n = extract_uint (source, len);
1108       p = btoa (n, itoa_buf, sizeof (itoa_buf));
1109       write_boz (dtp, f, p, n);
1110     }
1111 }
1112
1113
1114 void
1115 write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1116 {
1117   const char *p;
1118   char itoa_buf[GFC_OTOA_BUF_SIZE];
1119   GFC_UINTEGER_LARGEST n = 0;
1120   
1121   if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1122     {
1123       p = otoa_big (source, itoa_buf, len, &n);
1124       write_boz (dtp, f, p, n);
1125     }
1126   else
1127     {
1128       n = extract_uint (source, len);
1129       p = otoa (n, itoa_buf, sizeof (itoa_buf));
1130       write_boz (dtp, f, p, n);
1131     }
1132 }
1133
1134 void
1135 write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
1136 {
1137   const char *p;
1138   char itoa_buf[GFC_XTOA_BUF_SIZE];
1139   GFC_UINTEGER_LARGEST n = 0;
1140
1141   if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
1142     {
1143       p = ztoa_big (source, itoa_buf, len, &n);
1144       write_boz (dtp, f, p, n);
1145     }
1146   else
1147     {
1148       n = extract_uint (source, len);
1149       p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
1150       write_boz (dtp, f, p, n);
1151     }
1152 }
1153
1154
1155 void
1156 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1157 {
1158   write_float (dtp, f, p, len, 0);
1159 }
1160
1161
1162 void
1163 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1164 {
1165   write_float (dtp, f, p, len, 0);
1166 }
1167
1168
1169 void
1170 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1171 {
1172   write_float (dtp, f, p, len, 0);
1173 }
1174
1175
1176 void
1177 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1178 {
1179   write_float (dtp, f, p, len, 0);
1180 }
1181
1182
1183 void
1184 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1185 {
1186   write_float (dtp, f, p, len, 0);
1187 }
1188
1189
1190 /* Take care of the X/TR descriptor.  */
1191
1192 void
1193 write_x (st_parameter_dt *dtp, int len, int nspaces)
1194 {
1195   char *p;
1196
1197   p = write_block (dtp, len);
1198   if (p == NULL)
1199     return;
1200   if (nspaces > 0 && len - nspaces >= 0)
1201     {
1202       if (unlikely (is_char4_unit (dtp)))
1203         {
1204           gfc_char4_t *p4 = (gfc_char4_t *) p;
1205           memset4 (&p4[len - nspaces], ' ', nspaces);
1206         }
1207       else
1208         memset (&p[len - nspaces], ' ', nspaces);
1209     }
1210 }
1211
1212
1213 /* List-directed writing.  */
1214
1215
1216 /* Write a single character to the output.  Returns nonzero if
1217    something goes wrong.  */
1218
1219 static int
1220 write_char (st_parameter_dt *dtp, int c)
1221 {
1222   char *p;
1223
1224   p = write_block (dtp, 1);
1225   if (p == NULL)
1226     return 1;
1227   if (unlikely (is_char4_unit (dtp)))
1228     {
1229       gfc_char4_t *p4 = (gfc_char4_t *) p;
1230       *p4 = c;
1231       return 0;
1232     }
1233
1234   *p = (uchar) c;
1235
1236   return 0;
1237 }
1238
1239
1240 /* Write a list-directed logical value.  */
1241
1242 static void
1243 write_logical (st_parameter_dt *dtp, const char *source, int length)
1244 {
1245   write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1246 }
1247
1248
1249 /* Write a list-directed integer value.  */
1250
1251 static void
1252 write_integer (st_parameter_dt *dtp, const char *source, int length)
1253 {
1254   char *p;
1255   const char *q;
1256   int digits;
1257   int width;
1258   char itoa_buf[GFC_ITOA_BUF_SIZE];
1259
1260   q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
1261
1262   switch (length)
1263     {
1264     case 1:
1265       width = 4;
1266       break;
1267
1268     case 2:
1269       width = 6;
1270       break;
1271
1272     case 4:
1273       width = 11;
1274       break;
1275
1276     case 8:
1277       width = 20;
1278       break;
1279
1280     default:
1281       width = 0;
1282       break;
1283     }
1284
1285   digits = strlen (q);
1286
1287   if (width < digits)
1288     width = digits;
1289   p = write_block (dtp, width);
1290   if (p == NULL)
1291     return;
1292
1293   if (unlikely (is_char4_unit (dtp)))
1294     {
1295       gfc_char4_t *p4 = (gfc_char4_t *) p;
1296       if (dtp->u.p.no_leading_blank)
1297         {
1298           memcpy4 (p4, q, digits);
1299           memset4 (p4 + digits, ' ', width - digits);
1300         }
1301       else
1302         {
1303           memset4 (p4, ' ', width - digits);
1304           memcpy4 (p4 + width - digits, q, digits);
1305         }
1306       return;
1307     }
1308
1309   if (dtp->u.p.no_leading_blank)
1310     {
1311       memcpy (p, q, digits);
1312       memset (p + digits, ' ', width - digits);
1313     }
1314   else
1315     {
1316       memset (p, ' ', width - digits);
1317       memcpy (p + width - digits, q, digits);
1318     }
1319 }
1320
1321
1322 /* Write a list-directed string.  We have to worry about delimiting
1323    the strings if the file has been opened in that mode.  */
1324
1325 static void
1326 write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
1327 {
1328   int i, extra;
1329   char *p, d;
1330
1331   switch (dtp->u.p.current_unit->delim_status)
1332     {
1333     case DELIM_APOSTROPHE:
1334       d = '\'';
1335       break;
1336     case DELIM_QUOTE:
1337       d = '"';
1338       break;
1339     default:
1340       d = ' ';
1341       break;
1342     }
1343
1344   if (kind == 1)
1345     {
1346       if (d == ' ')
1347         extra = 0;
1348       else
1349         {
1350           extra = 2;
1351
1352           for (i = 0; i < length; i++)
1353             if (source[i] == d)
1354               extra++;
1355         }
1356
1357       p = write_block (dtp, length + extra);
1358       if (p == NULL)
1359         return;
1360
1361       if (unlikely (is_char4_unit (dtp)))
1362         {
1363           gfc_char4_t d4 = (gfc_char4_t) d;
1364           gfc_char4_t *p4 = (gfc_char4_t *) p;
1365
1366           if (d4 == ' ')
1367             memcpy4 (p4, source, length);
1368           else
1369             {
1370               *p4++ = d4;
1371
1372               for (i = 0; i < length; i++)
1373                 {
1374                   *p4++ = (gfc_char4_t) source[i];
1375                   if (source[i] == d)
1376                     *p4++ = d4;
1377                 }
1378
1379               *p4 = d4;
1380             }
1381           return;
1382         }
1383
1384       if (d == ' ')
1385         memcpy (p, source, length);
1386       else
1387         {
1388           *p++ = d;
1389
1390           for (i = 0; i < length; i++)
1391             {
1392               *p++ = source[i];
1393               if (source[i] == d)
1394                 *p++ = d;
1395             }
1396
1397           *p = d;
1398         }
1399     }
1400   else
1401     {
1402       if (d == ' ')
1403         {
1404           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1405             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1406           else
1407             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1408         }
1409       else
1410         {
1411           p = write_block (dtp, 1);
1412           *p = d;
1413
1414           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
1415             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
1416           else
1417             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
1418
1419           p = write_block (dtp, 1);
1420           *p = d;
1421         }
1422     }
1423 }
1424
1425
1426 /* Set an fnode to default format.  */
1427
1428 static void
1429 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
1430 {
1431   f->format = FMT_G;
1432   switch (length)
1433     {
1434     case 4:
1435       f->u.real.w = 16;
1436       f->u.real.d = 9;
1437       f->u.real.e = 2;
1438       break;
1439     case 8:
1440       f->u.real.w = 25;
1441       f->u.real.d = 17;
1442       f->u.real.e = 3;
1443       break;
1444     case 10:
1445       f->u.real.w = 30;
1446       f->u.real.d = 21;
1447       f->u.real.e = 4;
1448       break;
1449     case 16:
1450       f->u.real.w = 45;
1451       f->u.real.d = 36;
1452       f->u.real.e = 4;
1453       break;
1454     default:
1455       internal_error (&dtp->common, "bad real kind");
1456       break;
1457     }
1458 }
1459
1460 /* Output a real number with default format.  This is 1PG16.9E2 for
1461    REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4 for REAL(10) and
1462    1PG45.36E4 for REAL(16). The exception is that the Fortran standard
1463    requires outputting an extra digit when the scale factor is 1 and
1464    when the magnitude of the value is such that E editing is
1465    used. However, gfortran compensates for this, and thus for list
1466    formatted the same number of significant digits is generated both
1467    when using F and E editing.  */
1468
1469 void
1470 write_real (st_parameter_dt *dtp, const char *source, int length)
1471 {
1472   fnode f ;
1473   int org_scale = dtp->u.p.scale_factor;
1474   dtp->u.p.scale_factor = 1;
1475   set_fnode_default (dtp, &f, length);
1476   write_float (dtp, &f, source , length, 1);
1477   dtp->u.p.scale_factor = org_scale;
1478 }
1479
1480 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1481    compensate for the extra digit.  */
1482
1483 void
1484 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1485 {
1486   fnode f;
1487   int comp_d; 
1488   set_fnode_default (dtp, &f, length);
1489   if (d > 0)
1490     f.u.real.d = d;
1491
1492   /* Compensate for extra digits when using scale factor, d is not
1493      specified, and the magnitude is such that E editing is used.  */
1494   if (dtp->u.p.scale_factor > 0 && d == 0)
1495     comp_d = 1;
1496   else
1497     comp_d = 0;
1498   dtp->u.p.g0_no_blanks = 1;
1499   write_float (dtp, &f, source , length, comp_d);
1500   dtp->u.p.g0_no_blanks = 0;
1501 }
1502
1503
1504 static void
1505 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1506 {
1507   char semi_comma =
1508         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1509
1510   if (write_char (dtp, '('))
1511     return;
1512   write_real (dtp, source, kind);
1513
1514   if (write_char (dtp, semi_comma))
1515     return;
1516   write_real (dtp, source + size / 2, kind);
1517
1518   write_char (dtp, ')');
1519 }
1520
1521
1522 /* Write the separator between items.  */
1523
1524 static void
1525 write_separator (st_parameter_dt *dtp)
1526 {
1527   char *p;
1528
1529   p = write_block (dtp, options.separator_len);
1530   if (p == NULL)
1531     return;
1532   if (unlikely (is_char4_unit (dtp)))
1533     {
1534       gfc_char4_t *p4 = (gfc_char4_t *) p;
1535       memcpy4 (p4, options.separator, options.separator_len);
1536     }
1537   else
1538     memcpy (p, options.separator, options.separator_len);
1539 }
1540
1541
1542 /* Write an item with list formatting.
1543    TODO: handle skipping to the next record correctly, particularly
1544    with strings.  */
1545
1546 static void
1547 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1548                              size_t size)
1549 {
1550   if (dtp->u.p.current_unit == NULL)
1551     return;
1552
1553   if (dtp->u.p.first_item)
1554     {
1555       dtp->u.p.first_item = 0;
1556       write_char (dtp, ' ');
1557     }
1558   else
1559     {
1560       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1561         dtp->u.p.current_unit->delim_status != DELIM_NONE)
1562       write_separator (dtp);
1563     }
1564
1565   switch (type)
1566     {
1567     case BT_INTEGER:
1568       write_integer (dtp, p, kind);
1569       break;
1570     case BT_LOGICAL:
1571       write_logical (dtp, p, kind);
1572       break;
1573     case BT_CHARACTER:
1574       write_character (dtp, p, kind, size);
1575       break;
1576     case BT_REAL:
1577       write_real (dtp, p, kind);
1578       break;
1579     case BT_COMPLEX:
1580       write_complex (dtp, p, kind, size);
1581       break;
1582     default:
1583       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1584     }
1585
1586   dtp->u.p.char_flag = (type == BT_CHARACTER);
1587 }
1588
1589
1590 void
1591 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1592                       size_t size, size_t nelems)
1593 {
1594   size_t elem;
1595   char *tmp;
1596   size_t stride = type == BT_CHARACTER ?
1597                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1598
1599   tmp = (char *) p;
1600
1601   /* Big loop over all the elements.  */
1602   for (elem = 0; elem < nelems; elem++)
1603     {
1604       dtp->u.p.item_count++;
1605       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1606     }
1607 }
1608
1609 /*                      NAMELIST OUTPUT
1610
1611    nml_write_obj writes a namelist object to the output stream.  It is called
1612    recursively for derived type components:
1613         obj    = is the namelist_info for the current object.
1614         offset = the offset relative to the address held by the object for
1615                  derived type arrays.
1616         base   = is the namelist_info of the derived type, when obj is a
1617                  component.
1618         base_name = the full name for a derived type, including qualifiers
1619                     if any.
1620    The returned value is a pointer to the object beyond the last one
1621    accessed, including nested derived types.  Notice that the namelist is
1622    a linear linked list of objects, including derived types and their
1623    components.  A tree, of sorts, is implied by the compound names of
1624    the derived type components and this is how this function recurses through
1625    the list.  */
1626
1627 /* A generous estimate of the number of characters needed to print
1628    repeat counts and indices, including commas, asterices and brackets.  */
1629
1630 #define NML_DIGITS 20
1631
1632 static void
1633 namelist_write_newline (st_parameter_dt *dtp)
1634 {
1635   if (!is_internal_unit (dtp))
1636     {
1637 #ifdef HAVE_CRLF
1638       write_character (dtp, "\r\n", 1, 2);
1639 #else
1640       write_character (dtp, "\n", 1, 1);
1641 #endif
1642       return;
1643     }
1644
1645   if (is_array_io (dtp))
1646     {
1647       gfc_offset record;
1648       int finished;
1649       char *p;
1650       int length = dtp->u.p.current_unit->bytes_left;
1651
1652       p = write_block (dtp, length);
1653       if (p == NULL)
1654         return;
1655
1656       if (unlikely (is_char4_unit (dtp)))
1657         {
1658           gfc_char4_t *p4 = (gfc_char4_t *) p;
1659           memset4 (p4, ' ', length);
1660         }
1661       else
1662         memset (p, ' ', length);
1663
1664       /* Now that the current record has been padded out,
1665          determine where the next record in the array is. */
1666       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1667                                   &finished);
1668       if (finished)
1669         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1670       else
1671         {
1672           /* Now seek to this record */
1673           record = record * dtp->u.p.current_unit->recl;
1674
1675           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1676             {
1677               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1678               return;
1679             }
1680
1681           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1682         }
1683     }
1684   else
1685     write_character (dtp, " ", 1, 1);
1686 }
1687
1688
1689 static namelist_info *
1690 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1691                namelist_info * base, char * base_name)
1692 {
1693   int rep_ctr;
1694   int num;
1695   int nml_carry;
1696   int len;
1697   index_type obj_size;
1698   index_type nelem;
1699   size_t dim_i;
1700   size_t clen;
1701   index_type elem_ctr;
1702   size_t obj_name_len;
1703   void * p ;
1704   char cup;
1705   char * obj_name;
1706   char * ext_name;
1707   size_t ext_name_len;
1708   char rep_buff[NML_DIGITS];
1709   namelist_info * cmp;
1710   namelist_info * retval = obj->next;
1711   size_t base_name_len;
1712   size_t base_var_name_len;
1713   size_t tot_len;
1714   unit_delim tmp_delim;
1715   
1716   /* Set the character to be used to separate values
1717      to a comma or semi-colon.  */
1718
1719   char semi_comma =
1720         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1721
1722   /* Write namelist variable names in upper case. If a derived type,
1723      nothing is output.  If a component, base and base_name are set.  */
1724
1725   if (obj->type != BT_DERIVED)
1726     {
1727       namelist_write_newline (dtp);
1728       write_character (dtp, " ", 1, 1);
1729
1730       len = 0;
1731       if (base)
1732         {
1733           len = strlen (base->var_name);
1734           base_name_len = strlen (base_name);
1735           for (dim_i = 0; dim_i < base_name_len; dim_i++)
1736             {
1737               cup = toupper ((int) base_name[dim_i]);
1738               write_character (dtp, &cup, 1, 1);
1739             }
1740         }
1741       clen = strlen (obj->var_name);
1742       for (dim_i = len; dim_i < clen; dim_i++)
1743         {
1744           cup = toupper ((int) obj->var_name[dim_i]);
1745           write_character (dtp, &cup, 1, 1);
1746         }
1747       write_character (dtp, "=", 1, 1);
1748     }
1749
1750   /* Counts the number of data output on a line, including names.  */
1751
1752   num = 1;
1753
1754   len = obj->len;
1755
1756   switch (obj->type)
1757     {
1758
1759     case BT_REAL:
1760       obj_size = size_from_real_kind (len);
1761       break;
1762
1763     case BT_COMPLEX:
1764       obj_size = size_from_complex_kind (len);
1765       break;
1766
1767     case BT_CHARACTER:
1768       obj_size = obj->string_length;
1769       break;
1770
1771     default:
1772       obj_size = len;      
1773     }
1774
1775   if (obj->var_rank)
1776     obj_size = obj->size;
1777
1778   /* Set the index vector and count the number of elements.  */
1779
1780   nelem = 1;
1781   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1782     {
1783       obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
1784       nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
1785     }
1786
1787   /* Main loop to output the data held in the object.  */
1788
1789   rep_ctr = 1;
1790   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1791     {
1792
1793       /* Build the pointer to the data value.  The offset is passed by
1794          recursive calls to this function for arrays of derived types.
1795          Is NULL otherwise.  */
1796
1797       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1798       p += offset;
1799
1800       /* Check for repeat counts of intrinsic types.  */
1801
1802       if ((elem_ctr < (nelem - 1)) &&
1803           (obj->type != BT_DERIVED) &&
1804           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1805         {
1806           rep_ctr++;
1807         }
1808
1809       /* Execute a repeated output.  Note the flag no_leading_blank that
1810          is used in the functions used to output the intrinsic types.  */
1811
1812       else
1813         {
1814           if (rep_ctr > 1)
1815             {
1816               snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
1817               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1818               dtp->u.p.no_leading_blank = 1;
1819             }
1820           num++;
1821
1822           /* Output the data, if an intrinsic type, or recurse into this
1823              routine to treat derived types.  */
1824
1825           switch (obj->type)
1826             {
1827
1828             case BT_INTEGER:
1829               write_integer (dtp, p, len);
1830               break;
1831
1832             case BT_LOGICAL:
1833               write_logical (dtp, p, len);
1834               break;
1835
1836             case BT_CHARACTER:
1837               tmp_delim = dtp->u.p.current_unit->delim_status;
1838               if (dtp->u.p.nml_delim == '"')
1839                 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
1840               if (dtp->u.p.nml_delim == '\'')
1841                 dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
1842               write_character (dtp, p, 1, obj->string_length);
1843                 dtp->u.p.current_unit->delim_status = tmp_delim;
1844               break;
1845
1846             case BT_REAL:
1847               write_real (dtp, p, len);
1848               break;
1849
1850            case BT_COMPLEX:
1851               dtp->u.p.no_leading_blank = 0;
1852               num++;
1853               write_complex (dtp, p, len, obj_size);
1854               break;
1855
1856             case BT_DERIVED:
1857
1858               /* To treat a derived type, we need to build two strings:
1859                  ext_name = the name, including qualifiers that prepends
1860                             component names in the output - passed to
1861                             nml_write_obj.
1862                  obj_name = the derived type name with no qualifiers but %
1863                             appended.  This is used to identify the
1864                             components.  */
1865
1866               /* First ext_name => get length of all possible components  */
1867
1868               base_name_len = base_name ? strlen (base_name) : 0;
1869               base_var_name_len = base ? strlen (base->var_name) : 0;
1870               ext_name_len = base_name_len + base_var_name_len 
1871                 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
1872               ext_name = (char*)get_mem (ext_name_len);
1873
1874               memcpy (ext_name, base_name, base_name_len);
1875               clen = strlen (obj->var_name + base_var_name_len);
1876               memcpy (ext_name + base_name_len, 
1877                       obj->var_name + base_var_name_len, clen);
1878               
1879               /* Append the qualifier.  */
1880
1881               tot_len = base_name_len + clen;
1882               for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1883                 {
1884                   if (!dim_i)
1885                     {
1886                       ext_name[tot_len] = '(';
1887                       tot_len++;
1888                     }
1889                   snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d", 
1890                             (int) obj->ls[dim_i].idx);
1891                   tot_len += strlen (ext_name + tot_len);
1892                   ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
1893                   tot_len++;
1894                 }
1895
1896               ext_name[tot_len] = '\0';
1897
1898               /* Now obj_name.  */
1899
1900               obj_name_len = strlen (obj->var_name) + 1;
1901               obj_name = get_mem (obj_name_len+1);
1902               memcpy (obj_name, obj->var_name, obj_name_len-1);
1903               memcpy (obj_name + obj_name_len-1, "%", 2);
1904
1905               /* Now loop over the components. Update the component pointer
1906                  with the return value from nml_write_obj => this loop jumps
1907                  past nested derived types.  */
1908
1909               for (cmp = obj->next;
1910                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1911                    cmp = retval)
1912                 {
1913                   retval = nml_write_obj (dtp, cmp,
1914                                           (index_type)(p - obj->mem_pos),
1915                                           obj, ext_name);
1916                 }
1917
1918               free (obj_name);
1919               free (ext_name);
1920               goto obj_loop;
1921
1922             default:
1923               internal_error (&dtp->common, "Bad type for namelist write");
1924             }
1925
1926           /* Reset the leading blank suppression, write a comma (or semi-colon)
1927              and, if 5 values have been output, write a newline and advance
1928              to column 2. Reset the repeat counter.  */
1929
1930           dtp->u.p.no_leading_blank = 0;
1931           write_character (dtp, &semi_comma, 1, 1);
1932           if (num > 5)
1933             {
1934               num = 0;
1935               namelist_write_newline (dtp);
1936               write_character (dtp, " ", 1, 1);
1937             }
1938           rep_ctr = 1;
1939         }
1940
1941     /* Cycle through and increment the index vector.  */
1942
1943 obj_loop:
1944
1945     nml_carry = 1;
1946     for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
1947       {
1948         obj->ls[dim_i].idx += nml_carry ;
1949         nml_carry = 0;
1950         if (obj->ls[dim_i].idx  > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
1951           {
1952             obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
1953             nml_carry = 1;
1954           }
1955        }
1956     }
1957
1958   /* Return a pointer beyond the furthest object accessed.  */
1959
1960   return retval;
1961 }
1962
1963
1964 /* This is the entry function for namelist writes.  It outputs the name
1965    of the namelist and iterates through the namelist by calls to
1966    nml_write_obj.  The call below has dummys in the arguments used in
1967    the treatment of derived types.  */
1968
1969 void
1970 namelist_write (st_parameter_dt *dtp)
1971 {
1972   namelist_info * t1, *t2, *dummy = NULL;
1973   index_type i;
1974   index_type dummy_offset = 0;
1975   char c;
1976   char * dummy_name = NULL;
1977   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1978
1979   /* Set the delimiter for namelist output.  */
1980   tmp_delim = dtp->u.p.current_unit->delim_status;
1981
1982   dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
1983
1984   /* Temporarily disable namelist delimters.  */
1985   dtp->u.p.current_unit->delim_status = DELIM_NONE;
1986
1987   write_character (dtp, "&", 1, 1);
1988
1989   /* Write namelist name in upper case - f95 std.  */
1990   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1991     {
1992       c = toupper ((int) dtp->namelist_name[i]);
1993       write_character (dtp, &c, 1 ,1);
1994     }
1995
1996   if (dtp->u.p.ionml != NULL)
1997     {
1998       t1 = dtp->u.p.ionml;
1999       while (t1 != NULL)
2000         {
2001           t2 = t1;
2002           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
2003         }
2004     }
2005
2006   namelist_write_newline (dtp);
2007   write_character (dtp, " /", 1, 2);
2008   /* Restore the original delimiter.  */
2009   dtp->u.p.current_unit->delim_status = tmp_delim;
2010 }
2011
2012 #undef NML_DIGITS