OSDN Git Service

aa41bc7b9d288d4884acc14a69f0f0492e28b4d0
[pf3gnuchains/gcc-fork.git] / libgfortran / io / read.c
1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010, 2011
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 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 an
135    invalid input.  Note: many architectures (e.g. IA-64, HP-PA)
136    require that the storage pointed to by the dest argument is
137    properly aligned for the type in question.  */
138
139 int
140 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
141 {
142   char *endptr = NULL;
143
144   switch (length)
145     {
146     case 4:
147       *((GFC_REAL_4*) dest) =
148 #if defined(HAVE_STRTOF)
149         gfc_strtof (buffer, &endptr);
150 #else
151         (GFC_REAL_4) gfc_strtod (buffer, &endptr);
152 #endif
153       break;
154
155     case 8:
156       *((GFC_REAL_8*) dest) = gfc_strtod (buffer, &endptr);
157       break;
158
159 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
160     case 10:
161       *((GFC_REAL_10*) dest) = gfc_strtold (buffer, &endptr);
162       break;
163 #endif
164
165 #if defined(HAVE_GFC_REAL_16)
166 # if defined(GFC_REAL_16_IS_FLOAT128)
167     case 16:
168       *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, &endptr);
169       break;
170 # elif defined(HAVE_STRTOLD)
171     case 16:
172       *((GFC_REAL_16*) dest) = gfc_strtold (buffer, &endptr);
173       break;
174 # endif
175 #endif
176
177     default:
178       internal_error (&dtp->common, "Unsupported real kind during IO");
179     }
180
181   if (buffer == endptr)
182     {
183       generate_error (&dtp->common, LIBERROR_READ_VALUE,
184                       "Error during floating point read");
185       next_record (dtp, 1);
186       return 1;
187     }
188
189   return 0;
190 }
191
192 /* convert_infnan()-- Convert character INF/NAN representation to the
193    machine number.  Note: many architectures (e.g. IA-64, HP-PA) require
194    that the storage pointed to by the dest argument is properly aligned
195    for the type in question.  */
196
197 int
198 convert_infnan (st_parameter_dt *dtp, void *dest, const char *buffer,
199                 int length)
200 {
201   const char *s = buffer;
202   int is_inf, plus = 1;
203
204   if (*s == '+')
205     s++;
206   else if (*s == '-')
207     {
208       s++;
209       plus = 0;
210     }
211
212   is_inf = *s == 'i';
213
214   switch (length)
215     {
216     case 4:
217       if (is_inf)
218         *((GFC_REAL_4*) dest) = plus ? __builtin_inff () : -__builtin_inff ();
219       else
220         *((GFC_REAL_4*) dest) = plus ? __builtin_nanf ("") : -__builtin_nanf ("");
221       break;
222
223     case 8:
224       if (is_inf)
225         *((GFC_REAL_8*) dest) = plus ? __builtin_inf () : -__builtin_inf ();
226       else
227         *((GFC_REAL_8*) dest) = plus ? __builtin_nan ("") : -__builtin_nan ("");
228       break;
229
230 #if defined(HAVE_GFC_REAL_10)
231     case 10:
232       if (is_inf)
233         *((GFC_REAL_10*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
234       else
235         *((GFC_REAL_10*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
236       break;
237 #endif
238
239 #if defined(HAVE_GFC_REAL_16)
240 # if defined(GFC_REAL_16_IS_FLOAT128)
241     case 16:
242       *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, NULL);
243       break;
244 # else
245     case 16:
246       if (is_inf)
247         *((GFC_REAL_16*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
248       else
249         *((GFC_REAL_16*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
250       break;
251 # endif
252 #endif
253
254     default:
255       internal_error (&dtp->common, "Unsupported real kind during IO");
256     }
257
258   return 0;
259 }
260
261
262 /* read_l()-- Read a logical value */
263
264 void
265 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
266 {
267   char *p;
268   int w;
269
270   w = f->u.w;
271
272   p = read_block_form (dtp, &w);
273
274   if (p == NULL)
275     return;
276
277   while (*p == ' ')
278     {
279       if (--w == 0)
280         goto bad;
281       p++;
282     }
283
284   if (*p == '.')
285     {
286       if (--w == 0)
287         goto bad;
288       p++;
289     }
290
291   switch (*p)
292     {
293     case 't':
294     case 'T':
295       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
296       break;
297     case 'f':
298     case 'F':
299       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
300       break;
301     default:
302     bad:
303       generate_error (&dtp->common, LIBERROR_READ_VALUE,
304                       "Bad value on logical read");
305       next_record (dtp, 1);
306       break;
307     }
308 }
309
310
311 static gfc_char4_t
312 read_utf8 (st_parameter_dt *dtp, int *nbytes) 
313 {
314   static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
315   static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
316   int i, nb, nread;
317   gfc_char4_t c;
318   char *s;
319
320   *nbytes = 1;
321
322   s = read_block_form (dtp, nbytes);
323   if (s == NULL)
324     return 0;
325
326   /* If this is a short read, just return.  */
327   if (*nbytes == 0)
328     return 0;
329
330   c = (uchar) s[0];
331   if (c < 0x80)
332     return c;
333
334   /* The number of leading 1-bits in the first byte indicates how many
335      bytes follow.  */
336   for (nb = 2; nb < 7; nb++)
337     if ((c & ~masks[nb-1]) == patns[nb-1])
338       goto found;
339   goto invalid;
340         
341  found:
342   c = (c & masks[nb-1]);
343   nread = nb - 1;
344
345   s = read_block_form (dtp, &nread);
346   if (s == NULL)
347     return 0;
348   /* Decode the bytes read.  */
349   for (i = 1; i < nb; i++)
350     {
351       gfc_char4_t n = *s++;
352
353       if ((n & 0xC0) != 0x80)
354         goto invalid;
355
356       c = ((c << 6) + (n & 0x3F));
357     }
358
359   /* Make sure the shortest possible encoding was used.  */
360   if (c <=      0x7F && nb > 1) goto invalid;
361   if (c <=     0x7FF && nb > 2) goto invalid;
362   if (c <=    0xFFFF && nb > 3) goto invalid;
363   if (c <=  0x1FFFFF && nb > 4) goto invalid;
364   if (c <= 0x3FFFFFF && nb > 5) goto invalid;
365
366   /* Make sure the character is valid.  */
367   if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
368     goto invalid;
369
370   return c;
371       
372  invalid:
373   generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
374   return (gfc_char4_t) '?';
375 }
376
377
378 static void
379 read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
380 {
381   gfc_char4_t c;
382   char *dest;
383   int nbytes;
384   int i, j;
385
386   len = (width < len) ? len : width;
387
388   dest = (char *) p;
389
390   /* Proceed with decoding one character at a time.  */
391   for (j = 0; j < len; j++, dest++)
392     {
393       c = read_utf8 (dtp, &nbytes);
394
395       /* Check for a short read and if so, break out.  */
396       if (nbytes == 0)
397         break;
398
399       *dest = c > 255 ? '?' : (uchar) c;
400     }
401
402   /* If there was a short read, pad the remaining characters.  */
403   for (i = j; i < len; i++)
404     *dest++ = ' ';
405   return;
406 }
407
408 static void
409 read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
410 {
411   char *s;
412   int m, n;
413
414   s = read_block_form (dtp, &width);
415   
416   if (s == NULL)
417     return;
418   if (width > len)
419      s += (width - len);
420
421   m = (width > len) ? len : width;
422   memcpy (p, s, m);
423
424   n = len - width;
425   if (n > 0)
426     memset (p + m, ' ', n);
427 }
428
429
430 static void
431 read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
432 {
433   gfc_char4_t *dest;
434   int nbytes;
435   int i, j;
436
437   len = (width < len) ? len : width;
438
439   dest = (gfc_char4_t *) p;
440
441   /* Proceed with decoding one character at a time.  */
442   for (j = 0; j < len; j++, dest++)
443     {
444       *dest = read_utf8 (dtp, &nbytes);
445
446       /* Check for a short read and if so, break out.  */
447       if (nbytes == 0)
448         break;
449     }
450
451   /* If there was a short read, pad the remaining characters.  */
452   for (i = j; i < len; i++)
453     *dest++ = (gfc_char4_t) ' ';
454   return;
455 }
456
457
458 static void
459 read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
460 {
461   int m, n;
462   gfc_char4_t *dest;
463
464   if (is_char4_unit(dtp))
465     {
466       gfc_char4_t *s4;
467
468       s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
469
470       if (s4 == NULL)
471         return;
472       if (width > len)
473          s4 += (width - len);
474
475       m = ((int) width > len) ? len : (int) width;
476
477       dest = (gfc_char4_t *) p;
478
479       for (n = 0; n < m; n++)
480         *dest++ = *s4++;
481
482       for (n = 0; n < len - (int) width; n++)
483         *dest++ = (gfc_char4_t) ' ';
484     }
485   else
486     {
487       char *s;
488
489       s = read_block_form (dtp, &width);
490
491       if (s == NULL)
492         return;
493       if (width > len)
494          s += (width - len);
495
496       m = ((int) width > len) ? len : (int) width;
497
498       dest = (gfc_char4_t *) p;
499
500       for (n = 0; n < m; n++, dest++, s++)
501         *dest = (unsigned char ) *s;
502
503       for (n = 0; n < len - (int) width; n++, dest++)
504         *dest = (unsigned char) ' ';
505     }
506 }
507
508
509 /* read_a()-- Read a character record into a KIND=1 character destination,
510    processing UTF-8 encoding if necessary.  */
511
512 void
513 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
514 {
515   int wi;
516   int w;
517
518   wi = f->u.w;
519   if (wi == -1) /* '(A)' edit descriptor  */
520     wi = length;
521   w = wi;
522
523   /* Read in w characters, treating comma as not a separator.  */
524   dtp->u.p.sf_read_comma = 0;
525
526   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
527     read_utf8_char1 (dtp, p, length, w);
528   else
529     read_default_char1 (dtp, p, length, w);
530
531   dtp->u.p.sf_read_comma =
532     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
533 }
534
535
536 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
537    processing UTF-8 encoding if necessary.  */
538
539 void
540 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
541 {
542   int w;
543
544   w = f->u.w;
545   if (w == -1) /* '(A)' edit descriptor  */
546     w = length;
547
548   /* Read in w characters, treating comma as not a separator.  */
549   dtp->u.p.sf_read_comma = 0;
550
551   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
552     read_utf8_char4 (dtp, p, length, w);
553   else
554     read_default_char4 (dtp, p, length, w);
555   
556   dtp->u.p.sf_read_comma =
557     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
558 }
559
560 /* eat_leading_spaces()-- Given a character pointer and a width,
561  * ignore the leading spaces.  */
562
563 static char *
564 eat_leading_spaces (int *width, char *p)
565 {
566   for (;;)
567     {
568       if (*width == 0 || *p != ' ')
569         break;
570
571       (*width)--;
572       p++;
573     }
574
575   return p;
576 }
577
578
579 static char
580 next_char (st_parameter_dt *dtp, char **p, int *w)
581 {
582   char c, *q;
583
584   if (*w == 0)
585     return '\0';
586
587   q = *p;
588   c = *q++;
589   *p = q;
590
591   (*w)--;
592
593   if (c != ' ')
594     return c;
595   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
596     return ' ';  /* return a blank to signal a null */ 
597
598   /* At this point, the rest of the field has to be trailing blanks */
599
600   while (*w > 0)
601     {
602       if (*q++ != ' ')
603         return '?';
604       (*w)--;
605     }
606
607   *p = q;
608   return '\0';
609 }
610
611
612 /* read_decimal()-- Read a decimal integer value.  The values here are
613  * signed values. */
614
615 void
616 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
617 {
618   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
619   GFC_INTEGER_LARGEST v;
620   int w, negative; 
621   char c, *p;
622
623   w = f->u.w;
624
625   p = read_block_form (dtp, &w);
626
627   if (p == NULL)
628     return;
629
630   p = eat_leading_spaces (&w, p);
631   if (w == 0)
632     {
633       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
634       return;
635     }
636
637   maxv = max_value (length, 1);
638   maxv_10 = maxv / 10;
639
640   negative = 0;
641   value = 0;
642
643   switch (*p)
644     {
645     case '-':
646       negative = 1;
647       /* Fall through */
648
649     case '+':
650       p++;
651       if (--w == 0)
652         goto bad;
653       /* Fall through */
654
655     default:
656       break;
657     }
658
659   /* At this point we have a digit-string */
660   value = 0;
661
662   for (;;)
663     {
664       c = next_char (dtp, &p, &w);
665       if (c == '\0')
666         break;
667         
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       if (c < '0' || c > '9')
675         goto bad;
676
677       if (value > maxv_10 && compile_options.range_check == 1)
678         goto overflow;
679
680       c -= '0';
681       value = 10 * value;
682
683       if (value > maxv - c && compile_options.range_check == 1)
684         goto overflow;
685       value += c;
686     }
687
688   v = value;
689   if (negative)
690     v = -v;
691
692   set_integer (dest, v, length);
693   return;
694
695  bad:
696   generate_error (&dtp->common, LIBERROR_READ_VALUE,
697                   "Bad value during integer read");
698   next_record (dtp, 1);
699   return;
700
701  overflow:
702   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
703                   "Value overflowed during integer read");
704   next_record (dtp, 1);
705
706 }
707
708
709 /* read_radix()-- This function reads values for non-decimal radixes.
710  * The difference here is that we treat the values here as unsigned
711  * values for the purposes of overflow.  If minus sign is present and
712  * the top bit is set, the value will be incorrect. */
713
714 void
715 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
716             int radix)
717 {
718   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
719   GFC_INTEGER_LARGEST v;
720   int w, negative;
721   char c, *p;
722
723   w = f->u.w;
724
725   p = read_block_form (dtp, &w);
726
727   if (p == NULL)
728     return;
729
730   p = eat_leading_spaces (&w, p);
731   if (w == 0)
732     {
733       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
734       return;
735     }
736
737   maxv = max_value (length, 0);
738   maxv_r = maxv / radix;
739
740   negative = 0;
741   value = 0;
742
743   switch (*p)
744     {
745     case '-':
746       negative = 1;
747       /* Fall through */
748
749     case '+':
750       p++;
751       if (--w == 0)
752         goto bad;
753       /* Fall through */
754
755     default:
756       break;
757     }
758
759   /* At this point we have a digit-string */
760   value = 0;
761
762   for (;;)
763     {
764       c = next_char (dtp, &p, &w);
765       if (c == '\0')
766         break;
767       if (c == ' ')
768         {
769           if (dtp->u.p.blank_status == BLANK_NULL) continue;
770           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
771         }
772
773       switch (radix)
774         {
775         case 2:
776           if (c < '0' || c > '1')
777             goto bad;
778           break;
779
780         case 8:
781           if (c < '0' || c > '7')
782             goto bad;
783           break;
784
785         case 16:
786           switch (c)
787             {
788             case '0':
789             case '1':
790             case '2':
791             case '3':
792             case '4':
793             case '5':
794             case '6':
795             case '7':
796             case '8':
797             case '9':
798               break;
799
800             case 'a':
801             case 'b':
802             case 'c':
803             case 'd':
804             case 'e':
805             case 'f':
806               c = c - 'a' + '9' + 1;
807               break;
808
809             case 'A':
810             case 'B':
811             case 'C':
812             case 'D':
813             case 'E':
814             case 'F':
815               c = c - 'A' + '9' + 1;
816               break;
817
818             default:
819               goto bad;
820             }
821
822           break;
823         }
824
825       if (value > maxv_r)
826         goto overflow;
827
828       c -= '0';
829       value = radix * value;
830
831       if (maxv - c < value)
832         goto overflow;
833       value += c;
834     }
835
836   v = value;
837   if (negative)
838     v = -v;
839
840   set_integer (dest, v, length);
841   return;
842
843  bad:
844   generate_error (&dtp->common, LIBERROR_READ_VALUE,
845                   "Bad value during integer read");
846   next_record (dtp, 1);
847   return;
848
849  overflow:
850   generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
851                   "Value overflowed during integer read");
852   next_record (dtp, 1);
853
854 }
855
856
857 /* read_f()-- Read a floating point number with F-style editing, which
858    is what all of the other floating point descriptors behave as.  The
859    tricky part is that optional spaces are allowed after an E or D,
860    and the implicit decimal point if a decimal point is not present in
861    the input.  */
862
863 void
864 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
865 {
866   int w, seen_dp, exponent;
867   int exponent_sign;
868   const char *p;
869   char *buffer;
870   char *out;
871   int seen_int_digit; /* Seen a digit before the decimal point?  */
872   int seen_dec_digit; /* Seen a digit after the decimal point?  */
873
874   seen_dp = 0;
875   seen_int_digit = 0;
876   seen_dec_digit = 0;
877   exponent_sign = 1;
878   exponent = 0;
879   w = f->u.w;
880
881   /* Read in the next block.  */
882   p = read_block_form (dtp, &w);
883   if (p == NULL)
884     return;
885   p = eat_leading_spaces (&w, (char*) p);
886   if (w == 0)
887     goto zero;
888
889   /* In this buffer we're going to re-format the number cleanly to be parsed
890      by convert_real in the end; this assures we're using strtod from the
891      C library for parsing and thus probably get the best accuracy possible.
892      This process may add a '+0.0' in front of the number as well as change the
893      exponent because of an implicit decimal point or the like.  Thus allocating
894      strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
895      original buffer had should be enough.  */
896   buffer = gfc_alloca (w + 11);
897   out = buffer;
898
899   /* Optional sign */
900   if (*p == '-' || *p == '+')
901     {
902       if (*p == '-')
903         *(out++) = '-';
904       ++p;
905       --w;
906     }
907
908   p = eat_leading_spaces (&w, (char*) p);
909   if (w == 0)
910     goto zero;
911
912   /* Check for Infinity or NaN.  */    
913   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
914     {
915       int seen_paren = 0;
916       char *save = out;
917
918       /* Scan through the buffer keeping track of spaces and parenthesis. We
919          null terminate the string as soon as we see a left paren or if we are
920          BLANK_NULL mode.  Leading spaces have already been skipped above,
921          trailing spaces are ignored by converting to '\0'. A space
922          between "NaN" and the optional perenthesis is not permitted.  */
923       while (w > 0)
924         {
925           *out = tolower (*p);
926           switch (*p)
927             {
928             case ' ':
929               if (dtp->u.p.blank_status == BLANK_ZERO)
930                 {
931                   *out = '0';
932                   break;
933                 }
934               *out = '\0';
935               if (seen_paren == 1)
936                 goto bad_float;
937               break;
938             case '(':
939               seen_paren++;
940               *out = '\0';
941               break;
942             case ')':
943               if (seen_paren++ != 1)
944                 goto bad_float;
945               break;
946             default:
947               if (!isalnum (*out))
948                 goto bad_float;
949             }
950           --w;
951           ++p;
952           ++out;
953         }
954          
955       *out = '\0';
956       
957       if (seen_paren != 0 && seen_paren != 2)
958         goto bad_float;
959
960       if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
961         {
962            if (seen_paren)
963              goto bad_float;
964         }
965       else if (strcmp (save, "nan") != 0)
966         goto bad_float;
967
968       convert_infnan (dtp, dest, buffer, length);
969       return;
970     }
971
972   /* Process the mantissa string.  */
973   while (w > 0)
974     {
975       switch (*p)
976         {
977         case ',':
978           if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
979             goto bad_float;
980           /* Fall through.  */
981         case '.':
982           if (seen_dp)
983             goto bad_float;
984           if (!seen_int_digit)
985             *(out++) = '0';
986           *(out++) = '.';
987           seen_dp = 1;
988           break;
989
990         case ' ':
991           if (dtp->u.p.blank_status == BLANK_ZERO)
992             {
993               *(out++) = '0';
994               goto found_digit;
995             }
996           else if (dtp->u.p.blank_status == BLANK_NULL)
997             break;
998           else
999             /* TODO: Should we check instead that there are only trailing
1000                blanks here, as is done below for exponents?  */
1001             goto done;
1002           /* Fall through.  */
1003         case '0':
1004         case '1':
1005         case '2':
1006         case '3':
1007         case '4':
1008         case '5':
1009         case '6':
1010         case '7':
1011         case '8':
1012         case '9':
1013           *(out++) = *p;
1014 found_digit:
1015           if (!seen_dp)
1016             seen_int_digit = 1;
1017           else
1018             seen_dec_digit = 1;
1019           break;
1020
1021         case '-':
1022         case '+':
1023           goto exponent;
1024
1025         case 'e':
1026         case 'E':
1027         case 'd':
1028         case 'D':
1029           ++p;
1030           --w;
1031           goto exponent;
1032
1033         default:
1034           goto bad_float;
1035         }
1036
1037       ++p;
1038       --w;
1039     }
1040   
1041   /* No exponent has been seen, so we use the current scale factor.  */
1042   exponent = - dtp->u.p.scale_factor;
1043   goto done;
1044
1045   /* At this point the start of an exponent has been found.  */
1046 exponent:
1047   p = eat_leading_spaces (&w, (char*) p);
1048   if (*p == '-' || *p == '+')
1049     {
1050       if (*p == '-')
1051         exponent_sign = -1;
1052       ++p;
1053       --w;
1054     }
1055
1056   /* At this point a digit string is required.  We calculate the value
1057      of the exponent in order to take account of the scale factor and
1058      the d parameter before explict conversion takes place.  */
1059
1060   if (w == 0)
1061     goto bad_float;
1062
1063   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1064     {
1065       while (w > 0 && isdigit (*p))
1066         {
1067           exponent *= 10;
1068           exponent += *p - '0';
1069           ++p;
1070           --w;
1071         }
1072         
1073       /* Only allow trailing blanks.  */
1074       while (w > 0)
1075         {
1076           if (*p != ' ')
1077             goto bad_float;
1078           ++p;
1079           --w;
1080         }
1081     }    
1082   else  /* BZ or BN status is enabled.  */
1083     {
1084       while (w > 0)
1085         {
1086           if (*p == ' ')
1087             {
1088               if (dtp->u.p.blank_status == BLANK_ZERO)
1089                 exponent *= 10;
1090               else
1091                 assert (dtp->u.p.blank_status == BLANK_NULL);
1092             }
1093           else if (!isdigit (*p))
1094             goto bad_float;
1095           else
1096             {
1097               exponent *= 10;
1098               exponent += *p - '0';
1099             }
1100
1101           ++p;
1102           --w;
1103         }
1104     }
1105
1106   exponent *= exponent_sign;
1107
1108 done:
1109   /* Use the precision specified in the format if no decimal point has been
1110      seen.  */
1111   if (!seen_dp)
1112     exponent -= f->u.real.d;
1113
1114   /* Output a trailing '0' after decimal point if not yet found.  */
1115   if (seen_dp && !seen_dec_digit)
1116     *(out++) = '0';
1117   /* Handle input of style "E+NN" by inserting a 0 for the
1118      significand.  */
1119   else if (!seen_int_digit && !seen_dec_digit)
1120     {
1121       notify_std (&dtp->common, GFC_STD_LEGACY, 
1122                   "REAL input of style 'E+NN'");
1123       *(out++) = '0';
1124     }
1125
1126   /* Print out the exponent to finish the reformatted number.  Maximum 4
1127      digits for the exponent.  */
1128   if (exponent != 0)
1129     {
1130       int dig;
1131
1132       *(out++) = 'e';
1133       if (exponent < 0)
1134         {
1135           *(out++) = '-';
1136           exponent = - exponent;
1137         }
1138
1139       assert (exponent < 10000);
1140       for (dig = 3; dig >= 0; --dig)
1141         {
1142           out[dig] = (char) ('0' + exponent % 10);
1143           exponent /= 10;
1144         }
1145       out += 4;
1146     }
1147   *(out++) = '\0';
1148
1149   /* Do the actual conversion.  */
1150   convert_real (dtp, dest, buffer, length);
1151
1152   return;
1153
1154   /* The value read is zero.  */
1155 zero:
1156   switch (length)
1157     {
1158       case 4:
1159         *((GFC_REAL_4 *) dest) = 0.0;
1160         break;
1161
1162       case 8:
1163         *((GFC_REAL_8 *) dest) = 0.0;
1164         break;
1165
1166 #ifdef HAVE_GFC_REAL_10
1167       case 10:
1168         *((GFC_REAL_10 *) dest) = 0.0;
1169         break;
1170 #endif
1171
1172 #ifdef HAVE_GFC_REAL_16
1173       case 16:
1174         *((GFC_REAL_16 *) dest) = 0.0;
1175         break;
1176 #endif
1177
1178       default:
1179         internal_error (&dtp->common, "Unsupported real kind during IO");
1180     }
1181   return;
1182
1183 bad_float:
1184   generate_error (&dtp->common, LIBERROR_READ_VALUE,
1185                   "Bad value during floating point read");
1186   next_record (dtp, 1);
1187   return;
1188 }
1189
1190
1191 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
1192  * and never look at it. */
1193
1194 void
1195 read_x (st_parameter_dt *dtp, int n)
1196 {
1197   int length, q, q2;
1198
1199   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1200        && dtp->u.p.current_unit->bytes_left < n)
1201     n = dtp->u.p.current_unit->bytes_left;
1202     
1203   if (n == 0)
1204     return;
1205
1206   length = n;
1207
1208   if (is_internal_unit (dtp))
1209     {
1210       mem_alloc_r (dtp->u.p.current_unit->s, &length);
1211       if (unlikely (length < n))
1212         n = length;
1213       goto done;
1214     }
1215
1216   if (dtp->u.p.sf_seen_eor)
1217     return;
1218
1219   n = 0;
1220   while (n < length)
1221     {
1222       q = fbuf_getc (dtp->u.p.current_unit);
1223       if (q == EOF)
1224         break;
1225       else if (q == '\n' || q == '\r')
1226         {
1227           /* Unexpected end of line. Set the position.  */
1228           dtp->u.p.sf_seen_eor = 1;
1229
1230           /* If we see an EOR during non-advancing I/O, we need to skip
1231              the rest of the I/O statement.  Set the corresponding flag.  */
1232           if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1233             dtp->u.p.eor_condition = 1;
1234             
1235           /* If we encounter a CR, it might be a CRLF.  */
1236           if (q == '\r') /* Probably a CRLF */
1237             {
1238               /* See if there is an LF.  */
1239               q2 = fbuf_getc (dtp->u.p.current_unit);
1240               if (q2 == '\n')
1241                 dtp->u.p.sf_seen_eor = 2;
1242               else if (q2 != EOF) /* Oops, seek back.  */
1243                 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1244             }
1245           goto done;
1246         }
1247       n++;
1248     } 
1249
1250  done:
1251   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
1252     dtp->u.p.size_used += (GFC_IO_INT) n;
1253   dtp->u.p.current_unit->bytes_left -= n;
1254   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1255 }
1256