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