OSDN Git Service

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