OSDN Git Service

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