OSDN Git Service

2008-09-22 Jerry DeLisle <jvdelisle@gcc.gnu.org
[pf3gnuchains/gcc-fork.git] / libgfortran / io / write.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 95 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 2, or (at your option)
12 any later version.
13
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file.  (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
21 executable.)
22
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
26 GNU General Public License for more details.
27
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING.  If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA.  */
32
33 #include "io.h"
34 #include <assert.h>
35 #include <string.h>
36 #include <ctype.h>
37 #include <stdlib.h>
38 #include <stdbool.h>
39 #include <errno.h>
40 #define star_fill(p, n) memset(p, '*', n)
41
42 #include "write_float.def"
43
44 typedef unsigned char uchar;
45
46 /* Write out default char4.  */
47
48 static void
49 write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
50                      int src_len, int w_len)
51 {
52   char *p;
53   int j, k = 0;
54   gfc_char4_t c;
55   uchar d;
56       
57   /* Take care of preceding blanks.  */
58   if (w_len > src_len)
59     {
60       k = w_len - src_len;
61       p = write_block (dtp, k);
62       if (p == NULL)
63         return;
64       memset (p, ' ', k);
65     }
66
67   /* Get ready to handle delimiters if needed.  */
68   d = ' ';
69   if (dtp->common.flags & IOPARM_DT_HAS_F2003)
70   switch (dtp->u.p.delim_status)
71     {
72     case DELIM_APOSTROPHE:
73       d = '\'';
74       break;
75     case DELIM_QUOTE:
76       d = '"';
77       break;
78     default:
79       d = ' ';
80       break;
81     }
82
83   /* Now process the remaining characters, one at a time.  */
84   for (j = k; j < src_len; j++)
85     {
86       c = source[j];
87     
88       /* Handle delimiters if any.  */
89       if (c == d && d != ' ')
90         {
91           p = write_block (dtp, 2);
92           if (p == NULL)
93             return;
94           *p++ = (uchar) c;
95         }
96       else
97         {
98           p = write_block (dtp, 1);
99           if (p == NULL)
100             return;
101         }
102       *p = c > 255 ? '?' : (uchar) c;
103     }
104 }
105
106
107 /* Write out UTF-8 converted from char4.  */
108
109 static void
110 write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
111                      int src_len, int w_len)
112 {
113   char *p;
114   int j, k = 0;
115   gfc_char4_t c;
116   static const uchar masks[6] =  { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
117   static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
118   size_t nbytes;
119   uchar buf[6], d, *q; 
120
121   /* Take care of preceding blanks.  */
122   if (w_len > src_len)
123     {
124       k = w_len - src_len;
125       p = write_block (dtp, k);
126       if (p == NULL)
127         return;
128       memset (p, ' ', k);
129     }
130
131   /* Get ready to handle delimiters if needed.  */
132   d = ' ';
133   if (dtp->common.flags & IOPARM_DT_HAS_F2003)
134   switch (dtp->u.p.delim_status)
135     {
136     case DELIM_APOSTROPHE:
137       d = '\'';
138       break;
139     case DELIM_QUOTE:
140       d = '"';
141       break;
142     default:
143       d = ' ';
144       break;
145     }
146
147   /* Now process the remaining characters, one at a time.  */
148   for (j = k; j < src_len; j++)
149     {
150       c = source[j];
151       if (c < 0x80)
152         {
153           /* Handle the delimiters if any.  */
154           if (c == d && d != ' ')
155             {
156               p = write_block (dtp, 2);
157               if (p == NULL)
158                 return;
159               *p++ = (uchar) c;
160             }
161           else
162             {
163               p = write_block (dtp, 1);
164               if (p == NULL)
165                 return;
166             }
167           *p = (uchar) c;
168         }
169       else
170         {
171           /* Convert to UTF-8 sequence.  */
172           nbytes = 1;
173           q = &buf[6];
174
175           do
176             {
177               *--q = ((c & 0x3F) | 0x80);
178               c >>= 6;
179               nbytes++;
180             }
181           while (c >= 0x3F || (c & limits[nbytes-1]));
182
183           *--q = (c | masks[nbytes-1]);
184
185           p = write_block (dtp, nbytes);
186           if (p == NULL)
187             return;
188
189           while (q < &buf[6])
190             *p++ = *q++;
191         }
192     }
193 }
194
195
196 void
197 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
198 {
199   int wlen;
200   char *p;
201
202   wlen = f->u.string.length < 0
203          || (f->format == FMT_G && f->u.string.length == 0)
204          ? len : f->u.string.length;
205
206 #ifdef HAVE_CRLF
207   /* If this is formatted STREAM IO convert any embedded line feed characters
208      to CR_LF on systems that use that sequence for newlines.  See F2003
209      Standard sections 10.6.3 and 9.9 for further information.  */
210   if (is_stream_io (dtp))
211     {
212       const char crlf[] = "\r\n";
213       int i, q, bytes;
214       q = bytes = 0;
215
216       /* Write out any padding if needed.  */
217       if (len < wlen)
218         {
219           p = write_block (dtp, wlen - len);
220           if (p == NULL)
221             return;
222           memset (p, ' ', wlen - len);
223         }
224
225       /* Scan the source string looking for '\n' and convert it if found.  */
226       for (i = 0; i < wlen; i++)
227         {
228           if (source[i] == '\n')
229             {
230               /* Write out the previously scanned characters in the string.  */
231               if (bytes > 0)
232                 {
233                   p = write_block (dtp, bytes);
234                   if (p == NULL)
235                     return;
236                   memcpy (p, &source[q], bytes);
237                   q += bytes;
238                   bytes = 0;
239                 }
240
241               /* Write out the CR_LF sequence.  */ 
242               q++;
243               p = write_block (dtp, 2);
244               if (p == NULL)
245                 return;
246               memcpy (p, crlf, 2);
247             }
248           else
249             bytes++;
250         }
251
252       /*  Write out any remaining bytes if no LF was found.  */
253       if (bytes > 0)
254         {
255           p = write_block (dtp, bytes);
256           if (p == NULL)
257             return;
258           memcpy (p, &source[q], bytes);
259         }
260     }
261   else
262     {
263 #endif
264       p = write_block (dtp, wlen);
265       if (p == NULL)
266         return;
267
268       if (wlen < len)
269         memcpy (p, source, wlen);
270       else
271         {
272           memset (p, ' ', wlen - len);
273           memcpy (p + wlen - len, source, len);
274         }
275 #ifdef HAVE_CRLF
276     }
277 #endif
278 }
279
280
281 /* The primary difference between write_a_char4 and write_a is that we have to
282    deal with writing from the first byte of the 4-byte character and pay
283    attention to the most significant bytes.  For ENCODING="default" write the
284    lowest significant byte. If the 3 most significant bytes contain
285    non-zero values, emit a '?'.  For ENCODING="utf-8", convert the UCS-32 value
286    to the UTF-8 encoded string before writing out.  */
287
288 void
289 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
290 {
291   int wlen;
292   gfc_char4_t *q;
293
294   wlen = f->u.string.length < 0
295          || (f->format == FMT_G && f->u.string.length == 0)
296          ? len : f->u.string.length;
297
298   q = (gfc_char4_t *) source;
299 #ifdef HAVE_CRLF
300   /* If this is formatted STREAM IO convert any embedded line feed characters
301      to CR_LF on systems that use that sequence for newlines.  See F2003
302      Standard sections 10.6.3 and 9.9 for further information.  */
303   if (is_stream_io (dtp))
304     {
305       const char crlf[] = "\r\n";
306       int i, bytes;
307       gfc_char4_t *qq;
308       bytes = 0;
309
310       /* Write out any padding if needed.  */
311       if (len < wlen)
312         {
313           char *p;
314           p = write_block (dtp, wlen - len);
315           if (p == NULL)
316             return;
317           memset (p, ' ', wlen - len);
318         }
319
320       /* Scan the source string looking for '\n' and convert it if found.  */
321       qq = (gfc_char4_t *) source;
322       for (i = 0; i < wlen; i++)
323         {
324           if (qq[i] == '\n')
325             {
326               /* Write out the previously scanned characters in the string.  */
327               if (bytes > 0)
328                 {
329                   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
330                     write_utf8_char4 (dtp, q, bytes, 0);
331                   else
332                     write_default_char4 (dtp, q, bytes, 0);
333                   bytes = 0;
334                 }
335
336               /* Write out the CR_LF sequence.  */ 
337               write_default_char4 (dtp, crlf, 2, 0);
338             }
339           else
340             bytes++;
341         }
342
343       /*  Write out any remaining bytes if no LF was found.  */
344       if (bytes > 0)
345         {
346           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
347             write_utf8_char4 (dtp, q, bytes, 0);
348           else
349             write_default_char4 (dtp, q, bytes, 0);
350         }
351     }
352   else
353     {
354 #endif
355       if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
356         write_utf8_char4 (dtp, q, len, wlen);
357       else
358         write_default_char4 (dtp, q, len, wlen);
359 #ifdef HAVE_CRLF
360     }
361 #endif
362 }
363
364
365 static GFC_INTEGER_LARGEST
366 extract_int (const void *p, int len)
367 {
368   GFC_INTEGER_LARGEST i = 0;
369
370   if (p == NULL)
371     return i;
372
373   switch (len)
374     {
375     case 1:
376       {
377         GFC_INTEGER_1 tmp;
378         memcpy ((void *) &tmp, p, len);
379         i = tmp;
380       }
381       break;
382     case 2:
383       {
384         GFC_INTEGER_2 tmp;
385         memcpy ((void *) &tmp, p, len);
386         i = tmp;
387       }
388       break;
389     case 4:
390       {
391         GFC_INTEGER_4 tmp;
392         memcpy ((void *) &tmp, p, len);
393         i = tmp;
394       }
395       break;
396     case 8:
397       {
398         GFC_INTEGER_8 tmp;
399         memcpy ((void *) &tmp, p, len);
400         i = tmp;
401       }
402       break;
403 #ifdef HAVE_GFC_INTEGER_16
404     case 16:
405       {
406         GFC_INTEGER_16 tmp;
407         memcpy ((void *) &tmp, p, len);
408         i = tmp;
409       }
410       break;
411 #endif
412     default:
413       internal_error (NULL, "bad integer kind");
414     }
415
416   return i;
417 }
418
419 static GFC_UINTEGER_LARGEST
420 extract_uint (const void *p, int len)
421 {
422   GFC_UINTEGER_LARGEST i = 0;
423
424   if (p == NULL)
425     return i;
426
427   switch (len)
428     {
429     case 1:
430       {
431         GFC_INTEGER_1 tmp;
432         memcpy ((void *) &tmp, p, len);
433         i = (GFC_UINTEGER_1) tmp;
434       }
435       break;
436     case 2:
437       {
438         GFC_INTEGER_2 tmp;
439         memcpy ((void *) &tmp, p, len);
440         i = (GFC_UINTEGER_2) tmp;
441       }
442       break;
443     case 4:
444       {
445         GFC_INTEGER_4 tmp;
446         memcpy ((void *) &tmp, p, len);
447         i = (GFC_UINTEGER_4) tmp;
448       }
449       break;
450     case 8:
451       {
452         GFC_INTEGER_8 tmp;
453         memcpy ((void *) &tmp, p, len);
454         i = (GFC_UINTEGER_8) tmp;
455       }
456       break;
457 #ifdef HAVE_GFC_INTEGER_16
458     case 16:
459       {
460         GFC_INTEGER_16 tmp;
461         memcpy ((void *) &tmp, p, len);
462         i = (GFC_UINTEGER_16) tmp;
463       }
464       break;
465 #endif
466     default:
467       internal_error (NULL, "bad integer kind");
468     }
469
470   return i;
471 }
472
473
474 void
475 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
476 {
477   char *p;
478   int wlen;
479   GFC_INTEGER_LARGEST n;
480
481   wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
482   
483   p = write_block (dtp, wlen);
484   if (p == NULL)
485     return;
486
487   memset (p, ' ', wlen - 1);
488   n = extract_int (source, len);
489   p[wlen - 1] = (n) ? 'T' : 'F';
490 }
491
492
493 static void
494 write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
495            const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
496 {
497   GFC_UINTEGER_LARGEST n = 0;
498   int w, m, digits, nzero, nblank;
499   char *p;
500   const char *q;
501   char itoa_buf[GFC_BTOA_BUF_SIZE];
502
503   w = f->u.integer.w;
504   m = f->u.integer.m;
505
506   n = extract_uint (source, len);
507
508   /* Special case:  */
509
510   if (m == 0 && n == 0)
511     {
512       if (w == 0)
513         w = 1;
514
515       p = write_block (dtp, w);
516       if (p == NULL)
517         return;
518
519       memset (p, ' ', w);
520       goto done;
521     }
522
523   q = conv (n, itoa_buf, sizeof (itoa_buf));
524   digits = strlen (q);
525
526   /* Select a width if none was specified.  The idea here is to always
527      print something.  */
528
529   if (w == 0)
530     w = ((digits < m) ? m : digits);
531
532   p = write_block (dtp, w);
533   if (p == NULL)
534     return;
535
536   nzero = 0;
537   if (digits < m)
538     nzero = m - digits;
539
540   /* See if things will work.  */
541
542   nblank = w - (nzero + digits);
543
544   if (nblank < 0)
545     {
546       star_fill (p, w);
547       goto done;
548     }
549
550
551   if (!dtp->u.p.no_leading_blank)
552     {
553       memset (p, ' ', nblank);
554       p += nblank;
555       memset (p, '0', nzero);
556       p += nzero;
557       memcpy (p, q, digits);
558     }
559   else
560     {
561       memset (p, '0', nzero);
562       p += nzero;
563       memcpy (p, q, digits);
564       p += digits;
565       memset (p, ' ', nblank);
566       dtp->u.p.no_leading_blank = 0;
567     }
568
569  done:
570   return;
571 }
572
573 static void
574 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
575                int len,
576                const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
577 {
578   GFC_INTEGER_LARGEST n = 0;
579   int w, m, digits, nsign, nzero, nblank;
580   char *p;
581   const char *q;
582   sign_t sign;
583   char itoa_buf[GFC_BTOA_BUF_SIZE];
584
585   w = f->u.integer.w;
586   m = f->format == FMT_G ? -1 : f->u.integer.m;
587
588   n = extract_int (source, len);
589
590   /* Special case:  */
591   if (m == 0 && n == 0)
592     {
593       if (w == 0)
594         w = 1;
595
596       p = write_block (dtp, w);
597       if (p == NULL)
598         return;
599
600       memset (p, ' ', w);
601       goto done;
602     }
603
604   sign = calculate_sign (dtp, n < 0);
605   if (n < 0)
606     n = -n;
607
608   nsign = sign == S_NONE ? 0 : 1;
609   q = conv (n, itoa_buf, sizeof (itoa_buf));
610
611   digits = strlen (q);
612
613   /* Select a width if none was specified.  The idea here is to always
614      print something.  */
615
616   if (w == 0)
617     w = ((digits < m) ? m : digits) + nsign;
618
619   p = write_block (dtp, w);
620   if (p == NULL)
621     return;
622
623   nzero = 0;
624   if (digits < m)
625     nzero = m - digits;
626
627   /* See if things will work.  */
628
629   nblank = w - (nsign + nzero + digits);
630
631   if (nblank < 0)
632     {
633       star_fill (p, w);
634       goto done;
635     }
636
637   memset (p, ' ', nblank);
638   p += nblank;
639
640   switch (sign)
641     {
642     case S_PLUS:
643       *p++ = '+';
644       break;
645     case S_MINUS:
646       *p++ = '-';
647       break;
648     case S_NONE:
649       break;
650     }
651
652   memset (p, '0', nzero);
653   p += nzero;
654
655   memcpy (p, q, digits);
656
657  done:
658   return;
659 }
660
661
662 /* Convert unsigned octal to ascii.  */
663
664 static const char *
665 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
666 {
667   char *p;
668
669   assert (len >= GFC_OTOA_BUF_SIZE);
670
671   if (n == 0)
672     return "0";
673
674   p = buffer + GFC_OTOA_BUF_SIZE - 1;
675   *p = '\0';
676
677   while (n != 0)
678     {
679       *--p = '0' + (n & 7);
680       n >>= 3;
681     }
682
683   return p;
684 }
685
686
687 /* Convert unsigned binary to ascii.  */
688
689 static const char *
690 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
691 {
692   char *p;
693
694   assert (len >= GFC_BTOA_BUF_SIZE);
695
696   if (n == 0)
697     return "0";
698
699   p = buffer + GFC_BTOA_BUF_SIZE - 1;
700   *p = '\0';
701
702   while (n != 0)
703     {
704       *--p = '0' + (n & 1);
705       n >>= 1;
706     }
707
708   return p;
709 }
710
711
712 void
713 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
714 {
715   write_decimal (dtp, f, p, len, (void *) gfc_itoa);
716 }
717
718
719 void
720 write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
721 {
722   write_int (dtp, f, p, len, btoa);
723 }
724
725
726 void
727 write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
728 {
729   write_int (dtp, f, p, len, otoa);
730 }
731
732 void
733 write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
734 {
735   write_int (dtp, f, p, len, xtoa);
736 }
737
738
739 void
740 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
741 {
742   write_float (dtp, f, p, len);
743 }
744
745
746 void
747 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
748 {
749   write_float (dtp, f, p, len);
750 }
751
752
753 void
754 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
755 {
756   write_float (dtp, f, p, len);
757 }
758
759
760 void
761 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
762 {
763   write_float (dtp, f, p, len);
764 }
765
766
767 void
768 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
769 {
770   write_float (dtp, f, p, len);
771 }
772
773
774 /* Take care of the X/TR descriptor.  */
775
776 void
777 write_x (st_parameter_dt *dtp, int len, int nspaces)
778 {
779   char *p;
780
781   p = write_block (dtp, len);
782   if (p == NULL)
783     return;
784
785   if (nspaces > 0)
786     memset (&p[len - nspaces], ' ', nspaces);
787 }
788
789
790 /* List-directed writing.  */
791
792
793 /* Write a single character to the output.  Returns nonzero if
794    something goes wrong.  */
795
796 static int
797 write_char (st_parameter_dt *dtp, char c)
798 {
799   char *p;
800
801   p = write_block (dtp, 1);
802   if (p == NULL)
803     return 1;
804
805   *p = c;
806
807   return 0;
808 }
809
810
811 /* Write a list-directed logical value.  */
812
813 static void
814 write_logical (st_parameter_dt *dtp, const char *source, int length)
815 {
816   write_char (dtp, extract_int (source, length) ? 'T' : 'F');
817 }
818
819
820 /* Write a list-directed integer value.  */
821
822 static void
823 write_integer (st_parameter_dt *dtp, const char *source, int length)
824 {
825   char *p;
826   const char *q;
827   int digits;
828   int width;
829   char itoa_buf[GFC_ITOA_BUF_SIZE];
830
831   q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
832
833   switch (length)
834     {
835     case 1:
836       width = 4;
837       break;
838
839     case 2:
840       width = 6;
841       break;
842
843     case 4:
844       width = 11;
845       break;
846
847     case 8:
848       width = 20;
849       break;
850
851     default:
852       width = 0;
853       break;
854     }
855
856   digits = strlen (q);
857
858   if (width < digits)
859     width = digits;
860   p = write_block (dtp, width);
861   if (p == NULL)
862     return;
863   if (dtp->u.p.no_leading_blank)
864     {
865       memcpy (p, q, digits);
866       memset (p + digits, ' ', width - digits);
867     }
868   else
869     {
870       memset (p, ' ', width - digits);
871       memcpy (p + width - digits, q, digits);
872     }
873 }
874
875
876 /* Write a list-directed string.  We have to worry about delimiting
877    the strings if the file has been opened in that mode.  */
878
879 static void
880 write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
881 {
882   int i, extra;
883   char *p, d;
884
885   d = ' ';
886   if (dtp->common.flags & IOPARM_DT_HAS_F2003)
887   switch (dtp->u.p.delim_status)
888     {
889     case DELIM_APOSTROPHE:
890       d = '\'';
891       break;
892     case DELIM_QUOTE:
893       d = '"';
894       break;
895     default:
896       d = ' ';
897       break;
898     }
899
900   if (kind == 1)
901     {
902       if (d == ' ')
903         extra = 0;
904       else
905         {
906           extra = 2;
907
908           for (i = 0; i < length; i++)
909             if (source[i] == d)
910               extra++;
911         }
912
913       p = write_block (dtp, length + extra);
914       if (p == NULL)
915         return;
916
917       if (d == ' ')
918         memcpy (p, source, length);
919       else
920         {
921           *p++ = d;
922
923           for (i = 0; i < length; i++)
924             {
925               *p++ = source[i];
926               if (source[i] == d)
927                 *p++ = d;
928             }
929
930           *p = d;
931         }
932     }
933   else
934     {
935       if (d == ' ')
936         {
937           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
938             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
939           else
940             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
941         }
942       else
943         {
944           p = write_block (dtp, 1);
945           *p = d;
946
947           if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
948             write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
949           else
950             write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
951
952           p = write_block (dtp, 1);
953           *p = d;
954         }
955     }
956 }
957
958
959 /* Set an fnode to default format.  */
960
961 static void
962 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
963 {
964   f->format = FMT_G;
965   switch (length)
966     {
967     case 4:
968       f->u.real.w = 15;
969       f->u.real.d = 8;
970       f->u.real.e = 2;
971       break;
972     case 8:
973       f->u.real.w = 25;
974       f->u.real.d = 17;
975       f->u.real.e = 3;
976       break;
977     case 10:
978       f->u.real.w = 29;
979       f->u.real.d = 20;
980       f->u.real.e = 4;
981       break;
982     case 16:
983       f->u.real.w = 44;
984       f->u.real.d = 35;
985       f->u.real.e = 4;
986       break;
987     default:
988       internal_error (&dtp->common, "bad real kind");
989       break;
990     }
991 }
992 /* Output a real number with default format.
993    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
994    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
995
996 void
997 write_real (st_parameter_dt *dtp, const char *source, int length)
998 {
999   fnode f ;
1000   int org_scale = dtp->u.p.scale_factor;
1001   dtp->u.p.scale_factor = 1;
1002   set_fnode_default (dtp, &f, length);
1003   write_float (dtp, &f, source , length);
1004   dtp->u.p.scale_factor = org_scale;
1005 }
1006
1007
1008 void
1009 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
1010 {
1011   fnode f ;
1012   int org_scale = dtp->u.p.scale_factor;
1013   dtp->u.p.scale_factor = 1;
1014   set_fnode_default (dtp, &f, length);
1015   f.format = FMT_ES;
1016   f.u.real.d = d;
1017   write_float (dtp, &f, source , length);
1018   dtp->u.p.scale_factor = org_scale;
1019 }
1020
1021
1022 static void
1023 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1024 {
1025   char semi_comma = ',';
1026
1027   if (dtp->common.flags & IOPARM_DT_HAS_F2003)
1028     semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
1029
1030   if (write_char (dtp, '('))
1031     return;
1032   write_real (dtp, source, kind);
1033
1034   if (write_char (dtp, semi_comma))
1035     return;
1036   write_real (dtp, source + size / 2, kind);
1037
1038   write_char (dtp, ')');
1039 }
1040
1041
1042 /* Write the separator between items.  */
1043
1044 static void
1045 write_separator (st_parameter_dt *dtp)
1046 {
1047   char *p;
1048
1049   p = write_block (dtp, options.separator_len);
1050   if (p == NULL)
1051     return;
1052
1053   memcpy (p, options.separator, options.separator_len);
1054 }
1055
1056
1057 /* Write an item with list formatting.
1058    TODO: handle skipping to the next record correctly, particularly
1059    with strings.  */
1060
1061 static void
1062 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1063                              size_t size)
1064 {
1065   if (dtp->u.p.current_unit == NULL)
1066     return;
1067
1068   if (dtp->u.p.first_item)
1069     {
1070       dtp->u.p.first_item = 0;
1071       write_char (dtp, ' ');
1072     }
1073   else
1074     {
1075       if (dtp->common.flags & IOPARM_DT_HAS_F2003)
1076         {
1077           if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1078               dtp->u.p.delim_status != DELIM_NONE)
1079             write_separator (dtp);
1080         }
1081       else
1082         {
1083           if (type != BT_CHARACTER || !dtp->u.p.char_flag)
1084             write_separator (dtp);
1085         }
1086     }
1087
1088   switch (type)
1089     {
1090     case BT_INTEGER:
1091       write_integer (dtp, p, kind);
1092       break;
1093     case BT_LOGICAL:
1094       write_logical (dtp, p, kind);
1095       break;
1096     case BT_CHARACTER:
1097       write_character (dtp, p, kind, size);
1098       break;
1099     case BT_REAL:
1100       write_real (dtp, p, kind);
1101       break;
1102     case BT_COMPLEX:
1103       write_complex (dtp, p, kind, size);
1104       break;
1105     default:
1106       internal_error (&dtp->common, "list_formatted_write(): Bad type");
1107     }
1108
1109   dtp->u.p.char_flag = (type == BT_CHARACTER);
1110 }
1111
1112
1113 void
1114 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1115                       size_t size, size_t nelems)
1116 {
1117   size_t elem;
1118   char *tmp;
1119   size_t stride = type == BT_CHARACTER ?
1120                   size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1121
1122   tmp = (char *) p;
1123
1124   /* Big loop over all the elements.  */
1125   for (elem = 0; elem < nelems; elem++)
1126     {
1127       dtp->u.p.item_count++;
1128       list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
1129     }
1130 }
1131
1132 /*                      NAMELIST OUTPUT
1133
1134    nml_write_obj writes a namelist object to the output stream.  It is called
1135    recursively for derived type components:
1136         obj    = is the namelist_info for the current object.
1137         offset = the offset relative to the address held by the object for
1138                  derived type arrays.
1139         base   = is the namelist_info of the derived type, when obj is a
1140                  component.
1141         base_name = the full name for a derived type, including qualifiers
1142                     if any.
1143    The returned value is a pointer to the object beyond the last one
1144    accessed, including nested derived types.  Notice that the namelist is
1145    a linear linked list of objects, including derived types and their
1146    components.  A tree, of sorts, is implied by the compound names of
1147    the derived type components and this is how this function recurses through
1148    the list.  */
1149
1150 /* A generous estimate of the number of characters needed to print
1151    repeat counts and indices, including commas, asterices and brackets.  */
1152
1153 #define NML_DIGITS 20
1154
1155 static void
1156 namelist_write_newline (st_parameter_dt *dtp)
1157 {
1158   if (!is_internal_unit (dtp))
1159     {
1160 #ifdef HAVE_CRLF
1161       write_character (dtp, "\r\n", 1, 2);
1162 #else
1163       write_character (dtp, "\n", 1, 1);
1164 #endif
1165     }
1166   else
1167     write_character (dtp, " ", 1, 1);
1168 }
1169
1170
1171 static namelist_info *
1172 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1173                namelist_info * base, char * base_name)
1174 {
1175   int rep_ctr;
1176   int num;
1177   int nml_carry;
1178   index_type len;
1179   index_type obj_size;
1180   index_type nelem;
1181   index_type dim_i;
1182   index_type clen;
1183   index_type elem_ctr;
1184   index_type obj_name_len;
1185   void * p ;
1186   char cup;
1187   char * obj_name;
1188   char * ext_name;
1189   char rep_buff[NML_DIGITS];
1190   namelist_info * cmp;
1191   namelist_info * retval = obj->next;
1192   size_t base_name_len;
1193   size_t base_var_name_len;
1194   size_t tot_len;
1195   unit_delim tmp_delim;
1196   
1197   /* Set the character to be used to separate values
1198      to a comma or semi-colon.  */
1199
1200   char semi_comma = ',';
1201
1202   if (dtp->common.flags & IOPARM_DT_HAS_F2003)
1203     semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
1204
1205   /* Write namelist variable names in upper case. If a derived type,
1206      nothing is output.  If a component, base and base_name are set.  */
1207
1208   if (obj->type != GFC_DTYPE_DERIVED)
1209     {
1210       namelist_write_newline (dtp);
1211       write_character (dtp, " ", 1, 1);
1212
1213       len = 0;
1214       if (base)
1215         {
1216           len =strlen (base->var_name);
1217           for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1218             {
1219               cup = toupper (base_name[dim_i]);
1220               write_character (dtp, &cup, 1, 1);
1221             }
1222         }
1223       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1224         {
1225           cup = toupper (obj->var_name[dim_i]);
1226           write_character (dtp, &cup, 1, 1);
1227         }
1228       write_character (dtp, "=", 1, 1);
1229     }
1230
1231   /* Counts the number of data output on a line, including names.  */
1232
1233   num = 1;
1234
1235   len = obj->len;
1236
1237   switch (obj->type)
1238     {
1239
1240     case GFC_DTYPE_REAL:
1241       obj_size = size_from_real_kind (len);
1242       break;
1243
1244     case GFC_DTYPE_COMPLEX:
1245       obj_size = size_from_complex_kind (len);
1246       break;
1247
1248     case GFC_DTYPE_CHARACTER:
1249       obj_size = obj->string_length;
1250       break;
1251
1252     default:
1253       obj_size = len;      
1254     }
1255
1256   if (obj->var_rank)
1257     obj_size = obj->size;
1258
1259   /* Set the index vector and count the number of elements.  */
1260
1261   nelem = 1;
1262   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1263     {
1264       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1265       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1266     }
1267
1268   /* Main loop to output the data held in the object.  */
1269
1270   rep_ctr = 1;
1271   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1272     {
1273
1274       /* Build the pointer to the data value.  The offset is passed by
1275          recursive calls to this function for arrays of derived types.
1276          Is NULL otherwise.  */
1277
1278       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1279       p += offset;
1280
1281       /* Check for repeat counts of intrinsic types.  */
1282
1283       if ((elem_ctr < (nelem - 1)) &&
1284           (obj->type != GFC_DTYPE_DERIVED) &&
1285           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1286         {
1287           rep_ctr++;
1288         }
1289
1290       /* Execute a repeated output.  Note the flag no_leading_blank that
1291          is used in the functions used to output the intrinsic types.  */
1292
1293       else
1294         {
1295           if (rep_ctr > 1)
1296             {
1297               sprintf(rep_buff, " %d*", rep_ctr);
1298               write_character (dtp, rep_buff, 1, strlen (rep_buff));
1299               dtp->u.p.no_leading_blank = 1;
1300             }
1301           num++;
1302
1303           /* Output the data, if an intrinsic type, or recurse into this
1304              routine to treat derived types.  */
1305
1306           switch (obj->type)
1307             {
1308
1309             case GFC_DTYPE_INTEGER:
1310               write_integer (dtp, p, len);
1311               break;
1312
1313             case GFC_DTYPE_LOGICAL:
1314               write_logical (dtp, p, len);
1315               break;
1316
1317             case GFC_DTYPE_CHARACTER:
1318               if (dtp->common.flags & IOPARM_DT_HAS_F2003)
1319                 {
1320                   tmp_delim = dtp->u.p.delim_status;
1321                   if (dtp->u.p.nml_delim == '"')
1322                     dtp->u.p.delim_status = DELIM_QUOTE;
1323                   if (dtp->u.p.nml_delim == '\'')
1324                     dtp->u.p.delim_status = DELIM_APOSTROPHE;
1325                   write_character (dtp, p, 1, obj->string_length);
1326                   dtp->u.p.delim_status = tmp_delim;
1327                 }
1328               else
1329                 write_character (dtp, p, 1, obj->string_length);
1330               break;
1331
1332             case GFC_DTYPE_REAL:
1333               write_real (dtp, p, len);
1334               break;
1335
1336             case GFC_DTYPE_COMPLEX:
1337               dtp->u.p.no_leading_blank = 0;
1338               num++;
1339               write_complex (dtp, p, len, obj_size);
1340               break;
1341
1342             case GFC_DTYPE_DERIVED:
1343
1344               /* To treat a derived type, we need to build two strings:
1345                  ext_name = the name, including qualifiers that prepends
1346                             component names in the output - passed to
1347                             nml_write_obj.
1348                  obj_name = the derived type name with no qualifiers but %
1349                             appended.  This is used to identify the
1350                             components.  */
1351
1352               /* First ext_name => get length of all possible components  */
1353
1354               base_name_len = base_name ? strlen (base_name) : 0;
1355               base_var_name_len = base ? strlen (base->var_name) : 0;
1356               ext_name = (char*)get_mem ( base_name_len
1357                                         + base_var_name_len
1358                                         + strlen (obj->var_name)
1359                                         + obj->var_rank * NML_DIGITS
1360                                         + 1);
1361
1362               memcpy (ext_name, base_name, base_name_len);
1363               clen = strlen (obj->var_name + base_var_name_len);
1364               memcpy (ext_name + base_name_len, 
1365                       obj->var_name + base_var_name_len, clen);
1366               
1367               /* Append the qualifier.  */
1368
1369               tot_len = base_name_len + clen;
1370               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1371                 {
1372                   if (!dim_i)
1373                     {
1374                       ext_name[tot_len] = '(';
1375                       tot_len++;
1376                     }
1377                   sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1378                   tot_len += strlen (ext_name + tot_len);
1379                   ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
1380                   tot_len++;
1381                 }
1382
1383               ext_name[tot_len] = '\0';
1384
1385               /* Now obj_name.  */
1386
1387               obj_name_len = strlen (obj->var_name) + 1;
1388               obj_name = get_mem (obj_name_len+1);
1389               memcpy (obj_name, obj->var_name, obj_name_len-1);
1390               memcpy (obj_name + obj_name_len-1, "%", 2);
1391
1392               /* Now loop over the components. Update the component pointer
1393                  with the return value from nml_write_obj => this loop jumps
1394                  past nested derived types.  */
1395
1396               for (cmp = obj->next;
1397                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1398                    cmp = retval)
1399                 {
1400                   retval = nml_write_obj (dtp, cmp,
1401                                           (index_type)(p - obj->mem_pos),
1402                                           obj, ext_name);
1403                 }
1404
1405               free_mem (obj_name);
1406               free_mem (ext_name);
1407               goto obj_loop;
1408
1409             default:
1410               internal_error (&dtp->common, "Bad type for namelist write");
1411             }
1412
1413           /* Reset the leading blank suppression, write a comma (or semi-colon)
1414              and, if 5 values have been output, write a newline and advance
1415              to column 2. Reset the repeat counter.  */
1416
1417           dtp->u.p.no_leading_blank = 0;
1418           write_character (dtp, &semi_comma, 1, 1);
1419           if (num > 5)
1420             {
1421               num = 0;
1422               namelist_write_newline (dtp);
1423               write_character (dtp, " ", 1, 1);
1424             }
1425           rep_ctr = 1;
1426         }
1427
1428     /* Cycle through and increment the index vector.  */
1429
1430 obj_loop:
1431
1432     nml_carry = 1;
1433     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1434       {
1435         obj->ls[dim_i].idx += nml_carry ;
1436         nml_carry = 0;
1437         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1438           {
1439             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1440             nml_carry = 1;
1441           }
1442        }
1443     }
1444
1445   /* Return a pointer beyond the furthest object accessed.  */
1446
1447   return retval;
1448 }
1449
1450
1451 /* This is the entry function for namelist writes.  It outputs the name
1452    of the namelist and iterates through the namelist by calls to
1453    nml_write_obj.  The call below has dummys in the arguments used in
1454    the treatment of derived types.  */
1455
1456 void
1457 namelist_write (st_parameter_dt *dtp)
1458 {
1459   namelist_info * t1, *t2, *dummy = NULL;
1460   index_type i;
1461   index_type dummy_offset = 0;
1462   char c;
1463   char * dummy_name = NULL;
1464   unit_delim tmp_delim = DELIM_UNSPECIFIED;
1465
1466   /* Set the delimiter for namelist output.  */
1467 if (dtp->common.flags & IOPARM_DT_HAS_F2003)
1468   {
1469   tmp_delim = dtp->u.p.delim_status;
1470   switch (tmp_delim)
1471     {
1472     case (DELIM_QUOTE):
1473       dtp->u.p.nml_delim = '"';
1474       break;
1475
1476     case (DELIM_APOSTROPHE):
1477       dtp->u.p.nml_delim = '\'';
1478       break;
1479
1480     default:
1481       dtp->u.p.nml_delim = '\0';
1482       break;
1483     }
1484
1485   /* Temporarily disable namelist delimters.  */
1486   dtp->u.p.delim_status = DELIM_NONE;
1487   }
1488   write_character (dtp, "&", 1, 1);
1489
1490   /* Write namelist name in upper case - f95 std.  */
1491   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1492     {
1493       c = toupper (dtp->namelist_name[i]);
1494       write_character (dtp, &c, 1 ,1);
1495     }
1496
1497   if (dtp->u.p.ionml != NULL)
1498     {
1499       t1 = dtp->u.p.ionml;
1500       while (t1 != NULL)
1501         {
1502           t2 = t1;
1503           t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1504         }
1505     }
1506
1507   write_character (dtp, "  /", 1, 3);
1508   namelist_write_newline (dtp);
1509   /* Restore the original delimiter.  */
1510   if (dtp->common.flags & IOPARM_DT_HAS_F2003)
1511     dtp->u.p.delim_status = tmp_delim;
1512 }
1513
1514 #undef NML_DIGITS