OSDN Git Service

553557d7b885b79a7e031fdbaeaa972eec1527d9
[pf3gnuchains/gcc-fork.git] / libgfortran / io / write.c
1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3    Namelist output contibuted by Paul Thomas
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file.  (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
20
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24 GNU General Public License for more details.
25
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING.  If not, write to
28 the Free Software Foundation, 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA.  */
30
31 #include "config.h"
32 #include <string.h>
33 #include <ctype.h>
34 #include <float.h>
35 #include <stdio.h>
36 #include <stdlib.h>
37 #include "libgfortran.h"
38 #include "io.h"
39
40
41 #define star_fill(p, n) memset(p, '*', n)
42
43
44 typedef enum
45 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
46 sign_t;
47
48
49 static int no_leading_blank = 0 ;
50
51 void
52 write_a (fnode * f, const char *source, int len)
53 {
54   int wlen;
55   char *p;
56
57   wlen = f->u.string.length < 0 ? len : f->u.string.length;
58
59   p = write_block (wlen);
60   if (p == NULL)
61     return;
62
63   if (wlen < len)
64     memcpy (p, source, wlen);
65   else
66     {
67       memset (p, ' ', wlen - len);
68       memcpy (p + wlen - len, source, len);
69     }
70 }
71
72 static int64_t
73 extract_int (const void *p, int len)
74 {
75   int64_t i = 0;
76
77   if (p == NULL)
78     return i;
79
80   switch (len)
81     {
82     case 1:
83       i = *((const int8_t *) p);
84       break;
85     case 2:
86       i = *((const int16_t *) p);
87       break;
88     case 4:
89       i = *((const int32_t *) p);
90       break;
91     case 8:
92       i = *((const int64_t *) p);
93       break;
94     default:
95       internal_error ("bad integer kind");
96     }
97
98   return i;
99 }
100
101 static double
102 extract_real (const void *p, int len)
103 {
104   double i = 0.0;
105   switch (len)
106     {
107     case 4:
108       i = *((const float *) p);
109       break;
110     case 8:
111       i = *((const double *) p);
112       break;
113     default:
114       internal_error ("bad real kind");
115     }
116   return i;
117
118 }
119
120
121 /* Given a flag that indicate if a value is negative or not, return a
122    sign_t that gives the sign that we need to produce.  */
123
124 static sign_t
125 calculate_sign (int negative_flag)
126 {
127   sign_t s = SIGN_NONE;
128
129   if (negative_flag)
130     s = SIGN_MINUS;
131   else
132     switch (g.sign_status)
133       {
134       case SIGN_SP:
135         s = SIGN_PLUS;
136         break;
137       case SIGN_SS:
138         s = SIGN_NONE;
139         break;
140       case SIGN_S:
141         s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
142         break;
143       }
144
145   return s;
146 }
147
148
149 /* Returns the value of 10**d.  */
150
151 static double
152 calculate_exp (int d)
153 {
154   int i;
155   double r = 1.0;
156
157   for (i = 0; i< (d >= 0 ? d : -d); i++)
158     r *= 10;
159
160   r = (d >= 0) ? r : 1.0 / r;
161
162   return r;
163 }
164
165
166 /* Generate corresponding I/O format for FMT_G output.
167    The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
168    LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
169
170    Data Magnitude                              Equivalent Conversion
171    0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
172    m = 0                                       F(w-n).(d-1), n' '
173    0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
174    1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
175    10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
176    ................                           ..........
177    10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
178    m >= 10**d-0.5                              Ew.d[Ee]
179
180    notes: for Gw.d ,  n' ' means 4 blanks
181           for Gw.dEe, n' ' means e+2 blanks  */
182
183 static fnode *
184 calculate_G_format (fnode *f, double value, int len, int *num_blank)
185 {
186   int e = f->u.real.e;
187   int d = f->u.real.d;
188   int w = f->u.real.w;
189   fnode *newf;
190   double m, exp_d;
191   int low, high, mid;
192   int ubound, lbound;
193
194   newf = get_mem (sizeof (fnode));
195
196   /* Absolute value.  */
197   m = (value > 0.0) ? value : -value;
198
199   /* In case of the two data magnitude ranges,
200      generate E editing, Ew.d[Ee].  */
201   exp_d = calculate_exp (d);
202   if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
203       || (m >= (double) exp_d - 0.5 ))
204     {
205       newf->format = FMT_E;
206       newf->u.real.w = w;
207       newf->u.real.d = d;
208       newf->u.real.e = e;
209       *num_blank = 0;
210       return newf;
211     }
212
213   /* Use binary search to find the data magnitude range.  */
214   mid = 0;
215   low = 0;
216   high = d + 1;
217   lbound = 0;
218   ubound = d + 1;
219
220   while (low <= high)
221     {
222       double temp;
223       mid = (low + high) / 2;
224
225       /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
226       temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
227
228       if (m < temp)
229         {
230           ubound = mid;
231           if (ubound == lbound + 1)
232             break;
233           high = mid - 1;
234         }
235       else if (m > temp)
236         {
237           lbound = mid;
238           if (ubound == lbound + 1)
239             {
240               mid ++;
241               break;
242             }
243           low = mid + 1;
244         }
245       else
246         break;
247     }
248
249   /* Pad with blanks where the exponent would be.  */
250   if (e < 0)
251     *num_blank = 4;
252   else
253     *num_blank = e + 2;
254
255   /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '.  */
256   newf->format = FMT_F;
257   newf->u.real.w = f->u.real.w - *num_blank;
258
259   /* Special case.  */
260   if (m == 0.0)
261     newf->u.real.d = d - 1;
262   else
263     newf->u.real.d = - (mid - d - 1);
264
265   /* For F editing, the scale factor is ignored.  */
266   g.scale_factor = 0;
267   return newf;
268 }
269
270
271 /* Output a real number according to its format which is FMT_G free.  */
272
273 static void
274 output_float (fnode *f, double value, int len)
275 {
276   /* This must be large enough to accurately hold any value.  */ 
277   char buffer[32];
278   char *out;
279   char *digits;
280   int e;
281   char expchar;
282   format_token ft;
283   int w;
284   int d;
285   int edigits;
286   int ndigits;
287   /* Number of digits before the decimal point.  */
288   int nbefore;
289   /* Number of zeros after the decimal point.  */
290   int nzero;
291   /* Number of digits after the decimal point.  */
292   int nafter;
293   /* Number of zeros after the decimal point, whatever the precision.  */
294   int nzero_real;
295   int leadzero;
296   int nblanks;
297   int i;
298   sign_t sign;
299
300   ft = f->format;
301   w = f->u.real.w;
302   d = f->u.real.d;
303
304   nzero_real = -1;
305
306
307   /* We should always know the field width and precision.  */
308   if (d < 0)
309     internal_error ("Unspecified precision");
310
311   /* Use sprintf to print the number in the format +D.DDDDe+ddd
312      For an N digit exponent, this gives us (32-6)-N digits after the
313      decimal point, plus another one before the decimal point.  */
314   sign = calculate_sign (value < 0.0);
315   if (value < 0)
316     value = -value;
317
318   /* Printf always prints at least two exponent digits.  */
319   if (value == 0)
320     edigits = 2;
321   else
322     {
323       edigits = 1 + (int) log10 (fabs(log10 (value)));
324       if (edigits < 2)
325         edigits = 2;
326     }
327   
328   if (ft == FMT_F || ft == FMT_EN
329       || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
330     {
331       /* Always convert at full precision to avoid double rounding.  */
332       ndigits = 27 - edigits;
333     }
334   else
335     {
336       /* We know the number of digits, so can let printf do the rounding
337          for us.  */
338       if (ft == FMT_ES)
339         ndigits = d + 1;
340       else
341         ndigits = d;
342       if (ndigits > 27 - edigits)
343         ndigits = 27 - edigits;
344     }
345
346   sprintf (buffer, "%+-#31.*e", ndigits - 1, value);
347   
348   /* Check the resulting string has punctuation in the correct places.  */
349   if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
350       internal_error ("printf is broken");
351
352   /* Read the exponent back in.  */
353   e = atoi (&buffer[ndigits + 3]) + 1;
354
355   /* Make sure zero comes out as 0.0e0.  */
356   if (value == 0.0)
357     e = 0;
358
359   /* Normalize the fractional component.  */
360   buffer[2] = buffer[1];
361   digits = &buffer[2];
362
363   /* Figure out where to place the decimal point.  */
364   switch (ft)
365     {
366     case FMT_F:
367       nbefore = e + g.scale_factor;
368       if (nbefore < 0)
369         {
370           nzero = -nbefore;
371           nzero_real = nzero;
372           if (nzero > d)
373             nzero = d;
374           nafter = d - nzero;
375           nbefore = 0;
376         }
377       else
378         {
379           nzero = 0;
380           nafter = d;
381         }
382       expchar = 0;
383       break;
384
385     case FMT_E:
386     case FMT_D:
387       i = g.scale_factor;
388       if (value != 0.0)
389         e -= i;
390       if (i < 0)
391         {
392           nbefore = 0;
393           nzero = -i;
394           nafter = d + i;
395         }
396       else if (i > 0)
397         {
398           nbefore = i;
399           nzero = 0;
400           nafter = (d - i) + 1;
401         }
402       else /* i == 0 */
403         {
404           nbefore = 0;
405           nzero = 0;
406           nafter = d;
407         }
408
409       if (ft == FMT_E)
410         expchar = 'E';
411       else
412         expchar = 'D';
413       break;
414
415     case FMT_EN:
416       /* The exponent must be a multiple of three, with 1-3 digits before
417          the decimal point.  */
418       if (value != 0.0)
419         e--;
420       if (e >= 0)
421         nbefore = e % 3;
422       else
423         {
424           nbefore = (-e) % 3;
425           if (nbefore != 0)
426             nbefore = 3 - nbefore;
427         }
428       e -= nbefore;
429       nbefore++;
430       nzero = 0;
431       nafter = d;
432       expchar = 'E';
433       break;
434
435     case FMT_ES:
436       if (value != 0.0)
437         e--;
438       nbefore = 1;
439       nzero = 0;
440       nafter = d;
441       expchar = 'E';
442       break;
443
444     default:
445       /* Should never happen.  */
446       internal_error ("Unexpected format token");
447     }
448
449   /* Round the value.  */
450   if (nbefore + nafter == 0)
451     {
452       ndigits = 0;
453       if (nzero_real == d && digits[0] >= '5')
454         {
455           /* We rounded to zero but shouldn't have */
456           nzero--;
457           nafter = 1;
458           digits[0] = '1';
459           ndigits = 1;
460         }
461     }
462   else if (nbefore + nafter < ndigits)
463     {
464       ndigits = nbefore + nafter;
465       i = ndigits;
466       if (digits[i] >= '5')
467         {
468           /* Propagate the carry.  */
469           for (i--; i >= 0; i--)
470             {
471               if (digits[i] != '9')
472                 {
473                   digits[i]++;
474                   break;
475                 }
476               digits[i] = '0';
477             }
478
479           if (i < 0)
480             {
481               /* The carry overflowed.  Fortunately we have some spare space
482                  at the start of the buffer.  We may discard some digits, but
483                  this is ok because we already know they are zero.  */
484               digits--;
485               digits[0] = '1';
486               if (ft == FMT_F)
487                 {
488                   if (nzero > 0)
489                     {
490                       nzero--;
491                       nafter++;
492                     }
493                   else
494                     nbefore++;
495                 }
496               else if (ft == FMT_EN)
497                 {
498                   nbefore++;
499                   if (nbefore == 4)
500                     {
501                       nbefore = 1;
502                       e += 3;
503                     }
504                 }
505               else
506                 e++;
507             }
508         }
509     }
510
511   /* Calculate the format of the exponent field.  */
512   if (expchar)
513     {
514       edigits = 1;
515       for (i = abs (e); i >= 10; i /= 10)
516         edigits++;
517       
518       if (f->u.real.e < 0)
519         {
520           /* Width not specified.  Must be no more than 3 digits.  */
521           if (e > 999 || e < -999)
522             edigits = -1;
523           else
524             {
525               edigits = 4;
526               if (e > 99 || e < -99)
527                 expchar = ' ';
528             }
529         }
530       else
531         {
532           /* Exponent width specified, check it is wide enough.  */
533           if (edigits > f->u.real.e)
534             edigits = -1;
535           else
536             edigits = f->u.real.e + 2;
537         }
538     }
539   else
540     edigits = 0;
541
542   /* Pick a field size if none was specified.  */
543   if (w <= 0)
544     w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
545
546   /* Create the ouput buffer.  */
547   out = write_block (w);
548   if (out == NULL)
549     return;
550
551   /* Zero values always output as positive, even if the value was negative
552      before rounding.  */
553   for (i = 0; i < ndigits; i++)
554     {
555       if (digits[i] != '0')
556         break;
557     }
558   if (i == ndigits)
559     sign = calculate_sign (0);
560
561   /* Work out how much padding is needed.  */
562   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
563   if (sign != SIGN_NONE)
564     nblanks--;
565   
566   /* Check the value fits in the specified field width.  */
567   if (nblanks < 0 || edigits == -1)
568     {
569       star_fill (out, w);
570       return;
571     }
572
573   /* See if we have space for a zero before the decimal point.  */
574   if (nbefore == 0 && nblanks > 0)
575     {
576       leadzero = 1;
577       nblanks--;
578     }
579   else
580     leadzero = 0;
581
582   /* Padd to full field width.  */
583
584
585   if ( ( nblanks > 0 ) && !no_leading_blank )
586     {
587       memset (out, ' ', nblanks);
588       out += nblanks;
589     }
590
591   /* Output the initial sign (if any).  */
592   if (sign == SIGN_PLUS)
593     *(out++) = '+';
594   else if (sign == SIGN_MINUS)
595     *(out++) = '-';
596
597   /* Output an optional leading zero.  */
598   if (leadzero)
599     *(out++) = '0';
600
601   /* Output the part before the decimal point, padding with zeros.  */
602   if (nbefore > 0)
603     {
604       if (nbefore > ndigits)
605         i = ndigits;
606       else
607         i = nbefore;
608
609       memcpy (out, digits, i);
610       while (i < nbefore)
611         out[i++] = '0';
612
613       digits += i;
614       ndigits -= i;
615       out += nbefore;
616     }
617   /* Output the decimal point.  */
618   *(out++) = '.';
619
620   /* Output leading zeros after the decimal point.  */
621   if (nzero > 0)
622     {
623       for (i = 0; i < nzero; i++)
624         *(out++) = '0';
625     }
626
627   /* Output digits after the decimal point, padding with zeros.  */
628   if (nafter > 0)
629     {
630       if (nafter > ndigits)
631         i = ndigits;
632       else
633         i = nafter;
634
635       memcpy (out, digits, i);
636       while (i < nafter)
637         out[i++] = '0';
638
639       digits += i;
640       ndigits -= i;
641       out += nafter;
642     }
643   
644   /* Output the exponent.  */
645   if (expchar)
646     {
647       if (expchar != ' ')
648         {
649           *(out++) = expchar;
650           edigits--;
651         }
652 #if HAVE_SNPRINTF
653       snprintf (buffer, 32, "%+0*d", edigits, e);
654 #else
655       sprintf (buffer, "%+0*d", edigits, e);
656 #endif
657       memcpy (out, buffer, edigits);
658     }
659
660   if ( no_leading_blank )
661     {
662       out += edigits;
663       memset( out , ' ' , nblanks );
664       no_leading_blank = 0;
665     }
666 }
667
668
669 void
670 write_l (fnode * f, char *source, int len)
671 {
672   char *p;
673   int64_t n;
674
675   p = write_block (f->u.w);
676   if (p == NULL)
677     return;
678
679   memset (p, ' ', f->u.w - 1);
680   n = extract_int (source, len);
681   p[f->u.w - 1] = (n) ? 'T' : 'F';
682 }
683
684 /* Output a real number according to its format.  */
685
686 static void
687 write_float (fnode *f, const char *source, int len)
688 {
689   double n;
690   int nb =0, res, save_scale_factor;
691   char * p, fin;
692   fnode *f2 = NULL;
693
694   n = extract_real (source, len);
695
696   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
697     {
698       res = isfinite (n);
699       if (res == 0)
700         {
701           nb =  f->u.real.w;
702           p = write_block (nb);
703           if (nb < 3)
704             {
705               memset (p, '*',nb);
706               return;
707             }
708
709           memset(p, ' ', nb);
710           res = !isnan (n); 
711           if (res != 0)
712             {
713               if (signbit(n))   
714                 fin = '-';
715               else
716                 fin = '+';
717
718               if (nb > 7)
719                 memcpy(p + nb - 8, "Infinity", 8); 
720               else
721                 memcpy(p + nb - 3, "Inf", 3);
722               if (nb < 8 && nb > 3)
723                 p[nb - 4] = fin;
724               else if (nb > 8)
725                 p[nb - 9] = fin; 
726             }
727           else
728             memcpy(p + nb - 3, "NaN", 3);
729           return;
730         }
731     }
732
733   if (f->format != FMT_G)
734     {
735       output_float (f, n, len);
736     }
737   else
738     {
739       save_scale_factor = g.scale_factor;
740       f2 = calculate_G_format(f, n, len, &nb);
741       output_float (f2, n, len);
742       g.scale_factor = save_scale_factor;
743       if (f2 != NULL)
744         free_mem(f2);
745
746       if (nb > 0)
747         {
748           p = write_block (nb);
749           memset (p, ' ', nb);
750         }
751     }
752 }
753
754
755 static void
756 write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
757 {
758   uint32_t ns =0;
759   uint64_t n = 0;
760   int w, m, digits, nzero, nblank;
761   char *p, *q;
762
763   w = f->u.integer.w;
764   m = f->u.integer.m;
765
766   n = extract_int (source, len);
767
768   /* Special case:  */
769
770   if (m == 0 && n == 0)
771     {
772       if (w == 0)
773         w = 1;
774
775       p = write_block (w);
776       if (p == NULL)
777         return;
778
779       memset (p, ' ', w);
780       goto done;
781     }
782
783
784   if (len < 8)
785      {
786        ns = n;
787        q = conv (ns);
788      }
789   else
790       q = conv (n);
791
792   digits = strlen (q);
793
794   /* Select a width if none was specified.  The idea here is to always
795      print something.  */
796
797   if (w == 0)
798     w = ((digits < m) ? m : digits);
799
800   p = write_block (w);
801   if (p == NULL)
802     return;
803
804   nzero = 0;
805   if (digits < m)
806     nzero = m - digits;
807
808   /* See if things will work.  */
809
810   nblank = w - (nzero + digits);
811
812   if (nblank < 0)
813     {
814       star_fill (p, w);
815       goto done;
816     }
817
818
819   if (!no_leading_blank)
820     {
821   memset (p, ' ', nblank);
822   p += nblank;
823   memset (p, '0', nzero);
824   p += nzero;
825   memcpy (p, q, digits);
826     }
827   else
828     {
829       memset (p, '0', nzero);
830       p += nzero;
831       memcpy (p, q, digits);
832       p += digits;
833       memset (p, ' ', nblank);
834       no_leading_blank = 0;
835     }
836
837  done:
838   return;
839 }
840
841 static void
842 write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
843 {
844   int64_t n = 0;
845   int w, m, digits, nsign, nzero, nblank;
846   char *p, *q;
847   sign_t sign;
848
849   w = f->u.integer.w;
850   m = f->u.integer.m;
851
852   n = extract_int (source, len);
853
854   /* Special case:  */
855
856   if (m == 0 && n == 0)
857     {
858       if (w == 0)
859         w = 1;
860
861       p = write_block (w);
862       if (p == NULL)
863         return;
864
865       memset (p, ' ', w);
866       goto done;
867     }
868
869   sign = calculate_sign (n < 0);
870   if (n < 0)
871     n = -n;
872
873   nsign = sign == SIGN_NONE ? 0 : 1;
874   q = conv (n);
875
876   digits = strlen (q);
877
878   /* Select a width if none was specified.  The idea here is to always
879      print something.  */
880
881   if (w == 0)
882     w = ((digits < m) ? m : digits) + nsign;
883
884   p = write_block (w);
885   if (p == NULL)
886     return;
887
888   nzero = 0;
889   if (digits < m)
890     nzero = m - digits;
891
892   /* See if things will work.  */
893
894   nblank = w - (nsign + nzero + digits);
895
896   if (nblank < 0)
897     {
898       star_fill (p, w);
899       goto done;
900     }
901
902   memset (p, ' ', nblank);
903   p += nblank;
904
905   switch (sign)
906     {
907     case SIGN_PLUS:
908       *p++ = '+';
909       break;
910     case SIGN_MINUS:
911       *p++ = '-';
912       break;
913     case SIGN_NONE:
914       break;
915     }
916
917   memset (p, '0', nzero);
918   p += nzero;
919
920   memcpy (p, q, digits);
921
922  done:
923   return;
924 }
925
926
927 /* Convert unsigned octal to ascii.  */
928
929 static char *
930 otoa (uint64_t n)
931 {
932   char *p;
933
934   if (n == 0)
935     {
936       scratch[0] = '0';
937       scratch[1] = '\0';
938       return scratch;
939     }
940
941   p = scratch + sizeof (SCRATCH_SIZE) - 1;
942   *p-- = '\0';
943
944   while (n != 0)
945     {
946       *p = '0' + (n & 7);
947       p -- ;
948       n >>= 3;
949     }
950
951   return ++p;
952 }
953
954
955 /* Convert unsigned binary to ascii.  */
956
957 static char *
958 btoa (uint64_t n)
959 {
960   char *p;
961
962   if (n == 0)
963     {
964       scratch[0] = '0';
965       scratch[1] = '\0';
966       return scratch;
967     }
968
969   p = scratch + sizeof (SCRATCH_SIZE) - 1;
970   *p-- = '\0';
971
972   while (n != 0)
973     {
974       *p-- = '0' + (n & 1);
975       n >>= 1;
976     }
977
978   return ++p;
979 }
980
981
982 void
983 write_i (fnode * f, const char *p, int len)
984 {
985   write_decimal (f, p, len, (void *) gfc_itoa);
986 }
987
988
989 void
990 write_b (fnode * f, const char *p, int len)
991 {
992   write_int (f, p, len, btoa);
993 }
994
995
996 void
997 write_o (fnode * f, const char *p, int len)
998 {
999   write_int (f, p, len, otoa);
1000 }
1001
1002 void
1003 write_z (fnode * f, const char *p, int len)
1004 {
1005   write_int (f, p, len, xtoa);
1006 }
1007
1008
1009 void
1010 write_d (fnode *f, const char *p, int len)
1011 {
1012   write_float (f, p, len);
1013 }
1014
1015
1016 void
1017 write_e (fnode *f, const char *p, int len)
1018 {
1019   write_float (f, p, len);
1020 }
1021
1022
1023 void
1024 write_f (fnode *f, const char *p, int len)
1025 {
1026   write_float (f, p, len);
1027 }
1028
1029
1030 void
1031 write_en (fnode *f, const char *p, int len)
1032 {
1033   write_float (f, p, len);
1034 }
1035
1036
1037 void
1038 write_es (fnode *f, const char *p, int len)
1039 {
1040   write_float (f, p, len);
1041 }
1042
1043
1044 /* Take care of the X/TR descriptor.  */
1045
1046 void
1047 write_x (fnode * f)
1048 {
1049   char *p;
1050
1051   p = write_block (f->u.n);
1052   if (p == NULL)
1053     return;
1054
1055   memset (p, ' ', f->u.n);
1056 }
1057
1058
1059 /* List-directed writing.  */
1060
1061
1062 /* Write a single character to the output.  Returns nonzero if
1063    something goes wrong.  */
1064
1065 static int
1066 write_char (char c)
1067 {
1068   char *p;
1069
1070   p = write_block (1);
1071   if (p == NULL)
1072     return 1;
1073
1074   *p = c;
1075
1076   return 0;
1077 }
1078
1079
1080 /* Write a list-directed logical value.  */
1081
1082 static void
1083 write_logical (const char *source, int length)
1084 {
1085   write_char (extract_int (source, length) ? 'T' : 'F');
1086 }
1087
1088
1089 /* Write a list-directed integer value.  */
1090
1091 static void
1092 write_integer (const char *source, int length)
1093 {
1094   char *p;
1095   const char *q;
1096   int digits;
1097   int width;
1098
1099   q = gfc_itoa (extract_int (source, length));
1100
1101   switch (length)
1102     {
1103     case 1:
1104       width = 4;
1105       break;
1106
1107     case 2:
1108       width = 6;
1109       break;
1110
1111     case 4:
1112       width = 11;
1113       break;
1114
1115     case 8:
1116       width = 20;
1117       break;
1118
1119     default:
1120       width = 0;
1121       break;
1122     }
1123
1124   digits = strlen (q);
1125
1126   if(width < digits )
1127     width = digits ;
1128   p = write_block (width) ;
1129   if (no_leading_blank)
1130     {
1131       memcpy (p, q, digits);
1132       memset(p + digits ,' ', width - digits) ;
1133     }
1134   else
1135     {
1136   memset(p ,' ', width - digits) ;
1137   memcpy (p + width - digits, q, digits);
1138     }
1139 }
1140
1141
1142 /* Write a list-directed string.  We have to worry about delimiting
1143    the strings if the file has been opened in that mode.  */
1144
1145 static void
1146 write_character (const char *source, int length)
1147 {
1148   int i, extra;
1149   char *p, d;
1150
1151   switch (current_unit->flags.delim)
1152     {
1153     case DELIM_APOSTROPHE:
1154       d = '\'';
1155       break;
1156     case DELIM_QUOTE:
1157       d = '"';
1158       break;
1159     default:
1160       d = ' ';
1161       break;
1162     }
1163
1164   if (d == ' ')
1165     extra = 0;
1166   else
1167     {
1168       extra = 2;
1169
1170       for (i = 0; i < length; i++)
1171         if (source[i] == d)
1172           extra++;
1173     }
1174
1175   p = write_block (length + extra);
1176   if (p == NULL)
1177     return;
1178
1179   if (d == ' ')
1180     memcpy (p, source, length);
1181   else
1182     {
1183       *p++ = d;
1184
1185       for (i = 0; i < length; i++)
1186         {
1187           *p++ = source[i];
1188           if (source[i] == d)
1189             *p++ = d;
1190         }
1191
1192       *p = d;
1193     }
1194 }
1195
1196
1197 /* Output a real number with default format.
1198    This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8).  */
1199
1200 static void
1201 write_real (const char *source, int length)
1202 {
1203   fnode f ;
1204   int org_scale = g.scale_factor;
1205   f.format = FMT_G;
1206   g.scale_factor = 1;
1207   if (length < 8)
1208     {
1209       f.u.real.w = 14;
1210       f.u.real.d = 7;
1211       f.u.real.e = 2;
1212     }
1213   else
1214     {
1215       f.u.real.w = 23;
1216       f.u.real.d = 15;
1217       f.u.real.e = 3;
1218     }
1219   write_float (&f, source , length);
1220   g.scale_factor = org_scale;
1221 }
1222
1223
1224 static void
1225 write_complex (const char *source, int len)
1226 {
1227   if (write_char ('('))
1228     return;
1229   write_real (source, len);
1230
1231   if (write_char (','))
1232     return;
1233   write_real (source + len, len);
1234
1235   write_char (')');
1236 }
1237
1238
1239 /* Write the separator between items.  */
1240
1241 static void
1242 write_separator (void)
1243 {
1244   char *p;
1245
1246   p = write_block (options.separator_len);
1247   if (p == NULL)
1248     return;
1249
1250   memcpy (p, options.separator, options.separator_len);
1251 }
1252
1253
1254 /* Write an item with list formatting.
1255    TODO: handle skipping to the next record correctly, particularly
1256    with strings.  */
1257
1258 void
1259 list_formatted_write (bt type, void *p, int len)
1260 {
1261   static int char_flag;
1262
1263   if (current_unit == NULL)
1264     return;
1265
1266   if (g.first_item)
1267     {
1268       g.first_item = 0;
1269       char_flag = 0;
1270       write_char (' ');
1271     }
1272   else
1273     {
1274       if (type != BT_CHARACTER || !char_flag ||
1275           current_unit->flags.delim != DELIM_NONE)
1276         write_separator ();
1277     }
1278
1279   switch (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, len);
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 ("list_formatted_write(): Bad type");
1298     }
1299
1300   char_flag = (type == BT_CHARACTER);
1301 }
1302
1303 /*                      NAMELIST OUTPUT
1304
1305    nml_write_obj writes a namelist object to the output stream.  It is called
1306    recursively for derived type components:
1307         obj    = is the namelist_info for the current object.
1308         offset = the offset relative to the address held by the object for
1309                  derived type arrays.
1310         base   = is the namelist_info of the derived type, when obj is a
1311                  component.
1312         base_name = the full name for a derived type, including qualifiers
1313                     if any.
1314    The returned value is a pointer to the object beyond the last one
1315    accessed, including nested derived types.  Notice that the namelist is
1316    a linear linked list of objects, including derived types and their
1317    components.  A tree, of sorts, is implied by the compound names of
1318    the derived type components and this is how this function recurses through
1319    the list.  */
1320
1321 /* A generous estimate of the number of characters needed to print
1322    repeat counts and indices, including commas, asterices and brackets.  */
1323
1324 #define NML_DIGITS 20
1325
1326 /* Stores the delimiter to be used for character objects.  */
1327
1328 static char * nml_delim;
1329
1330 static namelist_info *
1331 nml_write_obj (namelist_info * obj, index_type offset,
1332                namelist_info * base, char * base_name)
1333 {
1334   int rep_ctr;
1335   int num;
1336   int nml_carry;
1337   index_type len;
1338   index_type obj_size;
1339   index_type nelem;
1340   index_type dim_i;
1341   index_type clen;
1342   index_type elem_ctr;
1343   index_type obj_name_len;
1344   void * p ;
1345   char cup;
1346   char * obj_name;
1347   char * ext_name;
1348   char rep_buff[NML_DIGITS];
1349   namelist_info * cmp;
1350   namelist_info * retval = obj->next;
1351
1352   /* Write namelist variable names in upper case. If a derived type,
1353      nothing is output.  If a component, base and base_name are set.  */
1354
1355   if (obj->type != GFC_DTYPE_DERIVED)
1356     {
1357       write_character ("\n ", 2);
1358       len = 0;
1359       if (base)
1360         {
1361           len =strlen (base->var_name);
1362           for (dim_i = 0; dim_i < strlen (base_name); dim_i++)
1363             {
1364               cup = toupper (base_name[dim_i]);
1365               write_character (&cup, 1);
1366             }
1367         }
1368       for (dim_i =len; dim_i < strlen (obj->var_name); dim_i++)
1369         {
1370           cup = toupper (obj->var_name[dim_i]);
1371           write_character (&cup, 1);
1372         }
1373       write_character ("=", 1);
1374     }
1375
1376   /* Counts the number of data output on a line, including names.  */
1377
1378   num = 1;
1379
1380   len = obj->len;
1381   obj_size = len;
1382   if (obj->type == GFC_DTYPE_COMPLEX)
1383     obj_size = 2*len;
1384   if (obj->type == GFC_DTYPE_CHARACTER)
1385     obj_size = obj->string_length;
1386   if (obj->var_rank)
1387     obj_size = obj->size;
1388
1389   /* Set the index vector and count the number of elements.  */
1390
1391   nelem = 1;
1392   for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1393     {
1394       obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1395       nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1396     }
1397
1398   /* Main loop to output the data held in the object.  */
1399
1400   rep_ctr = 1;
1401   for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1402     {
1403
1404       /* Build the pointer to the data value.  The offset is passed by
1405          recursive calls to this function for arrays of derived types.
1406          Is NULL otherwise.  */
1407
1408       p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1409       p += offset;
1410
1411       /* Check for repeat counts of intrinsic types.  */
1412
1413       if ((elem_ctr < (nelem - 1)) &&
1414           (obj->type != GFC_DTYPE_DERIVED) &&
1415           !memcmp (p, (void*)(p + obj_size ), obj_size ))
1416         {
1417           rep_ctr++;
1418         }
1419
1420       /* Execute a repeated output.  Note the flag no_leading_blank that
1421          is used in the functions used to output the intrinsic types.  */
1422
1423       else
1424         {
1425           if (rep_ctr > 1)
1426             {
1427               st_sprintf(rep_buff, " %d*", rep_ctr);
1428               write_character (rep_buff, strlen (rep_buff));
1429               no_leading_blank = 1;
1430             }
1431           num++;
1432
1433           /* Output the data, if an intrinsic type, or recurse into this 
1434              routine to treat derived types.  */
1435
1436           switch (obj->type)
1437             {
1438
1439             case GFC_DTYPE_INTEGER:
1440               write_integer (p, len);
1441               break;
1442
1443             case GFC_DTYPE_LOGICAL:
1444               write_logical (p, len);
1445               break;
1446
1447             case GFC_DTYPE_CHARACTER:
1448               if (nml_delim)
1449                 write_character (nml_delim, 1);
1450               write_character (p, obj->string_length);
1451               if (nml_delim)
1452                 write_character (nml_delim, 1);
1453               break;
1454
1455             case GFC_DTYPE_REAL:
1456               write_real (p, len);
1457               break;
1458
1459             case GFC_DTYPE_COMPLEX:
1460               no_leading_blank = 0;
1461               num++;
1462               write_complex (p, len);
1463               break;
1464
1465             case GFC_DTYPE_DERIVED:
1466
1467               /* To treat a derived type, we need to build two strings:
1468                  ext_name = the name, including qualifiers that prepends
1469                             component names in the output - passed to 
1470                             nml_write_obj.
1471                  obj_name = the derived type name with no qualifiers but %
1472                             appended.  This is used to identify the 
1473                             components.  */
1474
1475               /* First ext_name => get length of all possible components  */
1476
1477               ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
1478                                         + (base ? strlen (base->var_name) : 0)
1479                                         + strlen (obj->var_name)
1480                                         + obj->var_rank * NML_DIGITS
1481                                         + 1);
1482
1483               strcpy(ext_name, base_name ? base_name : "");
1484               clen = base ? strlen (base->var_name) : 0;
1485               strcat (ext_name, obj->var_name + clen);
1486
1487               /* Append the qualifier.  */
1488
1489               for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1490                 {
1491                   strcat (ext_name, dim_i ? "" : "(");
1492                   clen = strlen (ext_name);
1493                   st_sprintf (ext_name + clen, "%ld", (long) obj->ls[dim_i].idx);
1494                   strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
1495                 }
1496
1497               /* Now obj_name.  */
1498
1499               obj_name_len = strlen (obj->var_name) + 1;
1500               obj_name = get_mem (obj_name_len+1);
1501               strcpy (obj_name, obj->var_name);
1502               strcat (obj_name, "%");
1503
1504               /* Now loop over the components. Update the component pointer
1505                  with the return value from nml_write_obj => this loop jumps
1506                  past nested derived types.  */
1507
1508               for (cmp = obj->next;
1509                    cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1510                    cmp = retval)
1511                 {
1512                   retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
1513                                           obj, ext_name);
1514                 }
1515
1516               free_mem (obj_name);
1517               free_mem (ext_name);
1518               goto obj_loop;
1519
1520             default:
1521               internal_error ("Bad type for namelist write");
1522             }
1523
1524           /* Reset the leading blank suppression, write a comma and, if 5
1525              values have been output, write a newline and advance to column
1526              2. Reset the repeat counter.  */
1527
1528           no_leading_blank = 0;
1529           write_character (",", 1);
1530           if (num > 5)
1531             {
1532               num = 0;
1533               write_character ("\n ", 2);
1534             }
1535           rep_ctr = 1;
1536         }
1537
1538     /* Cycle through and increment the index vector.  */
1539
1540 obj_loop:
1541
1542     nml_carry = 1;
1543     for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1544       {
1545         obj->ls[dim_i].idx += nml_carry ;
1546         nml_carry = 0;
1547         if (obj->ls[dim_i].idx  > (ssize_t)obj->dim[dim_i].ubound)
1548           {
1549             obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1550             nml_carry = 1;
1551           }
1552        }
1553     }
1554
1555   /* Return a pointer beyond the furthest object accessed.  */
1556
1557   return retval;
1558 }
1559
1560 /* This is the entry function for namelist writes.  It outputs the name
1561    of the namelist and iterates through the namelist by calls to 
1562    nml_write_obj.  The call below has dummys in the arguments used in 
1563    the treatment of derived types.  */
1564
1565 void
1566 namelist_write (void)
1567 {
1568   namelist_info * t1, *t2, *dummy = NULL;
1569   index_type i;
1570   index_type dummy_offset = 0;
1571   char c;
1572   char * dummy_name = NULL;
1573   unit_delim tmp_delim;
1574
1575   /* Set the delimiter for namelist output.  */
1576
1577   tmp_delim = current_unit->flags.delim;
1578   current_unit->flags.delim = DELIM_NONE;
1579   switch (tmp_delim)
1580     {
1581     case (DELIM_QUOTE):
1582       nml_delim = "\"";
1583       break;
1584
1585     case (DELIM_APOSTROPHE):
1586       nml_delim = "'";
1587       break;
1588
1589     default:
1590       nml_delim = NULL;
1591     }
1592
1593   write_character ("&",1);
1594
1595   /* Write namelist name in upper case - f95 std.  */
1596
1597   for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
1598     {
1599       c = toupper (ioparm.namelist_name[i]);
1600       write_character (&c ,1);
1601             }
1602
1603   if (ionml != NULL)
1604     {
1605       t1 = ionml;
1606       while (t1 != NULL)
1607         {
1608           t2 = t1;
1609           t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
1610         }
1611     }
1612   write_character ("  /\n", 4);
1613
1614   /* Recover the original delimiter.  */
1615
1616   current_unit->flags.delim = tmp_delim;
1617 }
1618
1619 #undef NML_DIGITS
1620