OSDN Git Service

2006-08-15 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / read.c
1 /* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
10
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file.  (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
18 executable.)
19
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 GNU General Public License for more details.
24
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING.  If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA.  */
29
30
31 #include "config.h"
32 #include <string.h>
33 #include <errno.h>
34 #include <ctype.h>
35 #include <stdlib.h>
36 #include <stdio.h>
37 #include "libgfortran.h"
38 #include "io.h"
39
40 /* read.c -- Deal with formatted reads */
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   int n;
96
97   switch (length)
98     {
99 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
100     case 16:
101     case 10:
102       value = 1;
103       for (n = 1; n < 4 * length; n++)
104         value = (value << 2) + 3;
105       if (! signed_flag)
106         value = 2*value+1;
107       break;
108 #endif
109     case 8:
110       value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
111       break;
112     case 4:
113       value = signed_flag ? 0x7fffffff : 0xffffffff;
114       break;
115     case 2:
116       value = signed_flag ? 0x7fff : 0xffff;
117       break;
118     case 1:
119       value = signed_flag ? 0x7f : 0xff;
120       break;
121     default:
122       internal_error (NULL, "Bad integer kind");
123     }
124
125   return value;
126 }
127
128
129 /* convert_real()-- Convert a character representation of a floating
130  * point number to the machine number.  Returns nonzero if there is a
131  * range problem during conversion.  TODO: handle not-a-numbers and
132  * infinities.  */
133
134 int
135 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
136 {
137   errno = 0;
138
139   switch (length)
140     {
141     case 4:
142       {
143         GFC_REAL_4 tmp =
144 #if defined(HAVE_STRTOF)
145           strtof (buffer, NULL);
146 #else
147           (GFC_REAL_4) strtod (buffer, NULL);
148 #endif
149         memcpy (dest, (void *) &tmp, length);
150       }
151       break;
152     case 8:
153       {
154         GFC_REAL_8 tmp = strtod (buffer, NULL);
155         memcpy (dest, (void *) &tmp, length);
156       }
157       break;
158 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
159     case 10:
160       {
161         GFC_REAL_10 tmp = strtold (buffer, NULL);
162         memcpy (dest, (void *) &tmp, length);
163       }
164       break;
165 #endif
166 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
167     case 16:
168       {
169         GFC_REAL_16 tmp = strtold (buffer, NULL);
170         memcpy (dest, (void *) &tmp, length);
171       }
172       break;
173 #endif
174     default:
175       internal_error (&dtp->common, "Unsupported real kind during IO");
176     }
177
178   if (errno != 0 && errno != EINVAL)
179     {
180       generate_error (&dtp->common, ERROR_READ_VALUE,
181                       "Range error during floating point read");
182       return 1;
183     }
184
185   return 0;
186 }
187
188
189 /* read_l()-- Read a logical value */
190
191 void
192 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
193 {
194   char *p;
195   int w;
196
197   w = f->u.w;
198   p = read_block (dtp, &w);
199   if (p == NULL)
200     return;
201
202   while (*p == ' ')
203     {
204       if (--w == 0)
205         goto bad;
206       p++;
207     }
208
209   if (*p == '.')
210     {
211       if (--w == 0)
212         goto bad;
213       p++;
214     }
215
216   switch (*p)
217     {
218     case 't':
219     case 'T':
220       set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
221       break;
222     case 'f':
223     case 'F':
224       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
225       break;
226     default:
227     bad:
228       generate_error (&dtp->common, ERROR_READ_VALUE,
229                       "Bad value on logical read");
230       break;
231     }
232 }
233
234
235 /* read_a()-- Read a character record.  This one is pretty easy. */
236
237 void
238 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
239 {
240   char *source;
241   int w, m, n;
242
243   w = f->u.w;
244   if (w == -1) /* '(A)' edit descriptor  */
245     w = length;
246
247   dtp->u.p.sf_read_comma = 0;
248   source = read_block (dtp, &w);
249   dtp->u.p.sf_read_comma = 1;
250   if (source == NULL)
251     return;
252   if (w > length)
253      source += (w - length);
254
255   m = (w > length) ? length : w;
256   memcpy (p, source, m);
257
258   n = length - w;
259   if (n > 0)
260     memset (p + m, ' ', n);
261 }
262
263
264 /* eat_leading_spaces()-- Given a character pointer and a width,
265  * ignore the leading spaces.  */
266
267 static char *
268 eat_leading_spaces (int *width, char *p)
269 {
270   for (;;)
271     {
272       if (*width == 0 || *p != ' ')
273         break;
274
275       (*width)--;
276       p++;
277     }
278
279   return p;
280 }
281
282
283 static char
284 next_char (st_parameter_dt *dtp, char **p, int *w)
285 {
286   char c, *q;
287
288   if (*w == 0)
289     return '\0';
290
291   q = *p;
292   c = *q++;
293   *p = q;
294
295   (*w)--;
296
297   if (c != ' ')
298     return c;
299   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
300     return ' ';  /* return a blank to signal a null */ 
301
302   /* At this point, the rest of the field has to be trailing blanks */
303
304   while (*w > 0)
305     {
306       if (*q++ != ' ')
307         return '?';
308       (*w)--;
309     }
310
311   *p = q;
312   return '\0';
313 }
314
315
316 /* read_decimal()-- Read a decimal integer value.  The values here are
317  * signed values. */
318
319 void
320 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
321 {
322   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
323   GFC_INTEGER_LARGEST v;
324   int w, negative;
325   char c, *p;
326
327   w = f->u.w;
328   p = read_block (dtp, &w);
329   if (p == NULL)
330     return;
331
332   p = eat_leading_spaces (&w, p);
333   if (w == 0)
334     {
335       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
336       return;
337     }
338
339   maxv = max_value (length, 1);
340   maxv_10 = maxv / 10;
341
342   negative = 0;
343   value = 0;
344
345   switch (*p)
346     {
347     case '-':
348       negative = 1;
349       /* Fall through */
350
351     case '+':
352       p++;
353       if (--w == 0)
354         goto bad;
355       /* Fall through */
356
357     default:
358       break;
359     }
360
361   /* At this point we have a digit-string */
362   value = 0;
363
364   for (;;)
365     {
366       c = next_char (dtp, &p, &w);
367       if (c == '\0')
368         break;
369         
370       if (c == ' ')
371         {
372           if (dtp->u.p.blank_status == BLANK_NULL) continue;
373           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
374         }
375         
376       if (c < '0' || c > '9')
377         goto bad;
378
379       if (value > maxv_10)
380         goto overflow;
381
382       c -= '0';
383       value = 10 * value;
384
385       if (value > maxv - c)
386         goto overflow;
387       value += c;
388     }
389
390   v = value;
391   if (negative)
392     v = -v;
393
394   set_integer (dest, v, length);
395   return;
396
397  bad:
398   generate_error (&dtp->common, ERROR_READ_VALUE,
399                   "Bad value during integer read");
400   return;
401
402  overflow:
403   generate_error (&dtp->common, ERROR_READ_OVERFLOW,
404                   "Value overflowed during integer read");
405   return;
406 }
407
408
409 /* read_radix()-- This function reads values for non-decimal radixes.
410  * The difference here is that we treat the values here as unsigned
411  * values for the purposes of overflow.  If minus sign is present and
412  * the top bit is set, the value will be incorrect. */
413
414 void
415 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
416             int radix)
417 {
418   GFC_UINTEGER_LARGEST value, maxv, maxv_r;
419   GFC_INTEGER_LARGEST v;
420   int w, negative;
421   char c, *p;
422
423   w = f->u.w;
424   p = read_block (dtp, &w);
425   if (p == NULL)
426     return;
427
428   p = eat_leading_spaces (&w, p);
429   if (w == 0)
430     {
431       set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
432       return;
433     }
434
435   maxv = max_value (length, 0);
436   maxv_r = maxv / radix;
437
438   negative = 0;
439   value = 0;
440
441   switch (*p)
442     {
443     case '-':
444       negative = 1;
445       /* Fall through */
446
447     case '+':
448       p++;
449       if (--w == 0)
450         goto bad;
451       /* Fall through */
452
453     default:
454       break;
455     }
456
457   /* At this point we have a digit-string */
458   value = 0;
459
460   for (;;)
461     {
462       c = next_char (dtp, &p, &w);
463       if (c == '\0')
464         break;
465       if (c == ' ')
466         {
467           if (dtp->u.p.blank_status == BLANK_NULL) continue;
468           if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
469         }
470
471       switch (radix)
472         {
473         case 2:
474           if (c < '0' || c > '1')
475             goto bad;
476           break;
477
478         case 8:
479           if (c < '0' || c > '7')
480             goto bad;
481           break;
482
483         case 16:
484           switch (c)
485             {
486             case '0':
487             case '1':
488             case '2':
489             case '3':
490             case '4':
491             case '5':
492             case '6':
493             case '7':
494             case '8':
495             case '9':
496               break;
497
498             case 'a':
499             case 'b':
500             case 'c':
501             case 'd':
502             case 'e':
503             case 'f':
504               c = c - 'a' + '9' + 1;
505               break;
506
507             case 'A':
508             case 'B':
509             case 'C':
510             case 'D':
511             case 'E':
512             case 'F':
513               c = c - 'A' + '9' + 1;
514               break;
515
516             default:
517               goto bad;
518             }
519
520           break;
521         }
522
523       if (value > maxv_r)
524         goto overflow;
525
526       c -= '0';
527       value = radix * value;
528
529       if (maxv - c < value)
530         goto overflow;
531       value += c;
532     }
533
534   v = value;
535   if (negative)
536     v = -v;
537
538   set_integer (dest, v, length);
539   return;
540
541  bad:
542   generate_error (&dtp->common, ERROR_READ_VALUE,
543                   "Bad value during integer read");
544   return;
545
546  overflow:
547   generate_error (&dtp->common, ERROR_READ_OVERFLOW,
548                   "Value overflowed during integer read");
549   return;
550 }
551
552
553 /* read_f()-- Read a floating point number with F-style editing, which
554    is what all of the other floating point descriptors behave as.  The
555    tricky part is that optional spaces are allowed after an E or D,
556    and the implicit decimal point if a decimal point is not present in
557    the input.  */
558
559 void
560 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
561 {
562   int w, seen_dp, exponent;
563   int exponent_sign, val_sign;
564   int ndigits;
565   int edigits;
566   int i;
567   char *p, *buffer;
568   char *digits;
569   char scratch[SCRATCH_SIZE];
570
571   val_sign = 1;
572   seen_dp = 0;
573   w = f->u.w;
574   p = read_block (dtp, &w);
575   if (p == NULL)
576     return;
577
578   p = eat_leading_spaces (&w, p);
579   if (w == 0)
580     goto zero;
581
582   /* Optional sign */
583
584   if (*p == '-' || *p == '+')
585     {
586       if (*p == '-')
587         val_sign = -1;
588       p++;
589       w--;
590     }
591
592   exponent_sign = 1;
593   p = eat_leading_spaces (&w, p);
594   if (w == 0)
595     goto zero;
596
597   /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
598      is required at this point */
599
600   if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
601       && *p != 'e' && *p != 'E')
602     goto bad_float;
603
604   /* Remember the position of the first digit.  */
605   digits = p;
606   ndigits = 0;
607
608   /* Scan through the string to find the exponent.  */
609   while (w > 0)
610     {
611       switch (*p)
612         {
613         case '.':
614           if (seen_dp)
615             goto bad_float;
616           seen_dp = 1;
617           /* Fall through */
618
619         case '0':
620         case '1':
621         case '2':
622         case '3':
623         case '4':
624         case '5':
625         case '6':
626         case '7':
627         case '8':
628         case '9':
629         case ' ':
630           ndigits++;
631           p++;
632           w--;
633           break;
634
635         case '-':
636           exponent_sign = -1;
637           /* Fall through */
638
639         case '+':
640           p++;
641           w--;
642           goto exp2;
643
644         case 'd':
645         case 'e':
646         case 'D':
647         case 'E':
648           p++;
649           w--;
650           goto exp1;
651
652         default:
653           goto bad_float;
654         }
655     }
656
657   /* No exponent has been seen, so we use the current scale factor */
658   exponent = -dtp->u.p.scale_factor;
659   goto done;
660
661  bad_float:
662   generate_error (&dtp->common, ERROR_READ_VALUE,
663                   "Bad value during floating point read");
664   return;
665
666   /* The value read is zero */
667  zero:
668   switch (length)
669     {
670       case 4:
671         *((GFC_REAL_4 *) dest) = 0;
672         break;
673
674       case 8:
675         *((GFC_REAL_8 *) dest) = 0;
676         break;
677
678 #ifdef HAVE_GFC_REAL_10
679       case 10:
680         *((GFC_REAL_10 *) dest) = 0;
681         break;
682 #endif
683
684 #ifdef HAVE_GFC_REAL_16
685       case 16:
686         *((GFC_REAL_16 *) dest) = 0;
687         break;
688 #endif
689
690       default:
691         internal_error (&dtp->common, "Unsupported real kind during IO");
692     }
693   return;
694
695   /* At this point the start of an exponent has been found */
696  exp1:
697   while (w > 0 && *p == ' ')
698     {
699       w--;
700       p++;
701     }
702
703   switch (*p)
704     {
705     case '-':
706       exponent_sign = -1;
707       /* Fall through */
708
709     case '+':
710       p++;
711       w--;
712       break;
713     }
714
715   if (w == 0)
716     goto bad_float;
717
718   /* At this point a digit string is required.  We calculate the value
719      of the exponent in order to take account of the scale factor and
720      the d parameter before explict conversion takes place. */
721  exp2:
722   if (!isdigit (*p))
723     goto bad_float;
724
725   exponent = *p - '0';
726   p++;
727   w--;
728
729   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
730     {
731       while (w > 0 && isdigit (*p))
732         {
733           exponent = 10 * exponent + *p - '0';
734           p++;
735           w--;
736         }
737         
738       /* Only allow trailing blanks */
739
740       while (w > 0)
741         {
742           if (*p != ' ')
743           goto bad_float;
744           p++;
745           w--;
746         }
747     }    
748   else  /* BZ or BN status is enabled */
749     {
750       while (w > 0)
751         {
752           if (*p == ' ')
753             {
754               if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
755               if (dtp->u.p.blank_status == BLANK_NULL)
756                 {
757                   p++;
758                   w--;
759                   continue;
760                 }
761             }
762           else if (!isdigit (*p))
763             goto bad_float;
764
765           exponent = 10 * exponent + *p - '0';
766           p++;
767           w--;
768         }
769     }
770
771   exponent = exponent * exponent_sign;
772
773  done:
774   /* Use the precision specified in the format if no decimal point has been
775      seen.  */
776   if (!seen_dp)
777     exponent -= f->u.real.d;
778
779   if (exponent > 0)
780     {
781       edigits = 2;
782       i = exponent;
783     }
784   else
785     {
786       edigits = 3;
787       i = -exponent;
788     }
789
790   while (i >= 10)
791     {
792       i /= 10;
793       edigits++;
794     }
795
796   i = ndigits + edigits + 1;
797   if (val_sign < 0)
798     i++;
799
800   if (i < SCRATCH_SIZE) 
801     buffer = scratch;
802   else
803     buffer = get_mem (i);
804
805   /* Reformat the string into a temporary buffer.  As we're using atof it's
806      easiest to just leave the decimal point in place.  */
807   p = buffer;
808   if (val_sign < 0)
809     *(p++) = '-';
810   for (; ndigits > 0; ndigits--)
811     {
812       if (*digits == ' ')
813         {
814           if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
815           if (dtp->u.p.blank_status == BLANK_NULL)
816             {
817               digits++;
818               continue;
819             } 
820         }
821       *p = *digits;
822       p++;
823       digits++;
824     }
825   *(p++) = 'e';
826   sprintf (p, "%d", exponent);
827
828   /* Do the actual conversion.  */
829   convert_real (dtp, dest, buffer, length);
830
831   if (buffer != scratch)
832      free_mem (buffer);
833
834   return;
835 }
836
837
838 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
839  * and never look at it. */
840
841 void
842 read_x (st_parameter_dt *dtp, int n)
843 {
844   if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
845       && dtp->u.p.current_unit->bytes_left < n)
846     n = dtp->u.p.current_unit->bytes_left;
847
848   dtp->u.p.sf_read_comma = 0;
849   if (n > 0)
850     read_sf (dtp, &n, 1);
851   dtp->u.p.sf_read_comma = 1;
852
853 }