OSDN Git Service

0a6aee1588e8d03a276d228d7d1e4b61d34a2e15
[pf3gnuchains/gcc-fork.git] / libgfortran / io / write.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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, 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);
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);
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);
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);
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);
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 = 15;
1436       f->u.real.d = 8;
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 = 29;
1446       f->u.real.d = 20;
1447       f->u.real.e = 4;
1448       break;
1449     case 16:
1450       f->u.real.w = 44;
1451       f->u.real.d = 35;
1452       f->u.real.e = 4;
1453       break;
1454     default:
1455       internal_error (&dtp->common, "bad real kind");
1456       break;
1457     }
1458 }
1459 /* Output a real number with default format.
1460    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1461    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
1462
1463 void
1464 write_real (st_parameter_dt *dtp, const char *source, int length)
1465 {
1466   fnode f ;
1467   int org_scale = dtp->u.p.scale_factor;
1468   dtp->u.p.scale_factor = 1;
1469   set_fnode_default (dtp, &f, length);
1470   write_float (dtp, &f, source , length);
1471   dtp->u.p.scale_factor = org_scale;
1472 }
1473
1474
1475 void
1476 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1477 {
1478   fnode f ;
1479   set_fnode_default (dtp, &f, length);
1480   if (d > 0)
1481     f.u.real.d = d;
1482   dtp->u.p.g0_no_blanks = 1;
1483   write_float (dtp, &f, source , length);
1484   dtp->u.p.g0_no_blanks = 0;
1485 }
1486
1487
1488 static void
1489 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1490 {
1491   char semi_comma =
1492         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1493
1494   if (write_char (dtp, '('))
1495     return;
1496   write_real (dtp, source, kind);
1497
1498   if (write_char (dtp, semi_comma))
1499     return;
1500   write_real (dtp, source + size / 2, kind);
1501
1502   write_char (dtp, ')');
1503 }
1504
1505
1506 /* Write the separator between items.  */
1507
1508 static void
1509 write_separator (st_parameter_dt *dtp)
1510 {
1511   char *p;
1512
1513   p = write_block (dtp, options.separator_len);
1514   if (p == NULL)
1515     return;
1516   if (unlikely (is_char4_unit (dtp)))
1517     {
1518       gfc_char4_t *p4 = (gfc_char4_t *) p;
1519       memcpy4 (p4, options.separator, options.separator_len);
1520     }
1521   else
1522     memcpy (p, options.separator, options.separator_len);
1523 }
1524
1525
1526 /* Write an item with list formatting.
1527    TODO: handle skipping to the next record correctly, particularly
1528    with strings.  */
1529
1530 static void
1531 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1532                              size_t size)
1533 {
1534   if (dtp->u.p.current_unit == NULL)
1535     return;
1536
1537   if (dtp->u.p.first_item)
1538     {
1539       dtp->u.p.first_item = 0;
1540       write_char (dtp, ' ');
1541     }
1542   else
1543     {
1544       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1545         dtp->u.p.current_unit->delim_status != DELIM_NONE)
1546       write_separator (dtp);
1547     }
1548
1549   switch (type)
1550     {
1551     case BT_INTEGER:
1552       write_integer (dtp, p, kind);
1553       break;
1554     case BT_LOGICAL:
1555       write_logical (dtp, p, kind);
1556       break;
1557     case BT_CHARACTER:
1558       write_character (dtp, p, kind, size);
1559       break;
1560     case BT_REAL:
1561       write_real (dtp, p, kind);
1562       break;
1563     case BT_COMPLEX:
1564       write_complex (dtp, p, kind, size);
1565       break;
1566     default:
1567       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1568     }
1569
1570   dtp->u.p.char_flag = (type == BT_CHARACTER);
1571 }
1572
1573
1574 void
1575 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1576                       size_t size, size_t nelems)
1577 {
1578   size_t elem;
1579   char *tmp;
1580   size_t stride = type == BT_CHARACTER ?
1581                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1582
1583   tmp = (char *) p;
1584
1585   /* Big loop over all the elements.  */
1586   for (elem = 0; elem < nelems; elem++)
1587     {
1588       dtp->u.p.item_count++;
1589       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1590     }
1591 }
1592
1593 /*                      NAMELIST OUTPUT
1594
1595    nml_write_obj writes a namelist object to the output stream.  It is called
1596    recursively for derived type components:
1597         obj    = is the namelist_info for the current object.
1598         offset = the offset relative to the address held by the object for
1599                  derived type arrays.
1600         base   = is the namelist_info of the derived type, when obj is a
1601                  component.
1602         base_name = the full name for a derived type, including qualifiers
1603                     if any.
1604    The returned value is a pointer to the object beyond the last one
1605    accessed, including nested derived types.  Notice that the namelist is
1606    a linear linked list of objects, including derived types and their
1607    components.  A tree, of sorts, is implied by the compound names of
1608    the derived type components and this is how this function recurses through
1609    the list.  */
1610
1611 /* A generous estimate of the number of characters needed to print
1612    repeat counts and indices, including commas, asterices and brackets.  */
1613
1614 #define NML_DIGITS 20
1615
1616 static void
1617 namelist_write_newline (st_parameter_dt *dtp)
1618 {
1619   if (!is_internal_unit (dtp))
1620     {
1621 #ifdef HAVE_CRLF
1622       write_character (dtp, "\r\n", 1, 2);
1623 #else
1624       write_character (dtp, "\n", 1, 1);
1625 #endif
1626       return;
1627     }
1628
1629   if (is_array_io (dtp))
1630     {
1631       gfc_offset record;
1632       int finished;
1633       char *p;
1634       int length = dtp->u.p.current_unit->bytes_left;
1635
1636       p = write_block (dtp, length);
1637       if (p == NULL)
1638         return;
1639
1640       if (unlikely (is_char4_unit (dtp)))
1641         {
1642           gfc_char4_t *p4 = (gfc_char4_t *) p;
1643           memset4 (p4, ' ', length);
1644         }
1645       else
1646         memset (p, ' ', length);
1647
1648       /* Now that the current record has been padded out,
1649          determine where the next record in the array is. */
1650       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
1651                                   &finished);
1652       if (finished)
1653         dtp->u.p.current_unit->endfile = AT_ENDFILE;
1654       else
1655         {
1656           /* Now seek to this record */
1657           record = record * dtp->u.p.current_unit->recl;
1658
1659           if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
1660             {
1661               generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
1662               return;
1663             }
1664
1665           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1666         }
1667     }
1668   else
1669     write_character (dtp, " ", 1, 1);
1670 }
1671
1672
1673 static namelist_info *
1674 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1675                namelist_info * base, char * base_name)
1676 {
1677   int rep_ctr;
1678   int num;
1679   int nml_carry;
1680   int len;
1681   index_type obj_size;
1682   index_type nelem;
1683   size_t dim_i;
1684   size_t clen;
1685   index_type elem_ctr;
1686   size_t obj_name_len;
1687   void * p ;
1688   char cup;
1689   char * obj_name;
1690   char * ext_name;
1691   char rep_buff[NML_DIGITS];
1692   namelist_info * cmp;
1693   namelist_info * retval = obj->next;
1694   size_t base_name_len;
1695   size_t base_var_name_len;
1696   size_t tot_len;
1697   unit_delim tmp_delim;
1698   
1699   /* Set the character to be used to separate values
1700      to a comma or semi-colon.  */
1701
1702   char semi_comma =
1703         dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
1704
1705   /* Write namelist variable names in upper case. If a derived type,
1706      nothing is output.  If a component, base and base_name are set.  */
1707
1708   if (obj->type != BT_DERIVED)
1709     {
1710       namelist_write_newline (dtp);
1711       write_character (dtp, " ", 1, 1);
1712
1713       len = 0;
1714       if (base)
1715         {
1716           len = strlen (base->var_name);
1717           base_name_len = strlen (base_name);
1718           for (dim_i = 0; dim_i < base_name_len; dim_i++)
1719             {
1720               cup = toupper ((int) base_name[dim_i]);
1721               write_character (dtp, &cup, 1, 1);
1722             }
1723         }
1724       clen = strlen (obj->var_name);
1725       for (dim_i = len; dim_i < clen; dim_i++)
1726         {
1727           cup = toupper ((int) obj->var_name[dim_i]);
1728           write_character (dtp, &cup, 1, 1);
1729         }
1730       write_character (dtp, "=", 1, 1);
1731     }
1732
1733   /* Counts the number of data output on a line, including names.  */
1734
1735   num = 1;
1736
1737   len = obj->len;
1738
1739   switch (obj->type)
1740     {
1741
1742     case BT_REAL:
1743       obj_size = size_from_real_kind (len);
1744       break;
1745
1746     case BT_COMPLEX:
1747       obj_size = size_from_complex_kind (len);
1748       break;
1749
1750     case BT_CHARACTER:
1751       obj_size = obj->string_length;
1752       break;
1753
1754     default:
1755       obj_size = len;      
1756     }
1757
1758   if (obj->var_rank)
1759     obj_size = obj->size;
1760
1761   /* Set the index vector and count the number of elements.  */
1762
1763   nelem = 1;
1764   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1765     {
1766       obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
1767       nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
1768     }
1769
1770   /* Main loop to output the data held in the object.  */
1771
1772   rep_ctr = 1;
1773   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1774     {
1775
1776       /* Build the pointer to the data value.  The offset is passed by
1777          recursive calls to this function for arrays of derived types.
1778          Is NULL otherwise.  */
1779
1780       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1781       p += offset;
1782
1783       /* Check for repeat counts of intrinsic types.  */
1784
1785       if ((elem_ctr < (nelem - 1)) &&
1786           (obj->type != BT_DERIVED) &&
1787           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1788         {
1789           rep_ctr++;
1790         }
1791
1792       /* Execute a repeated output.  Note the flag no_leading_blank that
1793          is used in the functions used to output the intrinsic types.  */
1794
1795       else
1796         {
1797           if (rep_ctr > 1)
1798             {
1799               sprintf(rep_buff, " %d*", rep_ctr);
1800               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1801               dtp->u.p.no_leading_blank = 1;
1802             }
1803           num++;
1804
1805           /* Output the data, if an intrinsic type, or recurse into this
1806              routine to treat derived types.  */
1807
1808           switch (obj->type)
1809             {
1810
1811             case BT_INTEGER:
1812               write_integer (dtp, p, len);
1813               break;
1814
1815             case BT_LOGICAL:
1816               write_logical (dtp, p, len);
1817               break;
1818
1819             case BT_CHARACTER:
1820               tmp_delim = dtp->u.p.current_unit->delim_status;
1821               if (dtp->u.p.nml_delim == '"')
1822                 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
1823               if (dtp->u.p.nml_delim == '\'')
1824                 dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
1825               write_character (dtp, p, 1, obj->string_length);
1826                 dtp->u.p.current_unit->delim_status = tmp_delim;
1827               break;
1828
1829             case BT_REAL:
1830               write_real (dtp, p, len);
1831               break;
1832
1833            case BT_COMPLEX:
1834               dtp->u.p.no_leading_blank = 0;
1835               num++;
1836               write_complex (dtp, p, len, obj_size);
1837               break;
1838
1839             case BT_DERIVED:
1840
1841               /* To treat a derived type, we need to build two strings:
1842                  ext_name = the name, including qualifiers that prepends
1843                             component names in the output - passed to
1844                             nml_write_obj.
1845                  obj_name = the derived type name with no qualifiers but %
1846                             appended.  This is used to identify the
1847                             components.  */
1848
1849               /* First ext_name => get length of all possible components  */
1850
1851               base_name_len = base_name ? strlen (base_name) : 0;
1852               base_var_name_len = base ? strlen (base->var_name) : 0;
1853               ext_name = (char*)get_mem ( base_name_len
1854                                         + base_var_name_len
1855                                         + strlen (obj->var_name)
1856                                         + obj->var_rank * NML_DIGITS
1857                                         + 1);
1858
1859               memcpy (ext_name, base_name, base_name_len);
1860               clen = strlen (obj->var_name + base_var_name_len);
1861               memcpy (ext_name + base_name_len, 
1862                       obj->var_name + base_var_name_len, clen);
1863               
1864               /* Append the qualifier.  */
1865
1866               tot_len = base_name_len + clen;
1867               for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
1868                 {
1869                   if (!dim_i)
1870                     {
1871                       ext_name[tot_len] = '(';
1872                       tot_len++;
1873                     }
1874                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1875                   tot_len += strlen (ext_name + tot_len);
1876                   ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
1877                   tot_len++;
1878                 }
1879
1880               ext_name[tot_len] = '\0';
1881
1882               /* Now obj_name.  */
1883
1884               obj_name_len = strlen (obj->var_name) + 1;
1885               obj_name = get_mem (obj_name_len+1);
1886               memcpy (obj_name, obj->var_name, obj_name_len-1);
1887               memcpy (obj_name + obj_name_len-1, "%", 2);
1888
1889               /* Now loop over the components. Update the component pointer
1890                  with the return value from nml_write_obj => this loop jumps
1891                  past nested derived types.  */
1892
1893               for (cmp = obj->next;
1894                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1895                    cmp = retval)
1896                 {
1897                   retval = nml_write_obj (dtp, cmp,
1898                                           (index_type)(p - obj->mem_pos),
1899                                           obj, ext_name);
1900                 }
1901
1902               free (obj_name);
1903               free (ext_name);
1904               goto obj_loop;
1905
1906             default:
1907               internal_error (&dtp->common, "Bad type for namelist write");
1908             }
1909
1910           /* Reset the leading blank suppression, write a comma (or semi-colon)
1911              and, if 5 values have been output, write a newline and advance
1912              to column 2. Reset the repeat counter.  */
1913
1914           dtp->u.p.no_leading_blank = 0;
1915           write_character (dtp, &semi_comma, 1, 1);
1916           if (num > 5)
1917             {
1918               num = 0;
1919               namelist_write_newline (dtp);
1920               write_character (dtp, " ", 1, 1);
1921             }
1922           rep_ctr = 1;
1923         }
1924
1925     /* Cycle through and increment the index vector.  */
1926
1927 obj_loop:
1928
1929     nml_carry = 1;
1930     for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
1931       {
1932         obj->ls[dim_i].idx += nml_carry ;
1933         nml_carry = 0;
1934         if (obj->ls[dim_i].idx  > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
1935           {
1936             obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
1937             nml_carry = 1;
1938           }
1939        }
1940     }
1941
1942   /* Return a pointer beyond the furthest object accessed.  */
1943
1944   return retval;
1945 }
1946
1947
1948 /* This is the entry function for namelist writes.  It outputs the name
1949    of the namelist and iterates through the namelist by calls to
1950    nml_write_obj.  The call below has dummys in the arguments used in
1951    the treatment of derived types.  */
1952
1953 void
1954 namelist_write (st_parameter_dt *dtp)
1955 {
1956   namelist_info * t1, *t2, *dummy = NULL;
1957   index_type i;
1958   index_type dummy_offset = 0;
1959   char c;
1960   char * dummy_name = NULL;
1961   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1962
1963   /* Set the delimiter for namelist output.  */
1964   tmp_delim = dtp->u.p.current_unit->delim_status;
1965
1966   dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
1967
1968   /* Temporarily disable namelist delimters.  */
1969   dtp->u.p.current_unit->delim_status = DELIM_NONE;
1970
1971   write_character (dtp, "&", 1, 1);
1972
1973   /* Write namelist name in upper case - f95 std.  */
1974   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1975     {
1976       c = toupper ((int) dtp->namelist_name[i]);
1977       write_character (dtp, &c, 1 ,1);
1978     }
1979
1980   if (dtp->u.p.ionml != NULL)
1981     {
1982       t1 = dtp->u.p.ionml;
1983       while (t1 != NULL)
1984         {
1985           t2 = t1;
1986           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1987         }
1988     }
1989
1990   namelist_write_newline (dtp);
1991   write_character (dtp, " /", 1, 2);
1992   /* Restore the original delimiter.  */
1993   dtp->u.p.current_unit->delim_status = tmp_delim;
1994 }
1995
1996 #undef NML_DIGITS