1*0bfacb9bSmrg /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2760c2415Smrg Contributed by Andy Vaught
3760c2415Smrg F2003 I/O support contributed by Jerry DeLisle
4760c2415Smrg
5760c2415Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6760c2415Smrg
7760c2415Smrg Libgfortran is free software; you can redistribute it and/or modify
8760c2415Smrg it under the terms of the GNU General Public License as published by
9760c2415Smrg the Free Software Foundation; either version 3, or (at your option)
10760c2415Smrg any later version.
11760c2415Smrg
12760c2415Smrg Libgfortran is distributed in the hope that it will be useful,
13760c2415Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14760c2415Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15760c2415Smrg GNU General Public License for more details.
16760c2415Smrg
17760c2415Smrg Under Section 7 of GPL version 3, you are granted additional
18760c2415Smrg permissions described in the GCC Runtime Library Exception, version
19760c2415Smrg 3.1, as published by the Free Software Foundation.
20760c2415Smrg
21760c2415Smrg You should have received a copy of the GNU General Public License and
22760c2415Smrg a copy of the GCC Runtime Library Exception along with this program;
23760c2415Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24760c2415Smrg <http://www.gnu.org/licenses/>. */
25760c2415Smrg
26760c2415Smrg #include "io.h"
27760c2415Smrg #include "fbuf.h"
28760c2415Smrg #include "format.h"
29760c2415Smrg #include "unix.h"
30760c2415Smrg #include <string.h>
31760c2415Smrg #include <ctype.h>
32760c2415Smrg #include <assert.h>
33760c2415Smrg #include "async.h"
34760c2415Smrg
35760c2415Smrg typedef unsigned char uchar;
36760c2415Smrg
37760c2415Smrg /* read.c -- Deal with formatted reads */
38760c2415Smrg
39760c2415Smrg
40760c2415Smrg /* set_integer()-- All of the integer assignments come here to
41760c2415Smrg actually place the value into memory. */
42760c2415Smrg
43760c2415Smrg void
set_integer(void * dest,GFC_INTEGER_LARGEST value,int length)44760c2415Smrg set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
45760c2415Smrg {
46760c2415Smrg NOTE ("set_integer: %lld %p", (long long int) value, dest);
47760c2415Smrg switch (length)
48760c2415Smrg {
49760c2415Smrg #ifdef HAVE_GFC_INTEGER_16
50760c2415Smrg /* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
51760c2415Smrg case 10:
52760c2415Smrg case 16:
53760c2415Smrg {
54760c2415Smrg GFC_INTEGER_16 tmp = value;
55760c2415Smrg memcpy (dest, (void *) &tmp, length);
56760c2415Smrg }
57760c2415Smrg break;
58760c2415Smrg #endif
59760c2415Smrg case 8:
60760c2415Smrg {
61760c2415Smrg GFC_INTEGER_8 tmp = value;
62760c2415Smrg memcpy (dest, (void *) &tmp, length);
63760c2415Smrg }
64760c2415Smrg break;
65760c2415Smrg case 4:
66760c2415Smrg {
67760c2415Smrg GFC_INTEGER_4 tmp = value;
68760c2415Smrg memcpy (dest, (void *) &tmp, length);
69760c2415Smrg }
70760c2415Smrg break;
71760c2415Smrg case 2:
72760c2415Smrg {
73760c2415Smrg GFC_INTEGER_2 tmp = value;
74760c2415Smrg memcpy (dest, (void *) &tmp, length);
75760c2415Smrg }
76760c2415Smrg break;
77760c2415Smrg case 1:
78760c2415Smrg {
79760c2415Smrg GFC_INTEGER_1 tmp = value;
80760c2415Smrg memcpy (dest, (void *) &tmp, length);
81760c2415Smrg }
82760c2415Smrg break;
83760c2415Smrg default:
84760c2415Smrg internal_error (NULL, "Bad integer kind");
85760c2415Smrg }
86760c2415Smrg }
87760c2415Smrg
88760c2415Smrg
89760c2415Smrg /* Max signed value of size give by length argument. */
90760c2415Smrg
91760c2415Smrg GFC_UINTEGER_LARGEST
si_max(int length)92760c2415Smrg si_max (int length)
93760c2415Smrg {
94760c2415Smrg #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
95760c2415Smrg GFC_UINTEGER_LARGEST value;
96760c2415Smrg #endif
97760c2415Smrg
98760c2415Smrg switch (length)
99760c2415Smrg {
100760c2415Smrg #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
101760c2415Smrg case 16:
102760c2415Smrg case 10:
103760c2415Smrg value = 1;
104760c2415Smrg for (int n = 1; n < 4 * length; n++)
105760c2415Smrg value = (value << 2) + 3;
106760c2415Smrg return value;
107760c2415Smrg #endif
108760c2415Smrg case 8:
109760c2415Smrg return GFC_INTEGER_8_HUGE;
110760c2415Smrg case 4:
111760c2415Smrg return GFC_INTEGER_4_HUGE;
112760c2415Smrg case 2:
113760c2415Smrg return GFC_INTEGER_2_HUGE;
114760c2415Smrg case 1:
115760c2415Smrg return GFC_INTEGER_1_HUGE;
116760c2415Smrg default:
117760c2415Smrg internal_error (NULL, "Bad integer kind");
118760c2415Smrg }
119760c2415Smrg }
120760c2415Smrg
121760c2415Smrg
122760c2415Smrg /* convert_real()-- Convert a character representation of a floating
123760c2415Smrg point number to the machine number. Returns nonzero if there is an
124760c2415Smrg invalid input. Note: many architectures (e.g. IA-64, HP-PA)
125760c2415Smrg require that the storage pointed to by the dest argument is
126760c2415Smrg properly aligned for the type in question. */
127760c2415Smrg
128760c2415Smrg int
convert_real(st_parameter_dt * dtp,void * dest,const char * buffer,int length)129760c2415Smrg convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
130760c2415Smrg {
131760c2415Smrg char *endptr = NULL;
132760c2415Smrg int round_mode, old_round_mode;
133760c2415Smrg
134760c2415Smrg switch (dtp->u.p.current_unit->round_status)
135760c2415Smrg {
136760c2415Smrg case ROUND_COMPATIBLE:
137760c2415Smrg /* FIXME: As NEAREST but round away from zero for a tie. */
138760c2415Smrg case ROUND_UNSPECIFIED:
139760c2415Smrg /* Should not occur. */
140760c2415Smrg case ROUND_PROCDEFINED:
141760c2415Smrg round_mode = ROUND_NEAREST;
142760c2415Smrg break;
143760c2415Smrg default:
144760c2415Smrg round_mode = dtp->u.p.current_unit->round_status;
145760c2415Smrg break;
146760c2415Smrg }
147760c2415Smrg
148760c2415Smrg old_round_mode = get_fpu_rounding_mode();
149760c2415Smrg set_fpu_rounding_mode (round_mode);
150760c2415Smrg
151760c2415Smrg switch (length)
152760c2415Smrg {
153760c2415Smrg case 4:
154760c2415Smrg *((GFC_REAL_4*) dest) =
155760c2415Smrg #if defined(HAVE_STRTOF)
156760c2415Smrg gfc_strtof (buffer, &endptr);
157760c2415Smrg #else
158760c2415Smrg (GFC_REAL_4) gfc_strtod (buffer, &endptr);
159760c2415Smrg #endif
160760c2415Smrg break;
161760c2415Smrg
162760c2415Smrg case 8:
163760c2415Smrg *((GFC_REAL_8*) dest) = gfc_strtod (buffer, &endptr);
164760c2415Smrg break;
165760c2415Smrg
166760c2415Smrg #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
167760c2415Smrg case 10:
168760c2415Smrg *((GFC_REAL_10*) dest) = gfc_strtold (buffer, &endptr);
169760c2415Smrg break;
170760c2415Smrg #endif
171760c2415Smrg
172760c2415Smrg #if defined(HAVE_GFC_REAL_16)
173760c2415Smrg # if defined(GFC_REAL_16_IS_FLOAT128)
174760c2415Smrg case 16:
175760c2415Smrg *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, &endptr);
176760c2415Smrg break;
177760c2415Smrg # elif defined(HAVE_STRTOLD)
178760c2415Smrg case 16:
179760c2415Smrg *((GFC_REAL_16*) dest) = gfc_strtold (buffer, &endptr);
180760c2415Smrg break;
181760c2415Smrg # endif
182760c2415Smrg #endif
183760c2415Smrg
184760c2415Smrg default:
185760c2415Smrg internal_error (&dtp->common, "Unsupported real kind during IO");
186760c2415Smrg }
187760c2415Smrg
188760c2415Smrg set_fpu_rounding_mode (old_round_mode);
189760c2415Smrg
190760c2415Smrg if (buffer == endptr)
191760c2415Smrg {
192760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_VALUE,
193760c2415Smrg "Error during floating point read");
194760c2415Smrg next_record (dtp, 1);
195760c2415Smrg return 1;
196760c2415Smrg }
197760c2415Smrg
198760c2415Smrg return 0;
199760c2415Smrg }
200760c2415Smrg
201760c2415Smrg /* convert_infnan()-- Convert character INF/NAN representation to the
202760c2415Smrg machine number. Note: many architectures (e.g. IA-64, HP-PA) require
203760c2415Smrg that the storage pointed to by the dest argument is properly aligned
204760c2415Smrg for the type in question. */
205760c2415Smrg
206760c2415Smrg int
convert_infnan(st_parameter_dt * dtp,void * dest,const char * buffer,int length)207760c2415Smrg convert_infnan (st_parameter_dt *dtp, void *dest, const char *buffer,
208760c2415Smrg int length)
209760c2415Smrg {
210760c2415Smrg const char *s = buffer;
211760c2415Smrg int is_inf, plus = 1;
212760c2415Smrg
213760c2415Smrg if (*s == '+')
214760c2415Smrg s++;
215760c2415Smrg else if (*s == '-')
216760c2415Smrg {
217760c2415Smrg s++;
218760c2415Smrg plus = 0;
219760c2415Smrg }
220760c2415Smrg
221760c2415Smrg is_inf = *s == 'i';
222760c2415Smrg
223760c2415Smrg switch (length)
224760c2415Smrg {
225760c2415Smrg case 4:
226760c2415Smrg if (is_inf)
227760c2415Smrg *((GFC_REAL_4*) dest) = plus ? __builtin_inff () : -__builtin_inff ();
228760c2415Smrg else
229760c2415Smrg *((GFC_REAL_4*) dest) = plus ? __builtin_nanf ("") : -__builtin_nanf ("");
230760c2415Smrg break;
231760c2415Smrg
232760c2415Smrg case 8:
233760c2415Smrg if (is_inf)
234760c2415Smrg *((GFC_REAL_8*) dest) = plus ? __builtin_inf () : -__builtin_inf ();
235760c2415Smrg else
236760c2415Smrg *((GFC_REAL_8*) dest) = plus ? __builtin_nan ("") : -__builtin_nan ("");
237760c2415Smrg break;
238760c2415Smrg
239760c2415Smrg #if defined(HAVE_GFC_REAL_10)
240760c2415Smrg case 10:
241760c2415Smrg if (is_inf)
242760c2415Smrg *((GFC_REAL_10*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
243760c2415Smrg else
244760c2415Smrg *((GFC_REAL_10*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
245760c2415Smrg break;
246760c2415Smrg #endif
247760c2415Smrg
248760c2415Smrg #if defined(HAVE_GFC_REAL_16)
249760c2415Smrg # if defined(GFC_REAL_16_IS_FLOAT128)
250760c2415Smrg case 16:
251760c2415Smrg *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, NULL);
252760c2415Smrg break;
253760c2415Smrg # else
254760c2415Smrg case 16:
255760c2415Smrg if (is_inf)
256760c2415Smrg *((GFC_REAL_16*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
257760c2415Smrg else
258760c2415Smrg *((GFC_REAL_16*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
259760c2415Smrg break;
260760c2415Smrg # endif
261760c2415Smrg #endif
262760c2415Smrg
263760c2415Smrg default:
264760c2415Smrg internal_error (&dtp->common, "Unsupported real kind during IO");
265760c2415Smrg }
266760c2415Smrg
267760c2415Smrg return 0;
268760c2415Smrg }
269760c2415Smrg
270760c2415Smrg
271760c2415Smrg /* read_l()-- Read a logical value */
272760c2415Smrg
273760c2415Smrg void
read_l(st_parameter_dt * dtp,const fnode * f,char * dest,int length)274760c2415Smrg read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
275760c2415Smrg {
276760c2415Smrg char *p;
277760c2415Smrg size_t w;
278760c2415Smrg
279760c2415Smrg w = f->u.w;
280760c2415Smrg
281760c2415Smrg p = read_block_form (dtp, &w);
282760c2415Smrg
283760c2415Smrg if (p == NULL)
284760c2415Smrg return;
285760c2415Smrg
286760c2415Smrg while (*p == ' ')
287760c2415Smrg {
288760c2415Smrg if (--w == 0)
289760c2415Smrg goto bad;
290760c2415Smrg p++;
291760c2415Smrg }
292760c2415Smrg
293760c2415Smrg if (*p == '.')
294760c2415Smrg {
295760c2415Smrg if (--w == 0)
296760c2415Smrg goto bad;
297760c2415Smrg p++;
298760c2415Smrg }
299760c2415Smrg
300760c2415Smrg switch (*p)
301760c2415Smrg {
302760c2415Smrg case 't':
303760c2415Smrg case 'T':
304760c2415Smrg set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
305760c2415Smrg break;
306760c2415Smrg case 'f':
307760c2415Smrg case 'F':
308760c2415Smrg set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
309760c2415Smrg break;
310760c2415Smrg default:
311760c2415Smrg bad:
312760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_VALUE,
313760c2415Smrg "Bad value on logical read");
314760c2415Smrg next_record (dtp, 1);
315760c2415Smrg break;
316760c2415Smrg }
317760c2415Smrg }
318760c2415Smrg
319760c2415Smrg
320760c2415Smrg static gfc_char4_t
read_utf8(st_parameter_dt * dtp,size_t * nbytes)321760c2415Smrg read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
322760c2415Smrg {
323760c2415Smrg static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
324760c2415Smrg static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
325760c2415Smrg size_t nb, nread;
326760c2415Smrg gfc_char4_t c;
327760c2415Smrg char *s;
328760c2415Smrg
329760c2415Smrg *nbytes = 1;
330760c2415Smrg
331760c2415Smrg s = read_block_form (dtp, nbytes);
332760c2415Smrg if (s == NULL)
333760c2415Smrg return 0;
334760c2415Smrg
335760c2415Smrg /* If this is a short read, just return. */
336760c2415Smrg if (*nbytes == 0)
337760c2415Smrg return 0;
338760c2415Smrg
339760c2415Smrg c = (uchar) s[0];
340760c2415Smrg if (c < 0x80)
341760c2415Smrg return c;
342760c2415Smrg
343760c2415Smrg /* The number of leading 1-bits in the first byte indicates how many
344760c2415Smrg bytes follow. */
345760c2415Smrg for (nb = 2; nb < 7; nb++)
346760c2415Smrg if ((c & ~masks[nb-1]) == patns[nb-1])
347760c2415Smrg goto found;
348760c2415Smrg goto invalid;
349760c2415Smrg
350760c2415Smrg found:
351760c2415Smrg c = (c & masks[nb-1]);
352760c2415Smrg nread = nb - 1;
353760c2415Smrg
354760c2415Smrg s = read_block_form (dtp, &nread);
355760c2415Smrg if (s == NULL)
356760c2415Smrg return 0;
357760c2415Smrg /* Decode the bytes read. */
358760c2415Smrg for (size_t i = 1; i < nb; i++)
359760c2415Smrg {
360760c2415Smrg gfc_char4_t n = *s++;
361760c2415Smrg
362760c2415Smrg if ((n & 0xC0) != 0x80)
363760c2415Smrg goto invalid;
364760c2415Smrg
365760c2415Smrg c = ((c << 6) + (n & 0x3F));
366760c2415Smrg }
367760c2415Smrg
368760c2415Smrg /* Make sure the shortest possible encoding was used. */
369760c2415Smrg if (c <= 0x7F && nb > 1) goto invalid;
370760c2415Smrg if (c <= 0x7FF && nb > 2) goto invalid;
371760c2415Smrg if (c <= 0xFFFF && nb > 3) goto invalid;
372760c2415Smrg if (c <= 0x1FFFFF && nb > 4) goto invalid;
373760c2415Smrg if (c <= 0x3FFFFFF && nb > 5) goto invalid;
374760c2415Smrg
375760c2415Smrg /* Make sure the character is valid. */
376760c2415Smrg if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
377760c2415Smrg goto invalid;
378760c2415Smrg
379760c2415Smrg return c;
380760c2415Smrg
381760c2415Smrg invalid:
382760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
383760c2415Smrg return (gfc_char4_t) '?';
384760c2415Smrg }
385760c2415Smrg
386760c2415Smrg
387760c2415Smrg static void
read_utf8_char1(st_parameter_dt * dtp,char * p,size_t len,size_t width)388760c2415Smrg read_utf8_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
389760c2415Smrg {
390760c2415Smrg gfc_char4_t c;
391760c2415Smrg char *dest;
392760c2415Smrg size_t nbytes, j;
393760c2415Smrg
394760c2415Smrg len = (width < len) ? len : width;
395760c2415Smrg
396760c2415Smrg dest = (char *) p;
397760c2415Smrg
398760c2415Smrg /* Proceed with decoding one character at a time. */
399760c2415Smrg for (j = 0; j < len; j++, dest++)
400760c2415Smrg {
401760c2415Smrg c = read_utf8 (dtp, &nbytes);
402760c2415Smrg
403760c2415Smrg /* Check for a short read and if so, break out. */
404760c2415Smrg if (nbytes == 0)
405760c2415Smrg break;
406760c2415Smrg
407760c2415Smrg *dest = c > 255 ? '?' : (uchar) c;
408760c2415Smrg }
409760c2415Smrg
410760c2415Smrg /* If there was a short read, pad the remaining characters. */
411760c2415Smrg for (size_t i = j; i < len; i++)
412760c2415Smrg *dest++ = ' ';
413760c2415Smrg return;
414760c2415Smrg }
415760c2415Smrg
416760c2415Smrg static void
read_default_char1(st_parameter_dt * dtp,char * p,size_t len,size_t width)417760c2415Smrg read_default_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
418760c2415Smrg {
419760c2415Smrg char *s;
420760c2415Smrg size_t m;
421760c2415Smrg
422760c2415Smrg s = read_block_form (dtp, &width);
423760c2415Smrg
424760c2415Smrg if (s == NULL)
425760c2415Smrg return;
426760c2415Smrg if (width > len)
427760c2415Smrg s += (width - len);
428760c2415Smrg
429760c2415Smrg m = (width > len) ? len : width;
430760c2415Smrg memcpy (p, s, m);
431760c2415Smrg
432760c2415Smrg if (len > width)
433760c2415Smrg memset (p + m, ' ', len - width);
434760c2415Smrg }
435760c2415Smrg
436760c2415Smrg
437760c2415Smrg static void
read_utf8_char4(st_parameter_dt * dtp,void * p,size_t len,size_t width)438760c2415Smrg read_utf8_char4 (st_parameter_dt *dtp, void *p, size_t len, size_t width)
439760c2415Smrg {
440760c2415Smrg gfc_char4_t *dest;
441760c2415Smrg size_t nbytes, j;
442760c2415Smrg
443760c2415Smrg len = (width < len) ? len : width;
444760c2415Smrg
445760c2415Smrg dest = (gfc_char4_t *) p;
446760c2415Smrg
447760c2415Smrg /* Proceed with decoding one character at a time. */
448760c2415Smrg for (j = 0; j < len; j++, dest++)
449760c2415Smrg {
450760c2415Smrg *dest = read_utf8 (dtp, &nbytes);
451760c2415Smrg
452760c2415Smrg /* Check for a short read and if so, break out. */
453760c2415Smrg if (nbytes == 0)
454760c2415Smrg break;
455760c2415Smrg }
456760c2415Smrg
457760c2415Smrg /* If there was a short read, pad the remaining characters. */
458760c2415Smrg for (size_t i = j; i < len; i++)
459760c2415Smrg *dest++ = (gfc_char4_t) ' ';
460760c2415Smrg return;
461760c2415Smrg }
462760c2415Smrg
463760c2415Smrg
464760c2415Smrg static void
read_default_char4(st_parameter_dt * dtp,char * p,size_t len,size_t width)465760c2415Smrg read_default_char4 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
466760c2415Smrg {
467760c2415Smrg size_t m, n;
468760c2415Smrg gfc_char4_t *dest;
469760c2415Smrg
470760c2415Smrg if (is_char4_unit(dtp))
471760c2415Smrg {
472760c2415Smrg gfc_char4_t *s4;
473760c2415Smrg
474760c2415Smrg s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
475760c2415Smrg
476760c2415Smrg if (s4 == NULL)
477760c2415Smrg return;
478760c2415Smrg if (width > len)
479760c2415Smrg s4 += (width - len);
480760c2415Smrg
481760c2415Smrg m = (width > len) ? len : width;
482760c2415Smrg
483760c2415Smrg dest = (gfc_char4_t *) p;
484760c2415Smrg
485760c2415Smrg for (n = 0; n < m; n++)
486760c2415Smrg *dest++ = *s4++;
487760c2415Smrg
488760c2415Smrg if (len > width)
489760c2415Smrg {
490760c2415Smrg for (n = 0; n < len - width; n++)
491760c2415Smrg *dest++ = (gfc_char4_t) ' ';
492760c2415Smrg }
493760c2415Smrg }
494760c2415Smrg else
495760c2415Smrg {
496760c2415Smrg char *s;
497760c2415Smrg
498760c2415Smrg s = read_block_form (dtp, &width);
499760c2415Smrg
500760c2415Smrg if (s == NULL)
501760c2415Smrg return;
502760c2415Smrg if (width > len)
503760c2415Smrg s += (width - len);
504760c2415Smrg
505760c2415Smrg m = (width > len) ? len : width;
506760c2415Smrg
507760c2415Smrg dest = (gfc_char4_t *) p;
508760c2415Smrg
509760c2415Smrg for (n = 0; n < m; n++, dest++, s++)
510760c2415Smrg *dest = (unsigned char ) *s;
511760c2415Smrg
512760c2415Smrg if (len > width)
513760c2415Smrg {
514760c2415Smrg for (n = 0; n < len - width; n++, dest++)
515760c2415Smrg *dest = (unsigned char) ' ';
516760c2415Smrg }
517760c2415Smrg }
518760c2415Smrg }
519760c2415Smrg
520760c2415Smrg
521760c2415Smrg /* read_a()-- Read a character record into a KIND=1 character destination,
522760c2415Smrg processing UTF-8 encoding if necessary. */
523760c2415Smrg
524760c2415Smrg void
read_a(st_parameter_dt * dtp,const fnode * f,char * p,size_t length)525760c2415Smrg read_a (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
526760c2415Smrg {
527760c2415Smrg size_t w;
528760c2415Smrg
529760c2415Smrg if (f->u.w == -1) /* '(A)' edit descriptor */
530760c2415Smrg w = length;
531760c2415Smrg else
532760c2415Smrg w = f->u.w;
533760c2415Smrg
534760c2415Smrg /* Read in w characters, treating comma as not a separator. */
535760c2415Smrg dtp->u.p.sf_read_comma = 0;
536760c2415Smrg
537760c2415Smrg if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
538760c2415Smrg read_utf8_char1 (dtp, p, length, w);
539760c2415Smrg else
540760c2415Smrg read_default_char1 (dtp, p, length, w);
541760c2415Smrg
542760c2415Smrg dtp->u.p.sf_read_comma =
543760c2415Smrg dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
544760c2415Smrg }
545760c2415Smrg
546760c2415Smrg
547760c2415Smrg /* read_a_char4()-- Read a character record into a KIND=4 character destination,
548760c2415Smrg processing UTF-8 encoding if necessary. */
549760c2415Smrg
550760c2415Smrg void
read_a_char4(st_parameter_dt * dtp,const fnode * f,char * p,size_t length)551760c2415Smrg read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
552760c2415Smrg {
553760c2415Smrg size_t w;
554760c2415Smrg
555760c2415Smrg if (f->u.w == -1) /* '(A)' edit descriptor */
556760c2415Smrg w = length;
557760c2415Smrg else
558760c2415Smrg w = f->u.w;
559760c2415Smrg
560760c2415Smrg /* Read in w characters, treating comma as not a separator. */
561760c2415Smrg dtp->u.p.sf_read_comma = 0;
562760c2415Smrg
563760c2415Smrg if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
564760c2415Smrg read_utf8_char4 (dtp, p, length, w);
565760c2415Smrg else
566760c2415Smrg read_default_char4 (dtp, p, length, w);
567760c2415Smrg
568760c2415Smrg dtp->u.p.sf_read_comma =
569760c2415Smrg dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
570760c2415Smrg }
571760c2415Smrg
572760c2415Smrg /* eat_leading_spaces()-- Given a character pointer and a width,
573760c2415Smrg ignore the leading spaces. */
574760c2415Smrg
575760c2415Smrg static char *
eat_leading_spaces(size_t * width,char * p)576760c2415Smrg eat_leading_spaces (size_t *width, char *p)
577760c2415Smrg {
578760c2415Smrg for (;;)
579760c2415Smrg {
580760c2415Smrg if (*width == 0 || *p != ' ')
581760c2415Smrg break;
582760c2415Smrg
583760c2415Smrg (*width)--;
584760c2415Smrg p++;
585760c2415Smrg }
586760c2415Smrg
587760c2415Smrg return p;
588760c2415Smrg }
589760c2415Smrg
590760c2415Smrg
591760c2415Smrg static char
next_char(st_parameter_dt * dtp,char ** p,size_t * w)592760c2415Smrg next_char (st_parameter_dt *dtp, char **p, size_t *w)
593760c2415Smrg {
594760c2415Smrg char c, *q;
595760c2415Smrg
596760c2415Smrg if (*w == 0)
597760c2415Smrg return '\0';
598760c2415Smrg
599760c2415Smrg q = *p;
600760c2415Smrg c = *q++;
601760c2415Smrg *p = q;
602760c2415Smrg
603760c2415Smrg (*w)--;
604760c2415Smrg
605760c2415Smrg if (c != ' ')
606760c2415Smrg return c;
607760c2415Smrg if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
608760c2415Smrg return ' '; /* return a blank to signal a null */
609760c2415Smrg
610760c2415Smrg /* At this point, the rest of the field has to be trailing blanks */
611760c2415Smrg
612760c2415Smrg while (*w > 0)
613760c2415Smrg {
614760c2415Smrg if (*q++ != ' ')
615760c2415Smrg return '?';
616760c2415Smrg (*w)--;
617760c2415Smrg }
618760c2415Smrg
619760c2415Smrg *p = q;
620760c2415Smrg return '\0';
621760c2415Smrg }
622760c2415Smrg
623760c2415Smrg
624760c2415Smrg /* read_decimal()-- Read a decimal integer value. The values here are
625760c2415Smrg signed values. */
626760c2415Smrg
627760c2415Smrg void
read_decimal(st_parameter_dt * dtp,const fnode * f,char * dest,int length)628760c2415Smrg read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
629760c2415Smrg {
630760c2415Smrg GFC_UINTEGER_LARGEST value, maxv, maxv_10;
631760c2415Smrg GFC_INTEGER_LARGEST v;
632760c2415Smrg size_t w;
633760c2415Smrg int negative;
634760c2415Smrg char c, *p;
635760c2415Smrg
636760c2415Smrg w = f->u.w;
637760c2415Smrg
638*0bfacb9bSmrg /* This is a legacy extension, and the frontend will only allow such cases
639*0bfacb9bSmrg * through when -fdec-format-defaults is passed.
640*0bfacb9bSmrg */
641*0bfacb9bSmrg if (w == (size_t) DEFAULT_WIDTH)
642*0bfacb9bSmrg w = default_width_for_integer (length);
643*0bfacb9bSmrg
644760c2415Smrg p = read_block_form (dtp, &w);
645760c2415Smrg
646760c2415Smrg if (p == NULL)
647760c2415Smrg return;
648760c2415Smrg
649760c2415Smrg p = eat_leading_spaces (&w, p);
650760c2415Smrg if (w == 0)
651760c2415Smrg {
652760c2415Smrg set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
653760c2415Smrg return;
654760c2415Smrg }
655760c2415Smrg
656760c2415Smrg negative = 0;
657760c2415Smrg
658760c2415Smrg switch (*p)
659760c2415Smrg {
660760c2415Smrg case '-':
661760c2415Smrg negative = 1;
662760c2415Smrg /* Fall through */
663760c2415Smrg
664760c2415Smrg case '+':
665760c2415Smrg p++;
666760c2415Smrg if (--w == 0)
667760c2415Smrg goto bad;
668760c2415Smrg /* Fall through */
669760c2415Smrg
670760c2415Smrg default:
671760c2415Smrg break;
672760c2415Smrg }
673760c2415Smrg
674760c2415Smrg maxv = si_max (length);
675760c2415Smrg if (negative)
676760c2415Smrg maxv++;
677760c2415Smrg maxv_10 = maxv / 10;
678760c2415Smrg
679760c2415Smrg /* At this point we have a digit-string */
680760c2415Smrg value = 0;
681760c2415Smrg
682760c2415Smrg for (;;)
683760c2415Smrg {
684760c2415Smrg c = next_char (dtp, &p, &w);
685760c2415Smrg if (c == '\0')
686760c2415Smrg break;
687760c2415Smrg
688760c2415Smrg if (c == ' ')
689760c2415Smrg {
690760c2415Smrg if (dtp->u.p.blank_status == BLANK_NULL)
691760c2415Smrg {
692760c2415Smrg /* Skip spaces. */
693760c2415Smrg for ( ; w > 0; p++, w--)
694760c2415Smrg if (*p != ' ') break;
695760c2415Smrg continue;
696760c2415Smrg }
697760c2415Smrg if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
698760c2415Smrg }
699760c2415Smrg
700760c2415Smrg if (c < '0' || c > '9')
701760c2415Smrg goto bad;
702760c2415Smrg
703760c2415Smrg if (value > maxv_10)
704760c2415Smrg goto overflow;
705760c2415Smrg
706760c2415Smrg c -= '0';
707760c2415Smrg value = 10 * value;
708760c2415Smrg
709760c2415Smrg if (value > maxv - c)
710760c2415Smrg goto overflow;
711760c2415Smrg value += c;
712760c2415Smrg }
713760c2415Smrg
714760c2415Smrg if (negative)
715760c2415Smrg v = -value;
716760c2415Smrg else
717760c2415Smrg v = value;
718760c2415Smrg
719760c2415Smrg set_integer (dest, v, length);
720760c2415Smrg return;
721760c2415Smrg
722760c2415Smrg bad:
723760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_VALUE,
724760c2415Smrg "Bad value during integer read");
725760c2415Smrg next_record (dtp, 1);
726760c2415Smrg return;
727760c2415Smrg
728760c2415Smrg overflow:
729760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
730760c2415Smrg "Value overflowed during integer read");
731760c2415Smrg next_record (dtp, 1);
732760c2415Smrg
733760c2415Smrg }
734760c2415Smrg
735760c2415Smrg
736760c2415Smrg /* read_radix()-- This function reads values for non-decimal radixes.
737760c2415Smrg The difference here is that we treat the values here as unsigned
738760c2415Smrg values for the purposes of overflow. If minus sign is present and
739760c2415Smrg the top bit is set, the value will be incorrect. */
740760c2415Smrg
741760c2415Smrg void
read_radix(st_parameter_dt * dtp,const fnode * f,char * dest,int length,int radix)742760c2415Smrg read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
743760c2415Smrg int radix)
744760c2415Smrg {
745760c2415Smrg GFC_UINTEGER_LARGEST value, maxv, maxv_r;
746760c2415Smrg GFC_INTEGER_LARGEST v;
747760c2415Smrg size_t w;
748760c2415Smrg int negative;
749760c2415Smrg char c, *p;
750760c2415Smrg
751760c2415Smrg w = f->u.w;
752760c2415Smrg
753760c2415Smrg p = read_block_form (dtp, &w);
754760c2415Smrg
755760c2415Smrg if (p == NULL)
756760c2415Smrg return;
757760c2415Smrg
758760c2415Smrg p = eat_leading_spaces (&w, p);
759760c2415Smrg if (w == 0)
760760c2415Smrg {
761760c2415Smrg set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
762760c2415Smrg return;
763760c2415Smrg }
764760c2415Smrg
765760c2415Smrg /* Maximum unsigned value, assuming two's complement. */
766760c2415Smrg maxv = 2 * si_max (length) + 1;
767760c2415Smrg maxv_r = maxv / radix;
768760c2415Smrg
769760c2415Smrg negative = 0;
770760c2415Smrg value = 0;
771760c2415Smrg
772760c2415Smrg switch (*p)
773760c2415Smrg {
774760c2415Smrg case '-':
775760c2415Smrg negative = 1;
776760c2415Smrg /* Fall through */
777760c2415Smrg
778760c2415Smrg case '+':
779760c2415Smrg p++;
780760c2415Smrg if (--w == 0)
781760c2415Smrg goto bad;
782760c2415Smrg /* Fall through */
783760c2415Smrg
784760c2415Smrg default:
785760c2415Smrg break;
786760c2415Smrg }
787760c2415Smrg
788760c2415Smrg /* At this point we have a digit-string */
789760c2415Smrg value = 0;
790760c2415Smrg
791760c2415Smrg for (;;)
792760c2415Smrg {
793760c2415Smrg c = next_char (dtp, &p, &w);
794760c2415Smrg if (c == '\0')
795760c2415Smrg break;
796760c2415Smrg if (c == ' ')
797760c2415Smrg {
798760c2415Smrg if (dtp->u.p.blank_status == BLANK_NULL) continue;
799760c2415Smrg if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
800760c2415Smrg }
801760c2415Smrg
802760c2415Smrg switch (radix)
803760c2415Smrg {
804760c2415Smrg case 2:
805760c2415Smrg if (c < '0' || c > '1')
806760c2415Smrg goto bad;
807760c2415Smrg break;
808760c2415Smrg
809760c2415Smrg case 8:
810760c2415Smrg if (c < '0' || c > '7')
811760c2415Smrg goto bad;
812760c2415Smrg break;
813760c2415Smrg
814760c2415Smrg case 16:
815760c2415Smrg switch (c)
816760c2415Smrg {
817760c2415Smrg case '0':
818760c2415Smrg case '1':
819760c2415Smrg case '2':
820760c2415Smrg case '3':
821760c2415Smrg case '4':
822760c2415Smrg case '5':
823760c2415Smrg case '6':
824760c2415Smrg case '7':
825760c2415Smrg case '8':
826760c2415Smrg case '9':
827760c2415Smrg break;
828760c2415Smrg
829760c2415Smrg case 'a':
830760c2415Smrg case 'b':
831760c2415Smrg case 'c':
832760c2415Smrg case 'd':
833760c2415Smrg case 'e':
834760c2415Smrg case 'f':
835760c2415Smrg c = c - 'a' + '9' + 1;
836760c2415Smrg break;
837760c2415Smrg
838760c2415Smrg case 'A':
839760c2415Smrg case 'B':
840760c2415Smrg case 'C':
841760c2415Smrg case 'D':
842760c2415Smrg case 'E':
843760c2415Smrg case 'F':
844760c2415Smrg c = c - 'A' + '9' + 1;
845760c2415Smrg break;
846760c2415Smrg
847760c2415Smrg default:
848760c2415Smrg goto bad;
849760c2415Smrg }
850760c2415Smrg
851760c2415Smrg break;
852760c2415Smrg }
853760c2415Smrg
854760c2415Smrg if (value > maxv_r)
855760c2415Smrg goto overflow;
856760c2415Smrg
857760c2415Smrg c -= '0';
858760c2415Smrg value = radix * value;
859760c2415Smrg
860760c2415Smrg if (maxv - c < value)
861760c2415Smrg goto overflow;
862760c2415Smrg value += c;
863760c2415Smrg }
864760c2415Smrg
865760c2415Smrg v = value;
866760c2415Smrg if (negative)
867760c2415Smrg v = -v;
868760c2415Smrg
869760c2415Smrg set_integer (dest, v, length);
870760c2415Smrg return;
871760c2415Smrg
872760c2415Smrg bad:
873760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_VALUE,
874760c2415Smrg "Bad value during integer read");
875760c2415Smrg next_record (dtp, 1);
876760c2415Smrg return;
877760c2415Smrg
878760c2415Smrg overflow:
879760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
880760c2415Smrg "Value overflowed during integer read");
881760c2415Smrg next_record (dtp, 1);
882760c2415Smrg
883760c2415Smrg }
884760c2415Smrg
885760c2415Smrg
886760c2415Smrg /* read_f()-- Read a floating point number with F-style editing, which
887760c2415Smrg is what all of the other floating point descriptors behave as. The
888760c2415Smrg tricky part is that optional spaces are allowed after an E or D,
889760c2415Smrg and the implicit decimal point if a decimal point is not present in
890760c2415Smrg the input. */
891760c2415Smrg
892760c2415Smrg void
read_f(st_parameter_dt * dtp,const fnode * f,char * dest,int length)893760c2415Smrg read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
894760c2415Smrg {
895760c2415Smrg #define READF_TMP 50
896760c2415Smrg char tmp[READF_TMP];
897760c2415Smrg size_t buf_size = 0;
898760c2415Smrg size_t w;
899760c2415Smrg int seen_dp, exponent;
900760c2415Smrg int exponent_sign;
901760c2415Smrg const char *p;
902760c2415Smrg char *buffer;
903760c2415Smrg char *out;
904760c2415Smrg int seen_int_digit; /* Seen a digit before the decimal point? */
905760c2415Smrg int seen_dec_digit; /* Seen a digit after the decimal point? */
906760c2415Smrg
907760c2415Smrg seen_dp = 0;
908760c2415Smrg seen_int_digit = 0;
909760c2415Smrg seen_dec_digit = 0;
910760c2415Smrg exponent_sign = 1;
911760c2415Smrg exponent = 0;
912760c2415Smrg w = f->u.w;
913760c2415Smrg buffer = tmp;
914760c2415Smrg
915760c2415Smrg /* Read in the next block. */
916760c2415Smrg p = read_block_form (dtp, &w);
917760c2415Smrg if (p == NULL)
918760c2415Smrg return;
919760c2415Smrg p = eat_leading_spaces (&w, (char*) p);
920760c2415Smrg if (w == 0)
921760c2415Smrg goto zero;
922760c2415Smrg
923760c2415Smrg /* In this buffer we're going to re-format the number cleanly to be parsed
924760c2415Smrg by convert_real in the end; this assures we're using strtod from the
925760c2415Smrg C library for parsing and thus probably get the best accuracy possible.
926760c2415Smrg This process may add a '+0.0' in front of the number as well as change the
927760c2415Smrg exponent because of an implicit decimal point or the like. Thus allocating
928760c2415Smrg strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
929760c2415Smrg original buffer had should be enough. */
930760c2415Smrg buf_size = w + 11;
931760c2415Smrg if (buf_size > READF_TMP)
932760c2415Smrg buffer = xmalloc (buf_size);
933760c2415Smrg
934760c2415Smrg out = buffer;
935760c2415Smrg
936760c2415Smrg /* Optional sign */
937760c2415Smrg if (*p == '-' || *p == '+')
938760c2415Smrg {
939760c2415Smrg if (*p == '-')
940760c2415Smrg *(out++) = '-';
941760c2415Smrg ++p;
942760c2415Smrg --w;
943760c2415Smrg }
944760c2415Smrg
945760c2415Smrg p = eat_leading_spaces (&w, (char*) p);
946760c2415Smrg if (w == 0)
947760c2415Smrg goto zero;
948760c2415Smrg
949760c2415Smrg /* Check for Infinity or NaN. */
950760c2415Smrg if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
951760c2415Smrg {
952760c2415Smrg int seen_paren = 0;
953760c2415Smrg char *save = out;
954760c2415Smrg
955760c2415Smrg /* Scan through the buffer keeping track of spaces and parenthesis. We
956760c2415Smrg null terminate the string as soon as we see a left paren or if we are
957760c2415Smrg BLANK_NULL mode. Leading spaces have already been skipped above,
958760c2415Smrg trailing spaces are ignored by converting to '\0'. A space
959760c2415Smrg between "NaN" and the optional perenthesis is not permitted. */
960760c2415Smrg while (w > 0)
961760c2415Smrg {
962760c2415Smrg *out = tolower (*p);
963760c2415Smrg switch (*p)
964760c2415Smrg {
965760c2415Smrg case ' ':
966760c2415Smrg if (dtp->u.p.blank_status == BLANK_ZERO)
967760c2415Smrg {
968760c2415Smrg *out = '0';
969760c2415Smrg break;
970760c2415Smrg }
971760c2415Smrg *out = '\0';
972760c2415Smrg if (seen_paren == 1)
973760c2415Smrg goto bad_float;
974760c2415Smrg break;
975760c2415Smrg case '(':
976760c2415Smrg seen_paren++;
977760c2415Smrg *out = '\0';
978760c2415Smrg break;
979760c2415Smrg case ')':
980760c2415Smrg if (seen_paren++ != 1)
981760c2415Smrg goto bad_float;
982760c2415Smrg break;
983760c2415Smrg default:
984760c2415Smrg if (!isalnum (*out))
985760c2415Smrg goto bad_float;
986760c2415Smrg }
987760c2415Smrg --w;
988760c2415Smrg ++p;
989760c2415Smrg ++out;
990760c2415Smrg }
991760c2415Smrg
992760c2415Smrg *out = '\0';
993760c2415Smrg
994760c2415Smrg if (seen_paren != 0 && seen_paren != 2)
995760c2415Smrg goto bad_float;
996760c2415Smrg
997760c2415Smrg if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
998760c2415Smrg {
999760c2415Smrg if (seen_paren)
1000760c2415Smrg goto bad_float;
1001760c2415Smrg }
1002760c2415Smrg else if (strcmp (save, "nan") != 0)
1003760c2415Smrg goto bad_float;
1004760c2415Smrg
1005760c2415Smrg convert_infnan (dtp, dest, buffer, length);
1006760c2415Smrg if (buf_size > READF_TMP)
1007760c2415Smrg free (buffer);
1008760c2415Smrg return;
1009760c2415Smrg }
1010760c2415Smrg
1011760c2415Smrg /* Process the mantissa string. */
1012760c2415Smrg while (w > 0)
1013760c2415Smrg {
1014760c2415Smrg switch (*p)
1015760c2415Smrg {
1016760c2415Smrg case ',':
1017760c2415Smrg if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
1018760c2415Smrg goto bad_float;
1019760c2415Smrg /* Fall through. */
1020760c2415Smrg case '.':
1021760c2415Smrg if (seen_dp)
1022760c2415Smrg goto bad_float;
1023760c2415Smrg if (!seen_int_digit)
1024760c2415Smrg *(out++) = '0';
1025760c2415Smrg *(out++) = '.';
1026760c2415Smrg seen_dp = 1;
1027760c2415Smrg break;
1028760c2415Smrg
1029760c2415Smrg case ' ':
1030760c2415Smrg if (dtp->u.p.blank_status == BLANK_ZERO)
1031760c2415Smrg {
1032760c2415Smrg *(out++) = '0';
1033760c2415Smrg goto found_digit;
1034760c2415Smrg }
1035760c2415Smrg else if (dtp->u.p.blank_status == BLANK_NULL)
1036760c2415Smrg break;
1037760c2415Smrg else
1038760c2415Smrg /* TODO: Should we check instead that there are only trailing
1039760c2415Smrg blanks here, as is done below for exponents? */
1040760c2415Smrg goto done;
1041760c2415Smrg /* Fall through. */
1042760c2415Smrg case '0':
1043760c2415Smrg case '1':
1044760c2415Smrg case '2':
1045760c2415Smrg case '3':
1046760c2415Smrg case '4':
1047760c2415Smrg case '5':
1048760c2415Smrg case '6':
1049760c2415Smrg case '7':
1050760c2415Smrg case '8':
1051760c2415Smrg case '9':
1052760c2415Smrg *(out++) = *p;
1053760c2415Smrg found_digit:
1054760c2415Smrg if (!seen_dp)
1055760c2415Smrg seen_int_digit = 1;
1056760c2415Smrg else
1057760c2415Smrg seen_dec_digit = 1;
1058760c2415Smrg break;
1059760c2415Smrg
1060760c2415Smrg case '-':
1061760c2415Smrg case '+':
1062760c2415Smrg goto exponent;
1063760c2415Smrg
1064760c2415Smrg case 'e':
1065760c2415Smrg case 'E':
1066760c2415Smrg case 'd':
1067760c2415Smrg case 'D':
1068760c2415Smrg case 'q':
1069760c2415Smrg case 'Q':
1070760c2415Smrg ++p;
1071760c2415Smrg --w;
1072760c2415Smrg goto exponent;
1073760c2415Smrg
1074760c2415Smrg default:
1075760c2415Smrg goto bad_float;
1076760c2415Smrg }
1077760c2415Smrg
1078760c2415Smrg ++p;
1079760c2415Smrg --w;
1080760c2415Smrg }
1081760c2415Smrg
1082760c2415Smrg /* No exponent has been seen, so we use the current scale factor. */
1083760c2415Smrg exponent = - dtp->u.p.scale_factor;
1084760c2415Smrg goto done;
1085760c2415Smrg
1086760c2415Smrg /* At this point the start of an exponent has been found. */
1087760c2415Smrg exponent:
1088760c2415Smrg p = eat_leading_spaces (&w, (char*) p);
1089760c2415Smrg if (*p == '-' || *p == '+')
1090760c2415Smrg {
1091760c2415Smrg if (*p == '-')
1092760c2415Smrg exponent_sign = -1;
1093760c2415Smrg ++p;
1094760c2415Smrg --w;
1095760c2415Smrg }
1096760c2415Smrg
1097760c2415Smrg /* At this point a digit string is required. We calculate the value
1098760c2415Smrg of the exponent in order to take account of the scale factor and
1099760c2415Smrg the d parameter before explict conversion takes place. */
1100760c2415Smrg
1101760c2415Smrg if (w == 0)
1102760c2415Smrg {
1103760c2415Smrg /* Extension: allow default exponent of 0 when omitted. */
1104760c2415Smrg if (dtp->common.flags & IOPARM_DT_DEC_EXT)
1105760c2415Smrg goto done;
1106760c2415Smrg else
1107760c2415Smrg goto bad_float;
1108760c2415Smrg }
1109760c2415Smrg
1110760c2415Smrg if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1111760c2415Smrg {
1112760c2415Smrg while (w > 0 && isdigit (*p))
1113760c2415Smrg {
1114760c2415Smrg exponent *= 10;
1115760c2415Smrg exponent += *p - '0';
1116760c2415Smrg ++p;
1117760c2415Smrg --w;
1118760c2415Smrg }
1119760c2415Smrg
1120760c2415Smrg /* Only allow trailing blanks. */
1121760c2415Smrg while (w > 0)
1122760c2415Smrg {
1123760c2415Smrg if (*p != ' ')
1124760c2415Smrg goto bad_float;
1125760c2415Smrg ++p;
1126760c2415Smrg --w;
1127760c2415Smrg }
1128760c2415Smrg }
1129760c2415Smrg else /* BZ or BN status is enabled. */
1130760c2415Smrg {
1131760c2415Smrg while (w > 0)
1132760c2415Smrg {
1133760c2415Smrg if (*p == ' ')
1134760c2415Smrg {
1135760c2415Smrg if (dtp->u.p.blank_status == BLANK_ZERO)
1136760c2415Smrg exponent *= 10;
1137760c2415Smrg else
1138760c2415Smrg assert (dtp->u.p.blank_status == BLANK_NULL);
1139760c2415Smrg }
1140760c2415Smrg else if (!isdigit (*p))
1141760c2415Smrg goto bad_float;
1142760c2415Smrg else
1143760c2415Smrg {
1144760c2415Smrg exponent *= 10;
1145760c2415Smrg exponent += *p - '0';
1146760c2415Smrg }
1147760c2415Smrg
1148760c2415Smrg ++p;
1149760c2415Smrg --w;
1150760c2415Smrg }
1151760c2415Smrg }
1152760c2415Smrg
1153760c2415Smrg exponent *= exponent_sign;
1154760c2415Smrg
1155760c2415Smrg done:
1156760c2415Smrg /* Use the precision specified in the format if no decimal point has been
1157760c2415Smrg seen. */
1158760c2415Smrg if (!seen_dp)
1159760c2415Smrg exponent -= f->u.real.d;
1160760c2415Smrg
1161760c2415Smrg /* Output a trailing '0' after decimal point if not yet found. */
1162760c2415Smrg if (seen_dp && !seen_dec_digit)
1163760c2415Smrg *(out++) = '0';
1164760c2415Smrg /* Handle input of style "E+NN" by inserting a 0 for the
1165760c2415Smrg significand. */
1166760c2415Smrg else if (!seen_int_digit && !seen_dec_digit)
1167760c2415Smrg {
1168760c2415Smrg notify_std (&dtp->common, GFC_STD_LEGACY,
1169760c2415Smrg "REAL input of style 'E+NN'");
1170760c2415Smrg *(out++) = '0';
1171760c2415Smrg }
1172760c2415Smrg
1173760c2415Smrg /* Print out the exponent to finish the reformatted number. Maximum 4
1174760c2415Smrg digits for the exponent. */
1175760c2415Smrg if (exponent != 0)
1176760c2415Smrg {
1177760c2415Smrg int dig;
1178760c2415Smrg
1179760c2415Smrg *(out++) = 'e';
1180760c2415Smrg if (exponent < 0)
1181760c2415Smrg {
1182760c2415Smrg *(out++) = '-';
1183760c2415Smrg exponent = - exponent;
1184760c2415Smrg }
1185760c2415Smrg
1186760c2415Smrg if (exponent >= 10000)
1187760c2415Smrg goto bad_float;
1188760c2415Smrg
1189760c2415Smrg for (dig = 3; dig >= 0; --dig)
1190760c2415Smrg {
1191760c2415Smrg out[dig] = (char) ('0' + exponent % 10);
1192760c2415Smrg exponent /= 10;
1193760c2415Smrg }
1194760c2415Smrg out += 4;
1195760c2415Smrg }
1196760c2415Smrg *(out++) = '\0';
1197760c2415Smrg
1198760c2415Smrg /* Do the actual conversion. */
1199760c2415Smrg convert_real (dtp, dest, buffer, length);
1200760c2415Smrg if (buf_size > READF_TMP)
1201760c2415Smrg free (buffer);
1202760c2415Smrg return;
1203760c2415Smrg
1204760c2415Smrg /* The value read is zero. */
1205760c2415Smrg zero:
1206760c2415Smrg switch (length)
1207760c2415Smrg {
1208760c2415Smrg case 4:
1209760c2415Smrg *((GFC_REAL_4 *) dest) = 0.0;
1210760c2415Smrg break;
1211760c2415Smrg
1212760c2415Smrg case 8:
1213760c2415Smrg *((GFC_REAL_8 *) dest) = 0.0;
1214760c2415Smrg break;
1215760c2415Smrg
1216760c2415Smrg #ifdef HAVE_GFC_REAL_10
1217760c2415Smrg case 10:
1218760c2415Smrg *((GFC_REAL_10 *) dest) = 0.0;
1219760c2415Smrg break;
1220760c2415Smrg #endif
1221760c2415Smrg
1222760c2415Smrg #ifdef HAVE_GFC_REAL_16
1223760c2415Smrg case 16:
1224760c2415Smrg *((GFC_REAL_16 *) dest) = 0.0;
1225760c2415Smrg break;
1226760c2415Smrg #endif
1227760c2415Smrg
1228760c2415Smrg default:
1229760c2415Smrg internal_error (&dtp->common, "Unsupported real kind during IO");
1230760c2415Smrg }
1231760c2415Smrg return;
1232760c2415Smrg
1233760c2415Smrg bad_float:
1234760c2415Smrg if (buf_size > READF_TMP)
1235760c2415Smrg free (buffer);
1236760c2415Smrg generate_error (&dtp->common, LIBERROR_READ_VALUE,
1237760c2415Smrg "Bad value during floating point read");
1238760c2415Smrg next_record (dtp, 1);
1239760c2415Smrg return;
1240760c2415Smrg }
1241760c2415Smrg
1242760c2415Smrg
1243760c2415Smrg /* read_x()-- Deal with the X/TR descriptor. We just read some data
1244760c2415Smrg and never look at it. */
1245760c2415Smrg
1246760c2415Smrg void
read_x(st_parameter_dt * dtp,size_t n)1247760c2415Smrg read_x (st_parameter_dt *dtp, size_t n)
1248760c2415Smrg {
1249760c2415Smrg size_t length;
1250760c2415Smrg int q, q2;
1251760c2415Smrg
1252760c2415Smrg if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1253760c2415Smrg && dtp->u.p.current_unit->bytes_left < (gfc_offset) n)
1254760c2415Smrg n = dtp->u.p.current_unit->bytes_left;
1255760c2415Smrg
1256760c2415Smrg if (n == 0)
1257760c2415Smrg return;
1258760c2415Smrg
1259760c2415Smrg length = n;
1260760c2415Smrg
1261760c2415Smrg if (is_internal_unit (dtp))
1262760c2415Smrg {
1263760c2415Smrg mem_alloc_r (dtp->u.p.current_unit->s, &length);
1264760c2415Smrg if (unlikely (length < n))
1265760c2415Smrg n = length;
1266760c2415Smrg goto done;
1267760c2415Smrg }
1268760c2415Smrg
1269760c2415Smrg if (dtp->u.p.sf_seen_eor)
1270760c2415Smrg return;
1271760c2415Smrg
1272760c2415Smrg n = 0;
1273760c2415Smrg while (n < length)
1274760c2415Smrg {
1275760c2415Smrg q = fbuf_getc (dtp->u.p.current_unit);
1276760c2415Smrg if (q == EOF)
1277760c2415Smrg break;
1278760c2415Smrg else if (dtp->u.p.current_unit->flags.cc != CC_NONE
1279760c2415Smrg && (q == '\n' || q == '\r'))
1280760c2415Smrg {
1281760c2415Smrg /* Unexpected end of line. Set the position. */
1282760c2415Smrg dtp->u.p.sf_seen_eor = 1;
1283760c2415Smrg
1284760c2415Smrg /* If we see an EOR during non-advancing I/O, we need to skip
1285760c2415Smrg the rest of the I/O statement. Set the corresponding flag. */
1286760c2415Smrg if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1287760c2415Smrg dtp->u.p.eor_condition = 1;
1288760c2415Smrg
1289760c2415Smrg /* If we encounter a CR, it might be a CRLF. */
1290760c2415Smrg if (q == '\r') /* Probably a CRLF */
1291760c2415Smrg {
1292760c2415Smrg /* See if there is an LF. */
1293760c2415Smrg q2 = fbuf_getc (dtp->u.p.current_unit);
1294760c2415Smrg if (q2 == '\n')
1295760c2415Smrg dtp->u.p.sf_seen_eor = 2;
1296760c2415Smrg else if (q2 != EOF) /* Oops, seek back. */
1297760c2415Smrg fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1298760c2415Smrg }
1299760c2415Smrg goto done;
1300760c2415Smrg }
1301760c2415Smrg n++;
1302760c2415Smrg }
1303760c2415Smrg
1304760c2415Smrg done:
1305760c2415Smrg if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
1306760c2415Smrg dtp->u.p.current_unit->has_size)
1307760c2415Smrg dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
1308760c2415Smrg dtp->u.p.current_unit->bytes_left -= n;
1309760c2415Smrg dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1310760c2415Smrg }
1311760c2415Smrg
1312