OSDN Git Service

f98ec1f1f36196203da9a6bbf89dd18db4b69537
[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       snprintf (buffer, 32, "%+0*d", edigits, e);
619       memcpy (out, buffer, edigits);
620     }
621 }
622
623
624 void
625 write_l (fnode * f, char *source, int len)
626 {
627   char *p;
628   int64_t n;
629
630   p = write_block (f->u.w);
631   if (p == NULL)
632     return;
633
634   memset (p, ' ', f->u.w - 1);
635   n = extract_int (source, len);
636   p[f->u.w - 1] = (n) ? 'T' : 'F';
637 }
638
639 /* Output a real number according to its format.  */
640
641 static void
642 write_float (fnode *f, const char *source, int len)
643 {
644   double n;
645   int nb =0, res;
646   char * p, fin;
647   fnode *f2 = NULL;
648
649   n = extract_real (source, len);
650
651   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
652    {
653      res = finite (n);
654      if (res == 0)
655        {
656          nb =  f->u.real.w;
657          p = write_block (nb);
658          if (nb < 3)
659          {
660              memset (p, '*',nb);
661              return;
662          }
663
664          memset(p, ' ', nb);
665          res = !isnan (n); 
666          if (res != 0)
667          {
668             if (signbit(n))   
669                fin = '-';
670             else
671                fin = '+';
672
673             if (nb > 7)
674                memcpy(p + nb - 8, "Infinity", 8); 
675             else
676                memcpy(p + nb - 3, "Inf", 3);
677             if (nb < 8 && nb > 3)
678                p[nb - 4] = fin;
679             else if (nb > 8)
680                p[nb - 9] = fin; 
681           }
682          else
683              memcpy(p + nb - 3, "NaN", 3);
684          return;
685        }
686    }
687
688   if (f->format != FMT_G)
689     {
690       output_float (f, n, len);
691     }
692   else
693     {
694       f2 = calculate_G_format(f, n, len, &nb);
695       output_float (f2, n, len);
696       if (f2 != NULL)
697         free_mem(f2);
698
699       if (nb > 0)
700         {
701           p = write_block (nb);
702           memset (p, ' ', nb);
703         }
704     }
705 }
706
707
708 static void
709 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
710 {
711   uint32_t ns =0;
712   uint64_t n = 0;
713   int w, m, digits, nzero, nblank;
714   char *p, *q;
715
716   w = f->u.integer.w;
717   m = f->u.integer.m;
718
719   n = extract_int (source, len);
720
721   /* Special case:  */
722
723   if (m == 0 && n == 0)
724     {
725       if (w == 0)
726         w = 1;
727
728       p = write_block (w);
729       if (p == NULL)
730         return;
731
732       memset (p, ' ', w);
733       goto done;
734     }
735
736
737   if (len < 8)
738      {
739        ns = n;
740        q = conv (ns);
741      }
742   else
743       q = conv (n);
744
745   digits = strlen (q);
746
747   /* Select a width if none was specified.  The idea here is to always
748      print something.  */
749
750   if (w == 0)
751     w = ((digits < m) ? m : digits);
752
753   p = write_block (w);
754   if (p == NULL)
755     return;
756
757   nzero = 0;
758   if (digits < m)
759     nzero = m - digits;
760
761   /* See if things will work.  */
762
763   nblank = w - (nzero + digits);
764
765   if (nblank < 0)
766     {
767       star_fill (p, w);
768       goto done;
769     }
770
771   memset (p, ' ', nblank);
772   p += nblank;
773
774   memset (p, '0', nzero);
775   p += nzero;
776
777   memcpy (p, q, digits);
778
779 done:
780   return;
781 }
782
783 static void
784 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
785 {
786   int64_t n = 0;
787   int w, m, digits, nsign, nzero, nblank;
788   char *p, *q;
789   sign_t sign;
790
791   w = f->u.integer.w;
792   m = f->u.integer.m;
793
794   n = extract_int (source, len);
795
796   /* Special case:  */
797
798   if (m == 0 && n == 0)
799     {
800       if (w == 0)
801         w = 1;
802
803       p = write_block (w);
804       if (p == NULL)
805         return;
806
807       memset (p, ' ', w);
808       goto done;
809     }
810
811   sign = calculate_sign (n < 0);
812   if (n < 0)
813     n = -n;
814
815   nsign = sign == SIGN_NONE ? 0 : 1;
816   q = conv (n);
817
818   digits = strlen (q);
819
820   /* Select a width if none was specified.  The idea here is to always
821      print something.  */
822
823   if (w == 0)
824     w = ((digits < m) ? m : digits) + nsign;
825
826   p = write_block (w);
827   if (p == NULL)
828     return;
829
830   nzero = 0;
831   if (digits < m)
832     nzero = m - digits;
833
834   /* See if things will work.  */
835
836   nblank = w - (nsign + nzero + digits);
837
838   if (nblank < 0)
839     {
840       star_fill (p, w);
841       goto done;
842     }
843
844   memset (p, ' ', nblank);
845   p += nblank;
846
847   switch (sign)
848     {
849     case SIGN_PLUS:
850       *p++ = '+';
851       break;
852     case SIGN_MINUS:
853       *p++ = '-';
854       break;
855     case SIGN_NONE:
856       break;
857     }
858
859   memset (p, '0', nzero);
860   p += nzero;
861
862   memcpy (p, q, digits);
863
864 done:
865   return;
866 }
867
868
869 /* Convert unsigned octal to ascii.  */
870
871 static char *
872 otoa (uint64_t n)
873 {
874   char *p;
875
876   if (n == 0)
877     {
878       scratch[0] = '0';
879       scratch[1] = '\0';
880       return scratch;
881     }
882
883   p = scratch + sizeof (SCRATCH_SIZE) - 1;
884   *p-- = '\0';
885
886   while (n != 0)
887     {
888       *p = '0' + (n & 7);
889       p -- ;
890       n >>= 3;
891     }
892
893   return ++p;
894 }
895
896
897 /* Convert unsigned binary to ascii.  */
898
899 static char *
900 btoa (uint64_t n)
901 {
902   char *p;
903
904   if (n == 0)
905     {
906       scratch[0] = '0';
907       scratch[1] = '\0';
908       return scratch;
909     }
910
911   p = scratch + sizeof (SCRATCH_SIZE) - 1;
912   *p-- = '\0';
913
914   while (n != 0)
915     {
916       *p-- = '0' + (n & 1);
917       n >>= 1;
918     }
919
920   return ++p;
921 }
922
923
924 void
925 write_i (fnode * f, const char *p, int len)
926 {
927
928   write_decimal (f, p, len, (void *) itoa);
929 }
930
931
932 void
933 write_b (fnode * f, const char *p, int len)
934 {
935
936   write_int (f, p, len, btoa);
937 }
938
939
940 void
941 write_o (fnode * f, const char *p, int len)
942 {
943
944   write_int (f, p, len, otoa);
945 }
946
947 void
948 write_z (fnode * f, const char *p, int len)
949 {
950
951   write_int (f, p, len, xtoa);
952 }
953
954
955 void
956 write_d (fnode *f, const char *p, int len)
957 {
958
959   write_float (f, p, len);
960 }
961
962
963 void
964 write_e (fnode *f, const char *p, int len)
965 {
966
967   write_float (f, p, len);
968 }
969
970
971 void
972 write_f (fnode *f, const char *p, int len)
973 {
974
975   write_float (f, p, len);
976 }
977
978
979 void
980 write_en (fnode *f, const char *p, int len)
981 {
982
983   write_float (f, p, len);
984 }
985
986
987 void
988 write_es (fnode *f, const char *p, int len)
989 {
990
991   write_float (f, p, len);
992 }
993
994
995 /* Take care of the X/TR descriptor.  */
996
997 void
998 write_x (fnode * f)
999 {
1000   char *p;
1001
1002   p = write_block (f->u.n);
1003   if (p == NULL)
1004     return;
1005
1006   memset (p, ' ', f->u.n);
1007 }
1008
1009
1010 /* List-directed writing.  */
1011
1012
1013 /* Write a single character to the output.  Returns nonzero if
1014    something goes wrong.  */
1015
1016 static int
1017 write_char (char c)
1018 {
1019   char *p;
1020
1021   p = write_block (1);
1022   if (p == NULL)
1023     return 1;
1024
1025   *p = c;
1026
1027   return 0;
1028 }
1029
1030
1031 /* Write a list-directed logical value.  */
1032
1033 static void
1034 write_logical (const char *source, int length)
1035 {
1036   write_char (extract_int (source, length) ? 'T' : 'F');
1037 }
1038
1039
1040 /* Write a list-directed integer value.  */
1041
1042 static void
1043 write_integer (const char *source, int length)
1044 {
1045   char *p;
1046   const char *q;
1047   int digits;
1048   int width;
1049
1050   q = itoa (extract_int (source, length));
1051
1052   switch (length)
1053     {
1054     case 1:
1055       width = 4;
1056       break;
1057
1058     case 2:
1059       width = 6;
1060       break;
1061
1062     case 4:
1063       width = 11;
1064       break;
1065
1066     case 8:
1067       width = 20;
1068       break;
1069
1070     default:
1071       width = 0;
1072       break;
1073     }
1074
1075   digits = strlen (q);
1076
1077   if(width < digits )
1078     width = digits ;
1079   p = write_block (width) ;
1080
1081   memset(p ,' ', width - digits) ;
1082   memcpy (p + width - digits, q, digits);
1083 }
1084
1085
1086 /* Write a list-directed string.  We have to worry about delimiting
1087    the strings if the file has been opened in that mode.  */
1088
1089 static void
1090 write_character (const char *source, int length)
1091 {
1092   int i, extra;
1093   char *p, d;
1094
1095   switch (current_unit->flags.delim)
1096     {
1097     case DELIM_APOSTROPHE:
1098       d = '\'';
1099       break;
1100     case DELIM_QUOTE:
1101       d = '"';
1102       break;
1103     default:
1104       d = ' ';
1105       break;
1106     }
1107
1108   if (d == ' ')
1109     extra = 0;
1110   else
1111     {
1112       extra = 2;
1113
1114       for (i = 0; i < length; i++)
1115         if (source[i] == d)
1116           extra++;
1117     }
1118
1119   p = write_block (length + extra);
1120   if (p == NULL)
1121     return;
1122
1123   if (d == ' ')
1124     memcpy (p, source, length);
1125   else
1126     {
1127       *p++ = d;
1128
1129       for (i = 0; i < length; i++)
1130         {
1131           *p++ = source[i];
1132           if (source[i] == d)
1133             *p++ = d;
1134         }
1135
1136       *p = d;
1137     }
1138 }
1139
1140
1141 /* Output a real number with default format.
1142    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1143
1144 static void
1145 write_real (const char *source, int length)
1146 {
1147   fnode f ;
1148   int org_scale = g.scale_factor;
1149   f.format = FMT_G;
1150   g.scale_factor = 1;
1151   if (length < 8)
1152     {
1153       f.u.real.w = 14;
1154       f.u.real.d = 7;
1155       f.u.real.e = 2;
1156     }
1157   else
1158     {
1159       f.u.real.w = 23;
1160       f.u.real.d = 15;
1161       f.u.real.e = 3;
1162     }
1163   write_float (&f, source , length);
1164   g.scale_factor = org_scale;
1165 }
1166
1167
1168 static void
1169 write_complex (const char *source, int len)
1170 {
1171
1172   if (write_char ('('))
1173     return;
1174   write_real (source, len);
1175
1176   if (write_char (','))
1177     return;
1178   write_real (source + len, len);
1179
1180   write_char (')');
1181 }
1182
1183
1184 /* Write the separator between items.  */
1185
1186 static void
1187 write_separator (void)
1188 {
1189   char *p;
1190
1191   p = write_block (options.separator_len);
1192   if (p == NULL)
1193     return;
1194
1195   memcpy (p, options.separator, options.separator_len);
1196 }
1197
1198
1199 /* Write an item with list formatting.
1200    TODO: handle skipping to the next record correctly, particularly
1201    with strings.  */
1202
1203 void
1204 list_formatted_write (bt type, void *p, int len)
1205 {
1206   static int char_flag;
1207
1208   if (current_unit == NULL)
1209     return;
1210
1211   if (g.first_item)
1212     {
1213       g.first_item = 0;
1214       char_flag = 0;
1215       write_char (' ');
1216     }
1217   else
1218     {
1219       if (type != BT_CHARACTER || !char_flag ||
1220           current_unit->flags.delim != DELIM_NONE)
1221         write_separator ();
1222     }
1223
1224   switch (type)
1225     {
1226     case BT_INTEGER:
1227       write_integer (p, len);
1228       break;
1229     case BT_LOGICAL:
1230       write_logical (p, len);
1231       break;
1232     case BT_CHARACTER:
1233       write_character (p, len);
1234       break;
1235     case BT_REAL:
1236       write_real (p, len);
1237       break;
1238     case BT_COMPLEX:
1239       write_complex (p, len);
1240       break;
1241     default:
1242       internal_error ("list_formatted_write(): Bad type");
1243     }
1244
1245   char_flag = (type == BT_CHARACTER);
1246 }
1247
1248 void
1249 namelist_write (void)
1250 {
1251    namelist_info * t1, *t2;
1252    int len,num;
1253    void * p;
1254
1255    num = 0;
1256    write_character("&",1);
1257    write_character (ioparm.namelist_name, ioparm.namelist_name_len);
1258    write_character("\n",1);
1259
1260    if (ionml != NULL)
1261      {
1262        t1 = ionml;
1263        while (t1 != NULL)
1264         {
1265           num ++;
1266           t2 = t1;
1267           t1 = t1->next;
1268           if (t2->var_name)
1269             {
1270               write_character(t2->var_name, strlen(t2->var_name));
1271               write_character("=",1);
1272             }
1273           len = t2->len;
1274           p = t2->mem_pos;
1275           switch (t2->type)
1276             {
1277             case BT_INTEGER:
1278               write_integer (p, len);
1279               break;
1280             case BT_LOGICAL:
1281               write_logical (p, len);
1282               break;
1283             case BT_CHARACTER:
1284               write_character (p, t2->string_length);
1285               break;
1286             case BT_REAL:
1287               write_real (p, len);
1288               break;
1289             case BT_COMPLEX:
1290               write_complex (p, len);
1291               break;
1292             default:
1293               internal_error ("Bad type for namelist write");
1294             }
1295          write_character(",",1);
1296          if (num > 5)
1297            {
1298               num = 0;
1299               write_character("\n",1);
1300            }
1301         }
1302      }
1303      write_character("/",1);
1304
1305 }