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