OSDN Git Service

PR target/16135
[pf3gnuchains/gcc-fork.git] / libgfortran / io / write.c
1 /* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with Libgfortran; see the file COPYING.  If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA.  */
20
21 #include "config.h"
22 #include <string.h>
23 #include <float.h>
24 #include <stdio.h>
25 #include <stdlib.h>
26 #include "libgfortran.h"
27 #include "io.h"
28
29
30 #define star_fill(p, n) memset(p, '*', n)
31
32
33 typedef enum
34 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
35 sign_t;
36
37
38 void
39 write_a (fnode * f, const char *source, int len)
40 {
41   int wlen;
42   char *p;
43
44   wlen = f->u.string.length < 0 ? len : f->u.string.length;
45
46   p = write_block (wlen);
47   if (p == NULL)
48     return;
49
50   if (wlen < len)
51     memcpy (p, source, wlen);
52   else
53     {
54       memset (p, ' ', wlen - len);
55       memcpy (p + wlen - len, source, len);
56     }
57 }
58
59 static int64_t
60 extract_int (const void *p, int len)
61 {
62   int64_t i = 0;
63
64   if (p == NULL)
65     return i;
66
67   switch (len)
68     {
69     case 1:
70       i = *((const int8_t *) p);
71       break;
72     case 2:
73       i = *((const int16_t *) p);
74       break;
75     case 4:
76       i = *((const int32_t *) p);
77       break;
78     case 8:
79       i = *((const int64_t *) p);
80       break;
81     default:
82       internal_error ("bad integer kind");
83     }
84
85   return i;
86 }
87
88 static double
89 extract_real (const void *p, int len)
90 {
91   double i = 0.0;
92   switch (len)
93     {
94     case 4:
95       i = *((const float *) p);
96       break;
97     case 8:
98       i = *((const double *) p);
99       break;
100     default:
101       internal_error ("bad real kind");
102     }
103   return i;
104
105 }
106
107
108 /* Given a flag that indicate if a value is negative or not, return a
109    sign_t that gives the sign that we need to produce.  */
110
111 static sign_t
112 calculate_sign (int negative_flag)
113 {
114   sign_t s = SIGN_NONE;
115
116   if (negative_flag)
117     s = SIGN_MINUS;
118   else
119     switch (g.sign_status)
120       {
121       case SIGN_SP:
122         s = SIGN_PLUS;
123         break;
124       case SIGN_SS:
125         s = SIGN_NONE;
126         break;
127       case SIGN_S:
128         s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
129         break;
130       }
131
132   return s;
133 }
134
135
136 /* Returns the value of 10**d.  */
137
138 static double
139 calculate_exp (int d)
140 {
141   int i;
142   double r = 1.0;
143
144   for (i = 0; i< (d >= 0 ? d : -d); i++)
145     r *= 10;
146
147   r = (d >= 0) ? r : 1.0 / r;
148
149   return r;
150 }
151
152
153 /* Generate corresponding I/O format for FMT_G output.
154    The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
155    LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
156
157    Data Magnitude                              Equivalent Conversion
158    0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
159    m = 0                                       F(w-n).(d-1), n' '
160    0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
161    1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
162    10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
163    ................                           ..........
164    10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
165    m >= 10**d-0.5                              Ew.d[Ee]
166
167    notes: for Gw.d ,  n' ' means 4 blanks
168           for Gw.dEe, n' ' means e+2 blanks  */
169
170 static fnode *
171 calculate_G_format (fnode *f, double value, int len, int *num_blank)
172 {
173   int e = f->u.real.e;
174   int d = f->u.real.d;
175   int w = f->u.real.w;
176   fnode *newf;
177   double m, exp_d;
178   int low, high, mid;
179   int ubound, lbound;
180
181   newf = get_mem (sizeof (fnode));
182
183   /* Absolute value.  */
184   m = (value > 0.0) ? value : -value;
185
186   /* In case of the two data magnitude ranges,
187      generate E editing, Ew.d[Ee].  */
188   exp_d = calculate_exp (d);
189   if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
190       || (m >= (double) exp_d - 0.5 ))
191     {
192       newf->format = FMT_E;
193       newf->u.real.w = w;
194       newf->u.real.d = d;
195       newf->u.real.e = e;
196       *num_blank = 0;
197       return newf;
198     }
199
200   /* Use binary search to find the data magnitude range.  */
201   mid = 0;
202   low = 0;
203   high = d + 1;
204   lbound = 0;
205   ubound = d + 1;
206
207   while (low <= high)
208     {
209       double temp;
210       mid = (low + high) / 2;
211
212       /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
213       temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
214
215       if (m < temp)
216         {
217           ubound = mid;
218           if (ubound == lbound + 1)
219             break;
220           high = mid - 1;
221         }
222       else if (m > temp)
223         {
224           lbound = mid;
225           if (ubound == lbound + 1)
226             {
227               mid ++;
228               break;
229             }
230           low = mid + 1;
231         }
232       else
233         break;
234     }
235
236   /* Pad with blanks where the exponent would be.  */
237   if (e < 0)
238     *num_blank = 4;
239   else
240     *num_blank = e + 2;
241
242   /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '.  */
243   newf->format = FMT_F;
244   newf->u.real.w = f->u.real.w - *num_blank;
245
246   /* Special case.  */
247   if (m == 0.0)
248     newf->u.real.d = d - 1;
249   else
250     newf->u.real.d = - (mid - d - 1);
251
252   /* For F editing, the scale factor is ignored.  */
253   g.scale_factor = 0;
254   return newf;
255 }
256
257
258 /* Output a real number according to its format which is FMT_G free.  */
259
260 static void
261 output_float (fnode *f, double value, int len)
262 {
263   /* This must be large enough to accurately hold any value.  */ 
264   char buffer[32];
265   char *out;
266   char *digits;
267   int e;
268   char expchar;
269   format_token ft;
270   int w;
271   int d;
272   int edigits;
273   int ndigits;
274   /* Number of digits before the decimal point.  */
275   int nbefore;
276   /* Number of zeros after the decimal point.  */
277   int nzero;
278   /* Number of digits after the decimal point.  */
279   int nafter;
280   int leadzero;
281   int nblanks;
282   int i;
283   sign_t sign;
284
285   ft = f->format;
286   w = f->u.real.w;
287   d = f->u.real.d;
288
289   /* We should always know the field width and precision.  */
290   if (d < 0)
291     internal_error ("Uspecified precision");
292
293   /* Use sprintf to print the number in the format +D.DDDDe+ddd
294      For an N digit exponent, this gives us (32-6)-N digits after the
295      decimal point, plus another one before the decimal point.  */
296   sign = calculate_sign (value < 0.0);
297   if (value < 0)
298     value = -value;
299
300   /* Printf always prints at least two exponent digits.  */
301   if (value == 0)
302     edigits = 2;
303   else
304     {
305       edigits = 1 + (int) log10 (fabs(log10 (value)));
306       if (edigits < 2)
307         edigits = 2;
308     }
309   
310   if (ft == FMT_F || ft == FMT_EN
311       || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
312     {
313       /* Always convert at full precision to avoid double rounding.  */
314       ndigits = 27 - edigits;
315     }
316   else
317     {
318       /* We know the number of digits, so can let printf do the rounding
319          for us.  */
320       if (ft == FMT_ES)
321         ndigits = d + 1;
322       else
323         ndigits = d;
324       if (ndigits > 27 - edigits)
325         ndigits = 27 - edigits;
326     }
327
328   sprintf (buffer, "%+-#31.*e", ndigits - 1, value);
329   
330   /* Check the resulting string has punctuation in the correct places.  */
331   if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
332       internal_error ("printf is broken");
333
334   /* Read the exponent back in.  */
335   e = atoi (&buffer[ndigits + 3]) + 1;
336
337   /* Make sure zero comes out as 0.0e0.  */
338   if (value == 0.0)
339     e = 0;
340
341   /* Normalize the fractional component.  */
342   buffer[2] = buffer[1];
343   digits = &buffer[2];
344
345   /* Figure out where to place the decimal point.  */
346   switch (ft)
347     {
348     case FMT_F:
349       nbefore = e + g.scale_factor;
350       if (nbefore < 0)
351         {
352           nzero = -nbefore;
353           if (nzero > d)
354             nzero = d;
355           nafter = d - nzero;
356           nbefore = 0;
357         }
358       else
359         {
360           nzero = 0;
361           nafter = d;
362         }
363       expchar = 0;
364       break;
365
366     case FMT_E:
367     case FMT_D:
368       i = g.scale_factor;
369       e -= i;
370       if (i < 0)
371         {
372           nbefore = 0;
373           nzero = -i;
374           nafter = d + i;
375         }
376       else if (i > 0)
377         {
378           nbefore = i;
379           nzero = 0;
380           nafter = (d - i) + 1;
381         }
382       else /* i == 0 */
383         {
384           nbefore = 0;
385           nzero = 0;
386           nafter = d;
387         }
388
389       if (ft = FMT_E)
390         expchar = 'E';
391       else
392         expchar = 'D';
393       break;
394
395     case FMT_EN:
396       /* The exponent must be a multiple of three, with 1-3 digits before
397          the decimal point.  */
398       e--;
399       if (e >= 0)
400         nbefore = e % 3;
401       else
402         {
403           nbefore = (-e) % 3;
404           if (nbefore != 0)
405             nbefore = 3 - nbefore;
406         }
407       e -= nbefore;
408       nbefore++;
409       nzero = 0;
410       nafter = d;
411       expchar = 'E';
412       break;
413
414     case FMT_ES:
415       e--;
416       nbefore = 1;
417       nzero = 0;
418       nafter = d;
419       expchar = 'E';
420       break;
421
422     default:
423       /* Should never happen.  */
424       internal_error ("Unexpected format token");
425     }
426
427   /* Round the value.  */
428   if (nbefore + nafter == 0)
429     ndigits = 0;
430   else if (nbefore + nafter < ndigits)
431     {
432       ndigits = nbefore + nafter;
433       i = ndigits;
434       if (digits[i] >= '5')
435         {
436           /* Propagate the carry.  */
437           for (i--; i >= 0; i--)
438             {
439               if (digits[i] != '9')
440                 {
441                   digits[i]++;
442                   break;
443                 }
444               digits[i] = '0';
445             }
446
447           if (i < 0)
448             {
449               /* The carry overflowed.  Fortunately we have some spare space
450                  at the start of the buffer.  We may discard some digits, but
451                  this is ok because we already know they are zero.  */
452               digits--;
453               digits[0] = '1';
454               if (ft == FMT_F)
455                 {
456                   if (nzero > 0)
457                     {
458                       nzero--;
459                       nafter++;
460                     }
461                   else
462                     nbefore++;
463                 }
464               else if (ft == FMT_EN)
465                 {
466                   nbefore++;
467                   if (nbefore == 4)
468                     {
469                       nbefore = 1;
470                       e += 3;
471                     }
472                 }
473               else
474                 e++;
475             }
476         }
477     }
478
479   /* Calculate the format of the exponent field.  */
480   if (expchar)
481     {
482       edigits = 1;
483       for (i = abs (e); i >= 10; i /= 10)
484         edigits++;
485       
486       if (f->u.real.e < 0)
487         {
488           /* Width not specified.  Must be no more than 3 digits.  */
489           if (e > 999 || e < -999)
490             edigits = -1;
491           else
492             {
493               edigits = 4;
494               if (e > 99 || e < -99)
495                 expchar = ' ';
496             }
497         }
498       else
499         {
500           /* Exponent width specified, check it is wide enough.  */
501           if (edigits > f->u.real.e)
502             edigits = -1;
503           else
504             edigits = f->u.real.e + 2;
505         }
506     }
507   else
508     edigits = 0;
509
510   /* Pick a field size if none was specified.  */
511   if (w <= 0)
512     w = nbefore + nzero + nafter + 2;
513
514   /* Create the ouput buffer.  */
515   out = write_block (w);
516   if (out == NULL)
517     return;
518
519   /* Zero values always output as positive, even if the value was negative
520      before rounding.  */
521   for (i = 0; i < ndigits; i++)
522     {
523       if (digits[i] != '0')
524         break;
525     }
526   if (i == ndigits)
527     sign = calculate_sign (0);
528
529   /* Work out how much padding is needed.  */
530   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
531   if (sign != SIGN_NONE)
532     nblanks--;
533   
534   /* Check the value fits in the specified field width.  */
535   if (nblanks < 0 || edigits == -1)
536     {
537       star_fill (out, w);
538       return;
539     }
540
541   /* See if we have space for a zero before the decimal point.  */
542   if (nbefore == 0 && nblanks > 0)
543     {
544       leadzero = 1;
545       nblanks--;
546     }
547   else
548     leadzero = 0;
549
550   /* Padd to full field width.  */
551   if (nblanks > 0)
552     {
553       memset (out, ' ', nblanks);
554       out += nblanks;
555     }
556
557   /* Output the initial sign (if any).  */
558   if (sign == SIGN_PLUS)
559     *(out++) = '+';
560   else if (sign == SIGN_MINUS)
561     *(out++) = '-';
562
563   /* Output an optional leading zero.  */
564   if (leadzero)
565     *(out++) = '0';
566
567   /* Output the part before the decimal point, padding with zeros.  */
568   if (nbefore > 0)
569     {
570       if (nbefore > ndigits)
571         i = ndigits;
572       else
573         i = nbefore;
574
575       memcpy (out, digits, i);
576       while (i < nbefore)
577         out[i++] = '0';
578
579       digits += i;
580       ndigits -= i;
581       out += nbefore;
582     }
583   /* Output the decimal point.  */
584   *(out++) = '.';
585
586   /* Output leading zeros after the decimal point.  */
587   if (nzero > 0)
588     {
589       for (i = 0; i < nzero; i++)
590         *(out++) = '0';
591     }
592
593   /* Output digits after the decimal point, padding with zeros.  */
594   if (nafter > 0)
595     {
596       if (nafter > ndigits)
597         i = ndigits;
598       else
599         i = nafter;
600
601       memcpy (out, digits, i);
602       while (i < nafter)
603         out[i++] = '0';
604
605       digits += i;
606       ndigits -= i;
607       out += nafter;
608     }
609   
610   /* Output the exponent.  */
611   if (expchar)
612     {
613       if (expchar != ' ')
614         {
615           *(out++) = expchar;
616           edigits--;
617         }
618 #if HAVE_SNPRINTF
619       snprintf (buffer, 32, "%+0*d", edigits, e);
620 #else
621       sprintf (buffer, "%+0*d", edigits, e);
622 #endif
623       memcpy (out, buffer, edigits);
624     }
625 }
626
627
628 void
629 write_l (fnode * f, char *source, int len)
630 {
631   char *p;
632   int64_t n;
633
634   p = write_block (f->u.w);
635   if (p == NULL)
636     return;
637
638   memset (p, ' ', f->u.w - 1);
639   n = extract_int (source, len);
640   p[f->u.w - 1] = (n) ? 'T' : 'F';
641 }
642
643 /* Output a real number according to its format.  */
644
645 static void
646 write_float (fnode *f, const char *source, int len)
647 {
648   double n;
649   int nb =0, res;
650   char * p, fin;
651   fnode *f2 = NULL;
652
653   n = extract_real (source, len);
654
655   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
656    {
657      res = finite (n);
658      if (res == 0)
659        {
660          nb =  f->u.real.w;
661          p = write_block (nb);
662          if (nb < 3)
663          {
664              memset (p, '*',nb);
665              return;
666          }
667
668          memset(p, ' ', nb);
669          res = !isnan (n); 
670          if (res != 0)
671          {
672             if (signbit(n))   
673                fin = '-';
674             else
675                fin = '+';
676
677             if (nb > 7)
678                memcpy(p + nb - 8, "Infinity", 8); 
679             else
680                memcpy(p + nb - 3, "Inf", 3);
681             if (nb < 8 && nb > 3)
682                p[nb - 4] = fin;
683             else if (nb > 8)
684                p[nb - 9] = fin; 
685           }
686          else
687              memcpy(p + nb - 3, "NaN", 3);
688          return;
689        }
690    }
691
692   if (f->format != FMT_G)
693     {
694       output_float (f, n, len);
695     }
696   else
697     {
698       f2 = calculate_G_format(f, n, len, &nb);
699       output_float (f2, n, len);
700       if (f2 != NULL)
701         free_mem(f2);
702
703       if (nb > 0)
704         {
705           p = write_block (nb);
706           memset (p, ' ', nb);
707         }
708     }
709 }
710
711
712 static void
713 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
714 {
715   uint32_t ns =0;
716   uint64_t n = 0;
717   int w, m, digits, nzero, nblank;
718   char *p, *q;
719
720   w = f->u.integer.w;
721   m = f->u.integer.m;
722
723   n = extract_int (source, len);
724
725   /* Special case:  */
726
727   if (m == 0 && n == 0)
728     {
729       if (w == 0)
730         w = 1;
731
732       p = write_block (w);
733       if (p == NULL)
734         return;
735
736       memset (p, ' ', w);
737       goto done;
738     }
739
740
741   if (len < 8)
742      {
743        ns = n;
744        q = conv (ns);
745      }
746   else
747       q = conv (n);
748
749   digits = strlen (q);
750
751   /* Select a width if none was specified.  The idea here is to always
752      print something.  */
753
754   if (w == 0)
755     w = ((digits < m) ? m : digits);
756
757   p = write_block (w);
758   if (p == NULL)
759     return;
760
761   nzero = 0;
762   if (digits < m)
763     nzero = m - digits;
764
765   /* See if things will work.  */
766
767   nblank = w - (nzero + digits);
768
769   if (nblank < 0)
770     {
771       star_fill (p, w);
772       goto done;
773     }
774
775   memset (p, ' ', nblank);
776   p += nblank;
777
778   memset (p, '0', nzero);
779   p += nzero;
780
781   memcpy (p, q, digits);
782
783 done:
784   return;
785 }
786
787 static void
788 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
789 {
790   int64_t n = 0;
791   int w, m, digits, nsign, nzero, nblank;
792   char *p, *q;
793   sign_t sign;
794
795   w = f->u.integer.w;
796   m = f->u.integer.m;
797
798   n = extract_int (source, len);
799
800   /* Special case:  */
801
802   if (m == 0 && n == 0)
803     {
804       if (w == 0)
805         w = 1;
806
807       p = write_block (w);
808       if (p == NULL)
809         return;
810
811       memset (p, ' ', w);
812       goto done;
813     }
814
815   sign = calculate_sign (n < 0);
816   if (n < 0)
817     n = -n;
818
819   nsign = sign == SIGN_NONE ? 0 : 1;
820   q = conv (n);
821
822   digits = strlen (q);
823
824   /* Select a width if none was specified.  The idea here is to always
825      print something.  */
826
827   if (w == 0)
828     w = ((digits < m) ? m : digits) + nsign;
829
830   p = write_block (w);
831   if (p == NULL)
832     return;
833
834   nzero = 0;
835   if (digits < m)
836     nzero = m - digits;
837
838   /* See if things will work.  */
839
840   nblank = w - (nsign + nzero + digits);
841
842   if (nblank < 0)
843     {
844       star_fill (p, w);
845       goto done;
846     }
847
848   memset (p, ' ', nblank);
849   p += nblank;
850
851   switch (sign)
852     {
853     case SIGN_PLUS:
854       *p++ = '+';
855       break;
856     case SIGN_MINUS:
857       *p++ = '-';
858       break;
859     case SIGN_NONE:
860       break;
861     }
862
863   memset (p, '0', nzero);
864   p += nzero;
865
866   memcpy (p, q, digits);
867
868 done:
869   return;
870 }
871
872
873 /* Convert unsigned octal to ascii.  */
874
875 static char *
876 otoa (uint64_t n)
877 {
878   char *p;
879
880   if (n == 0)
881     {
882       scratch[0] = '0';
883       scratch[1] = '\0';
884       return scratch;
885     }
886
887   p = scratch + sizeof (SCRATCH_SIZE) - 1;
888   *p-- = '\0';
889
890   while (n != 0)
891     {
892       *p = '0' + (n & 7);
893       p -- ;
894       n >>= 3;
895     }
896
897   return ++p;
898 }
899
900
901 /* Convert unsigned binary to ascii.  */
902
903 static char *
904 btoa (uint64_t n)
905 {
906   char *p;
907
908   if (n == 0)
909     {
910       scratch[0] = '0';
911       scratch[1] = '\0';
912       return scratch;
913     }
914
915   p = scratch + sizeof (SCRATCH_SIZE) - 1;
916   *p-- = '\0';
917
918   while (n != 0)
919     {
920       *p-- = '0' + (n & 1);
921       n >>= 1;
922     }
923
924   return ++p;
925 }
926
927
928 void
929 write_i (fnode * f, const char *p, int len)
930 {
931
932   write_decimal (f, p, len, (void *) itoa);
933 }
934
935
936 void
937 write_b (fnode * f, const char *p, int len)
938 {
939
940   write_int (f, p, len, btoa);
941 }
942
943
944 void
945 write_o (fnode * f, const char *p, int len)
946 {
947
948   write_int (f, p, len, otoa);
949 }
950
951 void
952 write_z (fnode * f, const char *p, int len)
953 {
954
955   write_int (f, p, len, xtoa);
956 }
957
958
959 void
960 write_d (fnode *f, const char *p, int len)
961 {
962
963   write_float (f, p, len);
964 }
965
966
967 void
968 write_e (fnode *f, const char *p, int len)
969 {
970
971   write_float (f, p, len);
972 }
973
974
975 void
976 write_f (fnode *f, const char *p, int len)
977 {
978
979   write_float (f, p, len);
980 }
981
982
983 void
984 write_en (fnode *f, const char *p, int len)
985 {
986
987   write_float (f, p, len);
988 }
989
990
991 void
992 write_es (fnode *f, const char *p, int len)
993 {
994
995   write_float (f, p, len);
996 }
997
998
999 /* Take care of the X/TR descriptor.  */
1000
1001 void
1002 write_x (fnode * f)
1003 {
1004   char *p;
1005
1006   p = write_block (f->u.n);
1007   if (p == NULL)
1008     return;
1009
1010   memset (p, ' ', f->u.n);
1011 }
1012
1013
1014 /* List-directed writing.  */
1015
1016
1017 /* Write a single character to the output.  Returns nonzero if
1018    something goes wrong.  */
1019
1020 static int
1021 write_char (char c)
1022 {
1023   char *p;
1024
1025   p = write_block (1);
1026   if (p == NULL)
1027     return 1;
1028
1029   *p = c;
1030
1031   return 0;
1032 }
1033
1034
1035 /* Write a list-directed logical value.  */
1036
1037 static void
1038 write_logical (const char *source, int length)
1039 {
1040   write_char (extract_int (source, length) ? 'T' : 'F');
1041 }
1042
1043
1044 /* Write a list-directed integer value.  */
1045
1046 static void
1047 write_integer (const char *source, int length)
1048 {
1049   char *p;
1050   const char *q;
1051   int digits;
1052   int width;
1053
1054   q = itoa (extract_int (source, length));
1055
1056   switch (length)
1057     {
1058     case 1:
1059       width = 4;
1060       break;
1061
1062     case 2:
1063       width = 6;
1064       break;
1065
1066     case 4:
1067       width = 11;
1068       break;
1069
1070     case 8:
1071       width = 20;
1072       break;
1073
1074     default:
1075       width = 0;
1076       break;
1077     }
1078
1079   digits = strlen (q);
1080
1081   if(width < digits )
1082     width = digits ;
1083   p = write_block (width) ;
1084
1085   memset(p ,' ', width - digits) ;
1086   memcpy (p + width - digits, q, digits);
1087 }
1088
1089
1090 /* Write a list-directed string.  We have to worry about delimiting
1091    the strings if the file has been opened in that mode.  */
1092
1093 static void
1094 write_character (const char *source, int length)
1095 {
1096   int i, extra;
1097   char *p, d;
1098
1099   switch (current_unit->flags.delim)
1100     {
1101     case DELIM_APOSTROPHE:
1102       d = '\'';
1103       break;
1104     case DELIM_QUOTE:
1105       d = '"';
1106       break;
1107     default:
1108       d = ' ';
1109       break;
1110     }
1111
1112   if (d == ' ')
1113     extra = 0;
1114   else
1115     {
1116       extra = 2;
1117
1118       for (i = 0; i < length; i++)
1119         if (source[i] == d)
1120           extra++;
1121     }
1122
1123   p = write_block (length + extra);
1124   if (p == NULL)
1125     return;
1126
1127   if (d == ' ')
1128     memcpy (p, source, length);
1129   else
1130     {
1131       *p++ = d;
1132
1133       for (i = 0; i < length; i++)
1134         {
1135           *p++ = source[i];
1136           if (source[i] == d)
1137             *p++ = d;
1138         }
1139
1140       *p = d;
1141     }
1142 }
1143
1144
1145 /* Output a real number with default format.
1146    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1147
1148 static void
1149 write_real (const char *source, int length)
1150 {
1151   fnode f ;
1152   int org_scale = g.scale_factor;
1153   f.format = FMT_G;
1154   g.scale_factor = 1;
1155   if (length < 8)
1156     {
1157       f.u.real.w = 14;
1158       f.u.real.d = 7;
1159       f.u.real.e = 2;
1160     }
1161   else
1162     {
1163       f.u.real.w = 23;
1164       f.u.real.d = 15;
1165       f.u.real.e = 3;
1166     }
1167   write_float (&f, source , length);
1168   g.scale_factor = org_scale;
1169 }
1170
1171
1172 static void
1173 write_complex (const char *source, int len)
1174 {
1175
1176   if (write_char ('('))
1177     return;
1178   write_real (source, len);
1179
1180   if (write_char (','))
1181     return;
1182   write_real (source + len, len);
1183
1184   write_char (')');
1185 }
1186
1187
1188 /* Write the separator between items.  */
1189
1190 static void
1191 write_separator (void)
1192 {
1193   char *p;
1194
1195   p = write_block (options.separator_len);
1196   if (p == NULL)
1197     return;
1198
1199   memcpy (p, options.separator, options.separator_len);
1200 }
1201
1202
1203 /* Write an item with list formatting.
1204    TODO: handle skipping to the next record correctly, particularly
1205    with strings.  */
1206
1207 void
1208 list_formatted_write (bt type, void *p, int len)
1209 {
1210   static int char_flag;
1211
1212   if (current_unit == NULL)
1213     return;
1214
1215   if (g.first_item)
1216     {
1217       g.first_item = 0;
1218       char_flag = 0;
1219       write_char (' ');
1220     }
1221   else
1222     {
1223       if (type != BT_CHARACTER || !char_flag ||
1224           current_unit->flags.delim != DELIM_NONE)
1225         write_separator ();
1226     }
1227
1228   switch (type)
1229     {
1230     case BT_INTEGER:
1231       write_integer (p, len);
1232       break;
1233     case BT_LOGICAL:
1234       write_logical (p, len);
1235       break;
1236     case BT_CHARACTER:
1237       write_character (p, len);
1238       break;
1239     case BT_REAL:
1240       write_real (p, len);
1241       break;
1242     case BT_COMPLEX:
1243       write_complex (p, len);
1244       break;
1245     default:
1246       internal_error ("list_formatted_write(): Bad type");
1247     }
1248
1249   char_flag = (type == BT_CHARACTER);
1250 }
1251
1252 void
1253 namelist_write (void)
1254 {
1255    namelist_info * t1, *t2;
1256    int len,num;
1257    void * p;
1258
1259    num = 0;
1260    write_character("&",1);
1261    write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1262    write_character("\n",1);
1263
1264    if (ionml != NULL)
1265      {
1266        t1 = ionml;
1267        while (t1 != NULL)
1268         {
1269           num ++;
1270           t2 = t1;
1271           t1 = t1->next;
1272           if (t2->var_name)
1273             {
1274               write_character(t2->var_name, strlen(t2->var_name));
1275               write_character("=",1);
1276             }
1277           len = t2->len;
1278           p = t2->mem_pos;
1279           switch (t2->type)
1280             {
1281             case BT_INTEGER:
1282               write_integer (p, len);
1283               break;
1284             case BT_LOGICAL:
1285               write_logical (p, len);
1286               break;
1287             case BT_CHARACTER:
1288               write_character (p, t2->string_length);
1289               break;
1290             case BT_REAL:
1291               write_real (p, len);
1292               break;
1293             case BT_COMPLEX:
1294               write_complex (p, len);
1295               break;
1296             default:
1297               internal_error ("Bad type for namelist write");
1298             }
1299          write_character(",",1);
1300          if (num > 5)
1301            {
1302               num = 0;
1303               write_character("\n",1);
1304            }
1305         }
1306      }
1307      write_character("/",1);
1308
1309 }