OSDN Git Service

873d26c4d83172abc9ae959ff57e3563f5828b17
[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   /* Check for Infinity or NaN.  */    
814   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
815     {
816       int seen_paren = 0;
817       char *save = out;
818
819       /* Scan through the buffer keeping track of spaces and parenthesis. We
820          null terminate the string as soon as we see a left paren or if we are
821          BLANK_NULL mode.  Leading spaces have already been skipped above,
822          trailing spaces are ignored by converting to '\0'. A space
823          between "NaN" and the optional perenthesis is not permitted.  */
824       while (w > 0)
825         {
826           *out = tolower (*p);
827           switch (*p)
828             {
829             case ' ':
830               if (dtp->u.p.blank_status == BLANK_ZERO)
831                 {
832                   *out = '0';
833                   break;
834                 }
835               *out = '\0';
836               if (seen_paren == 1)
837                 goto bad_float;
838               break;
839             case '(':
840               seen_paren++;
841               *out = '\0';
842               break;
843             case ')':
844               if (seen_paren++ != 1)
845                 goto bad_float;
846               break;
847             default:
848               if (!isalnum (*out))
849                 goto bad_float;
850             }
851           --w;
852           ++p;
853           ++out;
854         }
855          
856       *out = '\0';
857       
858       if (seen_paren != 0 && seen_paren != 2)
859         goto bad_float;
860
861       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
862         {
863            if (seen_paren)
864              goto bad_float;
865         }
866       else if (strcmp (save, "nan") != 0)
867         goto bad_float;
868
869       convert_real (dtp, dest, buffer, length);
870       return;
871     }
872
873   /* Process the mantissa string.  */
874   while (w > 0)
875     {
876       switch (*p)
877         {
878         case ',':
879           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
880             goto bad_float;
881           /* Fall through.  */
882         case '.':
883           if (seen_dp)
884             goto bad_float;
885           if (!seen_int_digit)
886             *(out++) = '0';
887           *(out++) = '.';
888           seen_dp = 1;
889           break;
890
891         case ' ':
892           if (dtp->u.p.blank_status == BLANK_ZERO)
893             {
894               *(out++) = '0';
895               goto found_digit;
896             }
897           else if (dtp->u.p.blank_status == BLANK_NULL)
898             break;
899           else
900             /* TODO: Should we check instead that there are only trailing
901                blanks here, as is done below for exponents?  */
902             goto done;
903           /* Fall through.  */
904         case '0':
905         case '1':
906         case '2':
907         case '3':
908         case '4':
909         case '5':
910         case '6':
911         case '7':
912         case '8':
913         case '9':
914           *(out++) = *p;
915 found_digit:
916           if (!seen_dp)
917             seen_int_digit = 1;
918           else
919             seen_dec_digit = 1;
920           break;
921
922         case '-':
923         case '+':
924           goto exponent;
925
926         case 'e':
927         case 'E':
928         case 'd':
929         case 'D':
930           ++p;
931           --w;
932           goto exponent;
933
934         default:
935           goto bad_float;
936         }
937
938       ++p;
939       --w;
940     }
941   
942   /* No exponent has been seen, so we use the current scale factor.  */
943   exponent = - dtp->u.p.scale_factor;
944   goto done;
945
946   /* At this point the start of an exponent has been found.  */
947 exponent:
948   p = eat_leading_spaces (&w, (char*) p);
949   if (*p == '-' || *p == '+')
950     {
951       if (*p == '-')
952         exponent_sign = -1;
953       ++p;
954       --w;
955     }
956
957   /* At this point a digit string is required.  We calculate the value
958      of the exponent in order to take account of the scale factor and
959      the d parameter before explict conversion takes place.  */
960
961   if (w == 0)
962     goto bad_float;
963
964   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
965     {
966       while (w > 0 && isdigit (*p))
967         {
968           exponent *= 10;
969           exponent += *p - '0';
970           ++p;
971           --w;
972         }
973         
974       /* Only allow trailing blanks.  */
975       while (w > 0)
976         {
977           if (*p != ' ')
978             goto bad_float;
979           ++p;
980           --w;
981         }
982     }    
983   else  /* BZ or BN status is enabled.  */
984     {
985       while (w > 0)
986         {
987           if (*p == ' ')
988             {
989               if (dtp->u.p.blank_status == BLANK_ZERO)
990                 exponent *= 10;
991               else
992                 assert (dtp->u.p.blank_status == BLANK_NULL);
993             }
994           else if (!isdigit (*p))
995             goto bad_float;
996           else
997             {
998               exponent *= 10;
999               exponent += *p - '0';
1000             }
1001
1002           ++p;
1003           --w;
1004         }
1005     }
1006
1007   exponent *= exponent_sign;
1008
1009 done:
1010   /* Use the precision specified in the format if no decimal point has been
1011      seen.  */
1012   if (!seen_dp)
1013     exponent -= f->u.real.d;
1014
1015   /* Output a trailing '0' after decimal point if not yet found.  */
1016   if (seen_dp && !seen_dec_digit)
1017     *(out++) = '0';
1018
1019   /* Print out the exponent to finish the reformatted number.  Maximum 4
1020      digits for the exponent.  */
1021   if (exponent != 0)
1022     {
1023       int dig;
1024
1025       *(out++) = 'e';
1026       if (exponent < 0)
1027         {
1028           *(out++) = '-';
1029           exponent = - exponent;
1030         }
1031
1032       assert (exponent < 10000);
1033       for (dig = 3; dig >= 0; --dig)
1034         {
1035           out[dig] = (char) ('0' + exponent % 10);
1036           exponent /= 10;
1037         }
1038       out += 4;
1039     }
1040   *(out++) = '\0';
1041
1042   /* Do the actual conversion.  */
1043   convert_real (dtp, dest, buffer, length);
1044
1045   return;
1046
1047   /* The value read is zero.  */
1048 zero:
1049   switch (length)
1050     {
1051       case 4:
1052         *((GFC_REAL_4 *) dest) = 0.0;
1053         break;
1054
1055       case 8:
1056         *((GFC_REAL_8 *) dest) = 0.0;
1057         break;
1058
1059 #ifdef HAVE_GFC_REAL_10
1060       case 10:
1061         *((GFC_REAL_10 *) dest) = 0.0;
1062         break;
1063 #endif
1064
1065 #ifdef HAVE_GFC_REAL_16
1066       case 16:
1067         *((GFC_REAL_16 *) dest) = 0.0;
1068         break;
1069 #endif
1070
1071       default:
1072         internal_error (&dtp->common, "Unsupported real kind during IO");
1073     }
1074   return;
1075
1076 bad_float:
1077   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1078                   "Bad value during floating point read");
1079   next_record (dtp, 1);
1080   return;
1081 }
1082
1083
1084 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1085  * and never look at it. */
1086
1087 void
1088 read_x (st_parameter_dt *dtp, int n)
1089 {
1090   int length;
1091   char *p, q;
1092
1093   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1094        && dtp->u.p.current_unit->bytes_left < n)
1095     n = dtp->u.p.current_unit->bytes_left;
1096     
1097   if (n == 0)
1098     return;
1099
1100   length = n;
1101
1102   if (is_internal_unit (dtp))
1103     {
1104       p = mem_alloc_r (dtp->u.p.current_unit->s, &length);
1105       if (unlikely (length < n))
1106         n = length;
1107       goto done;
1108     }
1109
1110   if (dtp->u.p.sf_seen_eor)
1111     return;
1112
1113   p = fbuf_read (dtp->u.p.current_unit, &length);
1114   if (p == NULL)
1115     {
1116       hit_eof (dtp);
1117       return;
1118     }
1119   
1120   if (length == 0 && dtp->u.p.item_count == 1)
1121     {
1122       if (dtp->u.p.current_unit->pad_status == PAD_NO)
1123         {
1124           hit_eof (dtp);
1125           return;
1126         }
1127       else
1128         return;
1129     }
1130
1131   n = 0;
1132   while (n < length)
1133     {
1134       q = *p;
1135       if (q == '\n' || q == '\r')
1136         {
1137           /* Unexpected end of line. Set the position.  */
1138           fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
1139           dtp->u.p.sf_seen_eor = 1;
1140
1141           /* If we encounter a CR, it might be a CRLF.  */
1142           if (q == '\r') /* Probably a CRLF */
1143             {
1144               /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
1145                  the position is not advanced unless it really is an LF.  */
1146               int readlen = 1;
1147               p = fbuf_read (dtp->u.p.current_unit, &readlen);
1148               if (*p == '\n' && readlen == 1)
1149                 {
1150                   dtp->u.p.sf_seen_eor = 2;
1151                   fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
1152                 }
1153             }
1154           goto done;
1155         }
1156       n++;
1157       p++;
1158     } 
1159
1160   fbuf_seek (dtp->u.p.current_unit, n, SEEK_CUR);
1161   
1162  done:
1163   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1164     dtp->u.p.size_used += (GFC_IO_INT) n;
1165   dtp->u.p.current_unit->bytes_left -= n;
1166   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1167 }
1168