OSDN Git Service

PR 43839
[pf3gnuchains/gcc-fork.git] / libgfortran / io / read.c
1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4    F2003 I/O support contributed by Jerry DeLisle
5
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
12
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25 <http://www.gnu.org/licenses/>.  */
26
27 #include "io.h"
28 #include "fbuf.h"
29 #include "format.h"
30 #include "unix.h"
31 #include <string.h>
32 #include <errno.h>
33 #include <ctype.h>
34 #include <stdlib.h>
35 #include <assert.h>
36
37 typedef unsigned char uchar;
38
39 /* read.c -- Deal with formatted reads */
40
41
42 /* set_integer()-- All of the integer assignments come here to
43  * actually place the value into memory.  */
44
45 void
46 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
47 {
48   switch (length)
49     {
50 #ifdef HAVE_GFC_INTEGER_16
51 /* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
52     case 10:
53     case 16:
54       {
55         GFC_INTEGER_16 tmp = value;
56         memcpy (dest, (void *) &tmp, length);
57       }
58       break;
59 #endif
60     case 8:
61       {
62         GFC_INTEGER_8 tmp = value;
63         memcpy (dest, (void *) &tmp, length);
64       }
65       break;
66     case 4:
67       {
68         GFC_INTEGER_4 tmp = value;
69         memcpy (dest, (void *) &tmp, length);
70       }
71       break;
72     case 2:
73       {
74         GFC_INTEGER_2 tmp = value;
75         memcpy (dest, (void *) &tmp, length);
76       }
77       break;
78     case 1:
79       {
80         GFC_INTEGER_1 tmp = value;
81         memcpy (dest, (void *) &tmp, length);
82       }
83       break;
84     default:
85       internal_error (NULL, "Bad integer kind");
86     }
87 }
88
89
90 /* max_value()-- Given a length (kind), return the maximum signed or
91  * unsigned value */
92
93 GFC_UINTEGER_LARGEST
94 max_value (int length, int signed_flag)
95 {
96   GFC_UINTEGER_LARGEST value;
97 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
98   int n;
99 #endif
100
101   switch (length)
102     {
103 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
104     case 16:
105     case 10:
106       value = 1;
107       for (n = 1; n < 4 * length; n++)
108         value = (value << 2) + 3;
109       if (! signed_flag)
110         value = 2*value+1;
111       break;
112 #endif
113     case 8:
114       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
115       break;
116     case 4:
117       value = signed_flag ? 0x7fffffff : 0xffffffff;
118       break;
119     case 2:
120       value = signed_flag ? 0x7fff : 0xffff;
121       break;
122     case 1:
123       value = signed_flag ? 0x7f : 0xff;
124       break;
125     default:
126       internal_error (NULL, "Bad integer kind");
127     }
128
129   return value;
130 }
131
132
133 /* convert_real()-- Convert a character representation of a floating
134  * point number to the machine number.  Returns nonzero if there is a
135  * range problem during conversion.  Note: many architectures
136  * (e.g. IA-64, HP-PA) require that the storage pointed to by the dest
137  * argument is properly aligned for the type in question.  TODO:
138  * handle not-a-numbers and infinities.  */
139
140 int
141 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
142 {
143   errno = 0;
144
145   switch (length)
146     {
147     case 4:
148       *((GFC_REAL_4*) dest) =
149 #if defined(HAVE_STRTOF)
150         gfc_strtof (buffer, NULL);
151 #else
152         (GFC_REAL_4) gfc_strtod (buffer, NULL);
153 #endif
154       break;
155
156     case 8:
157       *((GFC_REAL_8*) dest) = gfc_strtod (buffer, NULL);
158       break;
159
160 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
161     case 10:
162       *((GFC_REAL_10*) dest) = gfc_strtold (buffer, NULL);
163       break;
164 #endif
165
166 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
167     case 16:
168       *((GFC_REAL_16*) dest) = gfc_strtold (buffer, NULL);
169       break;
170 #endif
171
172     default:
173       internal_error (&dtp->common, "Unsupported real kind during IO");
174     }
175
176   if (errno == EINVAL)
177     {
178       generate_error (&dtp->common, LIBERROR_READ_VALUE,
179                       "Error during floating point read");
180       next_record (dtp, 1);
181       return 1;
182     }
183
184   return 0;
185 }
186
187
188 /* read_l()-- Read a logical value */
189
190 void
191 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
192 {
193   char *p;
194   int w;
195
196   w = f->u.w;
197
198   p = read_block_form (dtp, &w);
199
200   if (p == NULL)
201     return;
202
203   while (*p == ' ')
204     {
205       if (--w == 0)
206         goto bad;
207       p++;
208     }
209
210   if (*p == '.')
211     {
212       if (--w == 0)
213         goto bad;
214       p++;
215     }
216
217   switch (*p)
218     {
219     case 't':
220     case 'T':
221       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
222       break;
223     case 'f':
224     case 'F':
225       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
226       break;
227     default:
228     bad:
229       generate_error (&dtp->common, LIBERROR_READ_VALUE,
230                       "Bad value on logical read");
231       next_record (dtp, 1);
232       break;
233     }
234 }
235
236
237 static gfc_char4_t
238 read_utf8 (st_parameter_dt *dtp, int *nbytes) 
239 {
240   static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
241   static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
242   int i, nb, nread;
243   gfc_char4_t c;
244   char *s;
245
246   *nbytes = 1;
247
248   s = read_block_form (dtp, nbytes);
249   if (s == NULL)
250     return 0;
251
252   /* If this is a short read, just return.  */
253   if (*nbytes == 0)
254     return 0;
255
256   c = (uchar) s[0];
257   if (c < 0x80)
258     return c;
259
260   /* The number of leading 1-bits in the first byte indicates how many
261      bytes follow.  */
262   for (nb = 2; nb < 7; nb++)
263     if ((c & ~masks[nb-1]) == patns[nb-1])
264       goto found;
265   goto invalid;
266         
267  found:
268   c = (c & masks[nb-1]);
269   nread = nb - 1;
270
271   s = read_block_form (dtp, &nread);
272   if (s == NULL)
273     return 0;
274   /* Decode the bytes read.  */
275   for (i = 1; i < nb; i++)
276     {
277       gfc_char4_t n = *s++;
278
279       if ((n & 0xC0) != 0x80)
280         goto invalid;
281
282       c = ((c << 6) + (n & 0x3F));
283     }
284
285   /* Make sure the shortest possible encoding was used.  */
286   if (c <=      0x7F && nb > 1) goto invalid;
287   if (c <=     0x7FF && nb > 2) goto invalid;
288   if (c <=    0xFFFF && nb > 3) goto invalid;
289   if (c <=  0x1FFFFF && nb > 4) goto invalid;
290   if (c <= 0x3FFFFFF && nb > 5) goto invalid;
291
292   /* Make sure the character is valid.  */
293   if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
294     goto invalid;
295
296   return c;
297       
298  invalid:
299   generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
300   return (gfc_char4_t) '?';
301 }
302
303
304 static void
305 read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
306 {
307   gfc_char4_t c;
308   char *dest;
309   int nbytes;
310   int i, j;
311
312   len = (width < len) ? len : width;
313
314   dest = (char *) p;
315
316   /* Proceed with decoding one character at a time.  */
317   for (j = 0; j < len; j++, dest++)
318     {
319       c = read_utf8 (dtp, &nbytes);
320
321       /* Check for a short read and if so, break out.  */
322       if (nbytes == 0)
323         break;
324
325       *dest = c > 255 ? '?' : (uchar) c;
326     }
327
328   /* If there was a short read, pad the remaining characters.  */
329   for (i = j; i < len; i++)
330     *dest++ = ' ';
331   return;
332 }
333
334 static void
335 read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
336 {
337   char *s;
338   int m, n;
339
340   s = read_block_form (dtp, &width);
341   
342   if (s == NULL)
343     return;
344   if (width > len)
345      s += (width - len);
346
347   m = (width > len) ? len : width;
348   memcpy (p, s, m);
349
350   n = len - width;
351   if (n > 0)
352     memset (p + m, ' ', n);
353 }
354
355
356 static void
357 read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
358 {
359   gfc_char4_t *dest;
360   int nbytes;
361   int i, j;
362
363   len = (width < len) ? len : width;
364
365   dest = (gfc_char4_t *) p;
366
367   /* Proceed with decoding one character at a time.  */
368   for (j = 0; j < len; j++, dest++)
369     {
370       *dest = read_utf8 (dtp, &nbytes);
371
372       /* Check for a short read and if so, break out.  */
373       if (nbytes == 0)
374         break;
375     }
376
377   /* If there was a short read, pad the remaining characters.  */
378   for (i = j; i < len; i++)
379     *dest++ = (gfc_char4_t) ' ';
380   return;
381 }
382
383
384 static void
385 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
386 {
387   char *s;
388   gfc_char4_t *dest;
389   int m, n;
390
391   s = read_block_form (dtp, &width);
392   
393   if (s == NULL)
394     return;
395   if (width > len)
396      s += (width - len);
397
398   m = ((int) width > len) ? len : (int) width;
399   
400   dest = (gfc_char4_t *) p;
401   
402   for (n = 0; n < m; n++, dest++, s++)
403     *dest = (unsigned char ) *s;
404
405   for (n = 0; n < len - (int) width; n++, dest++)
406     *dest = (unsigned char) ' ';
407 }
408
409
410 /* read_a()-- Read a character record into a KIND=1 character destination,
411    processing UTF-8 encoding if necessary.  */
412
413 void
414 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
415 {
416   int wi;
417   int w;
418
419   wi = f->u.w;
420   if (wi == -1) /* '(A)' edit descriptor  */
421     wi = length;
422   w = wi;
423
424   /* Read in w characters, treating comma as not a separator.  */
425   dtp->u.p.sf_read_comma = 0;
426
427   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
428     read_utf8_char1 (dtp, p, length, w);
429   else
430     read_default_char1 (dtp, p, length, w);
431
432   dtp->u.p.sf_read_comma =
433     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
434 }
435
436
437 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
438    processing UTF-8 encoding if necessary.  */
439
440 void
441 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
442 {
443   int w;
444
445   w = f->u.w;
446   if (w == -1) /* '(A)' edit descriptor  */
447     w = length;
448
449   /* Read in w characters, treating comma as not a separator.  */
450   dtp->u.p.sf_read_comma = 0;
451
452   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
453     read_utf8_char4 (dtp, p, length, w);
454   else
455     read_default_char4 (dtp, p, length, w);
456   
457   dtp->u.p.sf_read_comma =
458     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
459 }
460
461 /* eat_leading_spaces()-- Given a character pointer and a width,
462  * ignore the leading spaces.  */
463
464 static char *
465 eat_leading_spaces (int *width, char *p)
466 {
467   for (;;)
468     {
469       if (*width == 0 || *p != ' ')
470         break;
471
472       (*width)--;
473       p++;
474     }
475
476   return p;
477 }
478
479
480 static char
481 next_char (st_parameter_dt *dtp, char **p, int *w)
482 {
483   char c, *q;
484
485   if (*w == 0)
486     return '\0';
487
488   q = *p;
489   c = *q++;
490   *p = q;
491
492   (*w)--;
493
494   if (c != ' ')
495     return c;
496   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
497     return ' ';  /* return a blank to signal a null */ 
498
499   /* At this point, the rest of the field has to be trailing blanks */
500
501   while (*w > 0)
502     {
503       if (*q++ != ' ')
504         return '?';
505       (*w)--;
506     }
507
508   *p = q;
509   return '\0';
510 }
511
512
513 /* read_decimal()-- Read a decimal integer value.  The values here are
514  * signed values. */
515
516 void
517 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
518 {
519   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
520   GFC_INTEGER_LARGEST v;
521   int w, negative; 
522   char c, *p;
523
524   w = f->u.w;
525
526   p = read_block_form (dtp, &w);
527
528   if (p == NULL)
529     return;
530
531   p = eat_leading_spaces (&w, p);
532   if (w == 0)
533     {
534       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
535       return;
536     }
537
538   maxv = max_value (length, 1);
539   maxv_10 = maxv / 10;
540
541   negative = 0;
542   value = 0;
543
544   switch (*p)
545     {
546     case '-':
547       negative = 1;
548       /* Fall through */
549
550     case '+':
551       p++;
552       if (--w == 0)
553         goto bad;
554       /* Fall through */
555
556     default:
557       break;
558     }
559
560   /* At this point we have a digit-string */
561   value = 0;
562
563   for (;;)
564     {
565       c = next_char (dtp, &p, &w);
566       if (c == '\0')
567         break;
568         
569       if (c == ' ')
570         {
571           if (dtp->u.p.blank_status == BLANK_NULL) continue;
572           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
573         }
574         
575       if (c < '0' || c > '9')
576         goto bad;
577
578       if (value > maxv_10 && compile_options.range_check == 1)
579         goto overflow;
580
581       c -= '0';
582       value = 10 * value;
583
584       if (value > maxv - c && compile_options.range_check == 1)
585         goto overflow;
586       value += c;
587     }
588
589   v = value;
590   if (negative)
591     v = -v;
592
593   set_integer (dest, v, length);
594   return;
595
596  bad:
597   generate_error (&dtp->common, LIBERROR_READ_VALUE,
598                   "Bad value during integer read");
599   next_record (dtp, 1);
600   return;
601
602  overflow:
603   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
604                   "Value overflowed during integer read");
605   next_record (dtp, 1);
606
607 }
608
609
610 /* read_radix()-- This function reads values for non-decimal radixes.
611  * The difference here is that we treat the values here as unsigned
612  * values for the purposes of overflow.  If minus sign is present and
613  * the top bit is set, the value will be incorrect. */
614
615 void
616 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
617             int radix)
618 {
619   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
620   GFC_INTEGER_LARGEST v;
621   int w, negative;
622   char c, *p;
623
624   w = f->u.w;
625
626   p = read_block_form (dtp, &w);
627
628   if (p == NULL)
629     return;
630
631   p = eat_leading_spaces (&w, p);
632   if (w == 0)
633     {
634       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
635       return;
636     }
637
638   maxv = max_value (length, 0);
639   maxv_r = maxv / radix;
640
641   negative = 0;
642   value = 0;
643
644   switch (*p)
645     {
646     case '-':
647       negative = 1;
648       /* Fall through */
649
650     case '+':
651       p++;
652       if (--w == 0)
653         goto bad;
654       /* Fall through */
655
656     default:
657       break;
658     }
659
660   /* At this point we have a digit-string */
661   value = 0;
662
663   for (;;)
664     {
665       c = next_char (dtp, &p, &w);
666       if (c == '\0')
667         break;
668       if (c == ' ')
669         {
670           if (dtp->u.p.blank_status == BLANK_NULL) continue;
671           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
672         }
673
674       switch (radix)
675         {
676         case 2:
677           if (c < '0' || c > '1')
678             goto bad;
679           break;
680
681         case 8:
682           if (c < '0' || c > '7')
683             goto bad;
684           break;
685
686         case 16:
687           switch (c)
688             {
689             case '0':
690             case '1':
691             case '2':
692             case '3':
693             case '4':
694             case '5':
695             case '6':
696             case '7':
697             case '8':
698             case '9':
699               break;
700
701             case 'a':
702             case 'b':
703             case 'c':
704             case 'd':
705             case 'e':
706             case 'f':
707               c = c - 'a' + '9' + 1;
708               break;
709
710             case 'A':
711             case 'B':
712             case 'C':
713             case 'D':
714             case 'E':
715             case 'F':
716               c = c - 'A' + '9' + 1;
717               break;
718
719             default:
720               goto bad;
721             }
722
723           break;
724         }
725
726       if (value > maxv_r)
727         goto overflow;
728
729       c -= '0';
730       value = radix * value;
731
732       if (maxv - c < value)
733         goto overflow;
734       value += c;
735     }
736
737   v = value;
738   if (negative)
739     v = -v;
740
741   set_integer (dest, v, length);
742   return;
743
744  bad:
745   generate_error (&dtp->common, LIBERROR_READ_VALUE,
746                   "Bad value during integer read");
747   next_record (dtp, 1);
748   return;
749
750  overflow:
751   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
752                   "Value overflowed during integer read");
753   next_record (dtp, 1);
754
755 }
756
757
758 /* read_f()-- Read a floating point number with F-style editing, which
759    is what all of the other floating point descriptors behave as.  The
760    tricky part is that optional spaces are allowed after an E or D,
761    and the implicit decimal point if a decimal point is not present in
762    the input.  */
763
764 void
765 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
766 {
767   int w, seen_dp, exponent;
768   int exponent_sign;
769   const char *p;
770   char *buffer;
771   char *out;
772   int seen_int_digit; /* Seen a digit before the decimal point?  */
773   int seen_dec_digit; /* Seen a digit after the decimal point?  */
774
775   seen_dp = 0;
776   seen_int_digit = 0;
777   seen_dec_digit = 0;
778   exponent_sign = 1;
779   exponent = 0;
780   w = f->u.w;
781
782   /* Read in the next block.  */
783   p = read_block_form (dtp, &w);
784   if (p == NULL)
785     return;
786   p = eat_leading_spaces (&w, (char*) p);
787   if (w == 0)
788     goto zero;
789
790   /* In this buffer we're going to re-format the number cleanly to be parsed
791      by convert_real in the end; this assures we're using strtod from the
792      C library for parsing and thus probably get the best accuracy possible.
793      This process may add a '+0.0' in front of the number as well as change the
794      exponent because of an implicit decimal point or the like.  Thus allocating
795      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
796      original buffer had should be enough.  */
797   buffer = gfc_alloca (w + 11);
798   out = buffer;
799
800   /* Optional sign */
801   if (*p == '-' || *p == '+')
802     {
803       if (*p == '-')
804         *(out++) = '-';
805       ++p;
806       --w;
807     }
808
809   p = eat_leading_spaces (&w, (char*) p);
810   if (w == 0)
811     goto zero;
812
813   /* Process the mantissa string.  */
814   while (w > 0)
815     {
816       switch (*p)
817         {
818         case ',':
819           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
820             goto bad_float;
821           /* Fall through.  */
822         case '.':
823           if (seen_dp)
824             goto bad_float;
825           if (!seen_int_digit)
826             *(out++) = '0';
827           *(out++) = '.';
828           seen_dp = 1;
829           break;
830
831         case ' ':
832           if (dtp->u.p.blank_status == BLANK_ZERO)
833             {
834               *(out++) = '0';
835               goto found_digit;
836             }
837           else if (dtp->u.p.blank_status == BLANK_NULL)
838             break;
839           else
840             /* TODO: Should we check instead that there are only trailing
841                blanks here, as is done below for exponents?  */
842             goto done;
843           /* Fall through.  */
844         case '0':
845         case '1':
846         case '2':
847         case '3':
848         case '4':
849         case '5':
850         case '6':
851         case '7':
852         case '8':
853         case '9':
854           *(out++) = *p;
855 found_digit:
856           if (!seen_dp)
857             seen_int_digit = 1;
858           else
859             seen_dec_digit = 1;
860           break;
861
862         case '-':
863         case '+':
864           goto exponent;
865
866         case 'e':
867         case 'E':
868         case 'd':
869         case 'D':
870           ++p;
871           --w;
872           goto exponent;
873
874         default:
875           goto bad_float;
876         }
877
878       ++p;
879       --w;
880     }
881   
882   /* No exponent has been seen, so we use the current scale factor.  */
883   exponent = - dtp->u.p.scale_factor;
884   goto done;
885
886   /* At this point the start of an exponent has been found.  */
887 exponent:
888   p = eat_leading_spaces (&w, (char*) p);
889   if (*p == '-' || *p == '+')
890     {
891       if (*p == '-')
892         exponent_sign = -1;
893       ++p;
894       --w;
895     }
896
897   /* At this point a digit string is required.  We calculate the value
898      of the exponent in order to take account of the scale factor and
899      the d parameter before explict conversion takes place.  */
900
901   if (w == 0)
902     goto bad_float;
903
904   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
905     {
906       while (w > 0 && isdigit (*p))
907         {
908           exponent *= 10;
909           exponent += *p - '0';
910           ++p;
911           --w;
912         }
913         
914       /* Only allow trailing blanks.  */
915       while (w > 0)
916         {
917           if (*p != ' ')
918             goto bad_float;
919           ++p;
920           --w;
921         }
922     }    
923   else  /* BZ or BN status is enabled.  */
924     {
925       while (w > 0)
926         {
927           if (*p == ' ')
928             {
929               if (dtp->u.p.blank_status == BLANK_ZERO)
930                 exponent *= 10;
931               else
932                 assert (dtp->u.p.blank_status == BLANK_NULL);
933             }
934           else if (!isdigit (*p))
935             goto bad_float;
936           else
937             {
938               exponent *= 10;
939               exponent += *p - '0';
940             }
941
942           ++p;
943           --w;
944         }
945     }
946
947   exponent *= exponent_sign;
948
949 done:
950   /* Use the precision specified in the format if no decimal point has been
951      seen.  */
952   if (!seen_dp)
953     exponent -= f->u.real.d;
954
955   /* Output a trailing '0' after decimal point if not yet found.  */
956   if (seen_dp && !seen_dec_digit)
957     *(out++) = '0';
958
959   /* Print out the exponent to finish the reformatted number.  Maximum 4
960      digits for the exponent.  */
961   if (exponent != 0)
962     {
963       int dig;
964
965       *(out++) = 'e';
966       if (exponent < 0)
967         {
968           *(out++) = '-';
969           exponent = - exponent;
970         }
971
972       assert (exponent < 10000);
973       for (dig = 3; dig >= 0; --dig)
974         {
975           out[dig] = (char) ('0' + exponent % 10);
976           exponent /= 10;
977         }
978       out += 4;
979     }
980   *(out++) = '\0';
981
982   /* Do the actual conversion.  */
983   convert_real (dtp, dest, buffer, length);
984
985   return;
986
987   /* The value read is zero.  */
988 zero:
989   switch (length)
990     {
991       case 4:
992         *((GFC_REAL_4 *) dest) = 0.0;
993         break;
994
995       case 8:
996         *((GFC_REAL_8 *) dest) = 0.0;
997         break;
998
999 #ifdef HAVE_GFC_REAL_10
1000       case 10:
1001         *((GFC_REAL_10 *) dest) = 0.0;
1002         break;
1003 #endif
1004
1005 #ifdef HAVE_GFC_REAL_16
1006       case 16:
1007         *((GFC_REAL_16 *) dest) = 0.0;
1008         break;
1009 #endif
1010
1011       default:
1012         internal_error (&dtp->common, "Unsupported real kind during IO");
1013     }
1014   return;
1015
1016 bad_float:
1017   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1018                   "Bad value during floating point read");
1019   next_record (dtp, 1);
1020   return;
1021 }
1022
1023
1024 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1025  * and never look at it. */
1026
1027 void
1028 read_x (st_parameter_dt *dtp, int n)
1029 {
1030   int length;
1031   char *p, q;
1032
1033   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1034        && dtp->u.p.current_unit->bytes_left < n)
1035     n = dtp->u.p.current_unit->bytes_left;
1036     
1037   if (n == 0)
1038     return;
1039
1040   length = n;
1041
1042   if (is_internal_unit (dtp))
1043     {
1044       p = mem_alloc_r (dtp->u.p.current_unit->s, &length);
1045       if (unlikely (length < n))
1046         n = length;
1047       goto done;
1048     }
1049
1050   if (dtp->u.p.sf_seen_eor)
1051     return;
1052
1053   p = fbuf_read (dtp->u.p.current_unit, &length);
1054   if (p == NULL)
1055     {
1056       hit_eof (dtp);
1057       return;
1058     }
1059   
1060   if (length == 0 && dtp->u.p.item_count == 1)
1061     {
1062       if (dtp->u.p.current_unit->pad_status == PAD_NO)
1063         {
1064           hit_eof (dtp);
1065           return;
1066         }
1067       else
1068         return;
1069     }
1070
1071   n = 0;
1072   while (n < length)
1073     {
1074       q = *p;
1075       if (q == '\n' || q == '\r')
1076         {
1077           /* Unexpected end of line. Set the position.  */
1078           fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
1079           dtp->u.p.sf_seen_eor = 1;
1080
1081           /* If we encounter a CR, it might be a CRLF.  */
1082           if (q == '\r') /* Probably a CRLF */
1083             {
1084               /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
1085                  the position is not advanced unless it really is an LF.  */
1086               int readlen = 1;
1087               p = fbuf_read (dtp->u.p.current_unit, &readlen);
1088               if (*p == '\n' && readlen == 1)
1089                 {
1090                   dtp->u.p.sf_seen_eor = 2;
1091                   fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
1092                 }
1093             }
1094           goto done;
1095         }
1096       n++;
1097       p++;
1098     } 
1099
1100   fbuf_seek (dtp->u.p.current_unit, n, SEEK_CUR);
1101   
1102  done:
1103   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1104     dtp->u.p.size_used += (GFC_IO_INT) n;
1105   dtp->u.p.current_unit->bytes_left -= n;
1106   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1107 }
1108