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