1 /*
2 * Copyright (c) 1995-2018, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /* clang-format off */
19
20 /** \file
21 * \brief List-directed read module.
22 */
23
24 #include "global.h"
25 #include "format.h"
26 #include "list_io.h"
27 #include <string.h>
28
29 /* define a few things for run-time tracing */
30 static int dbgflag;
31 #undef DBGBIT
32 #define DBGBIT(v) (LOCAL_DEBUG && (dbgflag & v))
33 /*
34 * dbgbit values:
35 * 0x01 ldr
36 * 0x02 read_record
37 * 0x04 ldr_end
38 * 0x08 get_token
39 */
40
41 int read_record_internal(void);
42 static int read_record(void);
43 static char *alloc_rbuf(int, bool);
44 static int skip_record(void);
45
46 static FIO_FCB *fcb; /* fcb of external file */
47 static bool accessed; /* file has been read */
48 static int byte_cnt; /* number of bytes read */
49 static int n_irecs; /* number of internal file records */
50 static bool internal_file;
51 static int rec_len;
52
53 static int gbl_dtype; /* data type of item (global to local funcs) */
54
55 #define RBUF_SIZE 256
56 static char rbuf[RBUF_SIZE + 1];
57 static unsigned rbuf_size = RBUF_SIZE;
58
59 static char *rbufp = rbuf; /* ptr to read buffer */
60 static char *currc; /* current pointer in buffer */
61
62 static char *in_recp; /* internal i/o record (user's space) */
63
64 struct struct_G {
65 short blank_zero; /* FIO_ ZERO or NULL */
66 short pad; /* FIO_ YES or NULL */
67 short decimal; /* COMMA, POINT, NONE */
68 short round; /* FIO_ UP, DOWN, ZERO, NEAREST, COMPATIBLE,
69 * PROCESSOR_DEFINED, NONE
70 */
71 FIO_FCB *fcb;
72 bool accessed;
73 int byte_cnt;
74 int n_irecs;
75 bool internal_file;
76 int rec_len;
77 int gbl_dtype;
78 char rbuf[RBUF_SIZE + 1];
79 unsigned rbuf_size;
80 char *rbufp;
81 char *currc;
82 char *in_recp;
83
84 AVAL tknval;
85 int tkntyp;
86 int scan_err;
87 int repeat_cnt;
88 int prev_tkntyp;
89 bool comma_seen;
90 struct struct_G *same_fcb;
91 int same_fcb_idx;
92 };
93
94 #define GBL_SIZE 5
95
96 typedef struct struct_G G;
97
98 static G static_gbl[GBL_SIZE];
99 static G *gbl = &static_gbl[0];
100 static G *gbl_head = &static_gbl[0];
101 static int gbl_avl = 0;
102 static int gbl_size = GBL_SIZE;
103
104 union ieee {
105 double d;
106 struct {
107 unsigned int lm : 32;
108 unsigned int hm : 20;
109 unsigned int e : 11;
110 unsigned int s : 1;
111 } v;
112 int i[2];
113 };
114
115 /* get_token declarations, etc. */
116
117 #define TK_ERROR 1
118 #define TK_NULL 2
119 #define TK_SLASH 3
120 #define TK_VAL 4
121 #define TK_VALS 5
122
123 static void shared_init(void);
124 static void get_token(void);
125 static void get_number(void);
126 static void get_cmplx(void);
127 static void get_infinity(void);
128 static void get_nan(void);
129 static __BIGREAL_T to_bigreal(AVAL *);
130 static void get_qstr(int);
131 static void get_junk(void);
132 static bool skip_spaces(void);
133 static bool find_char(int);
134
135 static AVAL tknval; /* TK_VAL value returned by get_token */
136 static int tkntyp;
137 static int scan_err;
138
139 /* Initial state for a READ statement */
140 static int repeat_cnt;
141 static int prev_tkntyp;
142 static bool comma_seen;
143
144 static void
save_gbl()145 save_gbl()
146 {
147 if (gbl_avl) {
148 gbl->fcb = fcb;
149 gbl->accessed = accessed;
150 gbl->byte_cnt = byte_cnt;
151 gbl->n_irecs = n_irecs;
152 gbl->internal_file = internal_file;
153 gbl->rec_len = rec_len;
154 gbl->gbl_dtype = gbl_dtype;
155 if (rbuf_size > gbl->rbuf_size) {
156 gbl->rbufp = malloc(rbuf_size);
157 gbl->rbuf_size = rbuf_size;
158 } else {
159 gbl->rbufp = gbl->rbuf;
160 gbl->rbuf_size = RBUF_SIZE;
161 }
162 memcpy(gbl->rbufp, rbufp, rbuf_size);
163 if (currc) {
164 assert(currc == (rbufp + (currc - rbufp)));
165 gbl->currc = gbl->rbufp + (currc - rbufp);
166 } else {
167 gbl->currc = NULL;
168 }
169 gbl->in_recp = in_recp;
170
171 /* may need to revisit this for derived type io */
172 gbl->tknval = tknval;
173 gbl->tkntyp = tkntyp;
174 gbl->scan_err = scan_err;
175 gbl->repeat_cnt = repeat_cnt;
176 gbl->prev_tkntyp = prev_tkntyp;
177 gbl->comma_seen = comma_seen;
178 }
179 }
180
181 static void
restore_gbl()182 restore_gbl()
183 {
184 if (gbl_avl) {
185 fcb = gbl->fcb;
186 accessed = gbl->accessed;
187 byte_cnt = gbl->byte_cnt;
188 n_irecs = gbl->n_irecs;
189 internal_file = gbl->internal_file;
190 rec_len = gbl->rec_len;
191 gbl_dtype = gbl->gbl_dtype;
192 if (gbl->rbuf_size > rbuf_size) {
193 if (rbufp != rbuf)
194 rbufp = realloc(rbufp, gbl->rbuf_size);
195 else
196 rbufp = malloc(gbl->rbuf_size);
197 } else {
198 rbufp = rbuf;
199 }
200 rbuf_size = gbl->rbuf_size;
201 memcpy(rbufp, gbl->rbufp, rbuf_size);
202 if (gbl->currc) {
203 assert(gbl->currc == (gbl->rbufp + (gbl->currc - gbl->rbufp)));
204 currc = rbufp + (gbl->currc - gbl->rbufp);
205 } else {
206 currc = NULL;
207 }
208
209 in_recp = gbl->in_recp;
210
211 /* may need to revisit this for derived type io */
212 tknval = gbl->tknval;
213 tkntyp = gbl->tkntyp;
214 scan_err = gbl->scan_err;
215 repeat_cnt = gbl->repeat_cnt;
216 prev_tkntyp = gbl->prev_tkntyp;
217 comma_seen = gbl->comma_seen;
218 }
219 }
220
221 static void
save_samefcb()222 save_samefcb()
223 {
224 G *tmp_gbl;
225 tmp_gbl = gbl->same_fcb;
226 if (tmp_gbl) {
227 tmp_gbl = &gbl_head[gbl->same_fcb_idx];
228 tmp_gbl->accessed = accessed;
229 tmp_gbl->byte_cnt = byte_cnt;
230 tmp_gbl->repeat_cnt = repeat_cnt;
231 tmp_gbl->prev_tkntyp = prev_tkntyp;
232 tmp_gbl->n_irecs = n_irecs;
233 tmp_gbl->internal_file = internal_file;
234 tmp_gbl->rec_len = rec_len;
235 tmp_gbl->gbl_dtype = gbl_dtype;
236 tmp_gbl->in_recp = in_recp;
237 if (rbuf_size > tmp_gbl->rbuf_size) {
238 if (tmp_gbl->rbuf != tmp_gbl->rbufp)
239 tmp_gbl->rbufp = realloc(tmp_gbl->rbufp, rbuf_size);
240 else
241 tmp_gbl->rbufp = malloc(rbuf_size);
242 tmp_gbl->rbuf_size = rbuf_size;
243 } else {
244 tmp_gbl->rbufp = tmp_gbl->rbuf;
245 }
246 memcpy(tmp_gbl->rbufp, rbufp, rbuf_size);
247 if (currc) {
248 assert(currc == (rbufp + (currc - rbufp)));
249 tmp_gbl->currc = tmp_gbl->rbufp + (currc - rbufp);
250 } else {
251 tmp_gbl->currc = NULL;
252 }
253
254 tmp_gbl->blank_zero = gbl->blank_zero;
255 tmp_gbl->pad = gbl->pad;
256 tmp_gbl->decimal = gbl->decimal;
257 tmp_gbl->round = gbl->round;
258 tmp_gbl->internal_file = internal_file;
259 }
260 }
261
262 static void
allocate_new_gbl()263 allocate_new_gbl()
264 {
265 G *tmp_gbl;
266 int gsize = sizeof(G);
267 if (gbl_avl >= gbl_size) {
268 if (gbl_size == GBL_SIZE) {
269 gbl_size = gbl_size + GBL_SIZE;
270 tmp_gbl = (G *)malloc(gsize * gbl_size);
271 memcpy(tmp_gbl, gbl_head, gsize * gbl_avl);
272 memset(tmp_gbl + gbl_avl, 0, gsize * GBL_SIZE);
273 gbl_head = tmp_gbl;
274 } else {
275 gbl_size = gbl_size + GBL_SIZE;
276 gbl_head = (G *)realloc(gbl_head, gsize * gbl_size);
277 memset(gbl_head + gbl_avl, 0, gsize * GBL_SIZE);
278 }
279 }
280 gbl = &gbl_head[gbl_avl];
281 if (gbl->rbufp != gbl->rbuf) {
282 free(gbl->rbufp);
283 }
284 memset(gbl, 0, gsize);
285 gbl->rbufp = gbl->rbuf;
286 gbl->rbuf_size = RBUF_SIZE;
287 ++gbl_avl;
288 }
289
290 static void
free_gbl()291 free_gbl()
292 {
293 --gbl_avl;
294 if (gbl_avl <= 0)
295 gbl_avl = 0;
296 if (gbl_avl == 0)
297 gbl = &gbl_head[gbl_avl];
298 else
299 gbl = &gbl_head[gbl_avl - 1];
300 }
301
302 /* ***************************************/
303 /* list-directed external file read init */
304 /* ***************************************/
305
306 static int
_f90io_ldr_init(__INT_T * unit,__INT_T * rec,__INT_T * bitv,__INT_T * iostat)307 _f90io_ldr_init(__INT_T *unit, /* unit number */
308 __INT_T *rec, /* record number for direct access I/O */
309 __INT_T *bitv, /* same as for ENTF90IO(open_) */
310 __INT_T *iostat) /* same as for ENTF90IO(open_) */
311 {
312
313 int i;
314 G *tmp_gbl;
315 save_gbl();
316 __fortio_errinit03(*unit, *bitv, iostat, "list-directed read");
317 allocate_new_gbl();
318 fcb = __fortio_rwinit(*unit, FIO_FORMATTED, rec, 0 /*read*/);
319
320 if (fcb == NULL) {
321 if (fioFcbTbls.eof)
322 return EOF_FLAG;
323 /* TBD - does there need to be fioFcbTbls.eor */
324 return ERR_FLAG;
325 }
326
327 rec_len = fcb->reclen;
328 internal_file = FALSE;
329
330 gbl->decimal = fcb->decimal;
331
332 /* check if recursive io on same external file */
333 tmp_gbl = NULL;
334 if (gbl_avl > 1) {
335 for (i = gbl_avl - 2; i >= 0; --i) {
336 if (gbl_head[i].fcb == fcb) {
337 tmp_gbl = &gbl_head[i];
338 break;
339 }
340 }
341 }
342 if (tmp_gbl) {
343 gbl->same_fcb = tmp_gbl;
344 gbl->same_fcb_idx = i;
345 gbl->blank_zero = tmp_gbl->blank_zero;
346 gbl->pad = tmp_gbl->pad;
347 gbl->decimal = tmp_gbl->decimal;
348 gbl->round = tmp_gbl->round;
349
350 accessed = tmp_gbl->accessed;
351 byte_cnt = tmp_gbl->byte_cnt;
352 prev_tkntyp = tmp_gbl->prev_tkntyp;
353 repeat_cnt = tmp_gbl->repeat_cnt;
354 n_irecs = tmp_gbl->n_irecs;
355 rec_len = tmp_gbl->rec_len;
356 gbl_dtype = tmp_gbl->gbl_dtype;
357 in_recp = tmp_gbl->in_recp;
358 internal_file = tmp_gbl->internal_file;
359 if (tmp_gbl->rbuf_size > rbuf_size) {
360 if (rbufp != rbuf)
361 rbufp = realloc(rbufp, tmp_gbl->rbuf_size);
362 else
363 rbufp = malloc(tmp_gbl->rbuf_size);
364 rbuf_size = tmp_gbl->rbuf_size;
365 } else {
366 rbufp = rbuf;
367 }
368 memcpy(rbufp, tmp_gbl->rbufp, tmp_gbl->rbuf_size);
369 if (tmp_gbl->currc) {
370 currc = rbufp + (tmp_gbl->currc - tmp_gbl->rbufp);
371 } else {
372 currc = NULL;
373 }
374 comma_seen = FALSE;
375 return 0;
376 } else {
377 gbl->same_fcb = tmp_gbl;
378 gbl->same_fcb_idx = 0;
379 fcb->skip = 0;
380 }
381
382 shared_init();
383 return 0;
384 }
385
386 __INT_T
ENTF90IO(LDR_INIT,ldr_init)387 ENTF90IO(LDR_INIT, ldr_init)
388 (__INT_T *unit, /* unit number */
389 __INT_T *rec, /* record number for direct access I/O */
390 __INT_T *bitv, /* same as for ENTF90IO(open_) */
391 __INT_T *iostat) /* same as for ENTF90IO(open_) */
392 {
393 int s = 0;
394
395 __fort_status_init(bitv, iostat);
396 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
397 s = _f90io_ldr_init(unit, rec, bitv, iostat);
398 if (s != 0) {
399 free_gbl();
400 restore_gbl();
401 __fortio_errend03();
402 }
403 return DIST_STATUS_BCST(s);
404 }
405
406 __INT_T
ENTF90IO(LDR_INIT03A,ldr_init03a)407 ENTF90IO(LDR_INIT03A, ldr_init03a)
408 (__INT_T *istat, DCHAR(blank), DCHAR(decimal), DCHAR(pad),
409 DCHAR(round) DCLEN64(blank) DCLEN64(decimal) DCLEN64(pad) DCLEN64(round))
410 {
411 int s = *istat;
412
413 if (s)
414 return DIST_STATUS_BCST(s);
415
416 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC) {
417 if (ISPRESENTC(blank)) {
418 if (__fortio_eq_str(CADR(blank), CLEN(blank), "ZERO")) {
419 gbl->blank_zero = FIO_ZERO;
420 } else if (__fortio_eq_str(CADR(blank), CLEN(blank), "NULL")) {
421 gbl->blank_zero = FIO_NULL;
422 } else
423 s = __fortio_error(FIO_ESPEC);
424 }
425 if (ISPRESENTC(decimal) && s == 0) {
426 if (__fortio_eq_str(CADR(decimal), CLEN(decimal), "COMMA")) {
427 gbl->decimal = FIO_COMMA;
428 } else if (__fortio_eq_str(CADR(decimal), CLEN(decimal), "POINT")) {
429 gbl->decimal = FIO_POINT;
430 } else
431 s = __fortio_error(FIO_ESPEC);
432 }
433 if (ISPRESENTC(pad) && s == 0) {
434 if (__fortio_eq_str(CADR(pad), CLEN(pad), "YES"))
435 gbl->pad = FIO_YES;
436 else if (__fortio_eq_str(CADR(pad), CLEN(pad), "NO"))
437 gbl->pad = FIO_NO;
438 else
439 s = __fortio_error(FIO_ESPEC);
440 }
441 if (ISPRESENTC(round) && s == 0) {
442 if (__fortio_eq_str(CADR(round), CLEN(round), "UP")) {
443 gbl->round = FIO_UP;
444 } else if (__fortio_eq_str(CADR(round), CLEN(round), "DOWN")) {
445 gbl->round = FIO_DOWN;
446 } else if (__fortio_eq_str(CADR(round), CLEN(round), "ZERO")) {
447 gbl->round = FIO_ZERO;
448 } else if (__fortio_eq_str(CADR(round), CLEN(round), "NEAREST")) {
449 gbl->round = FIO_NEAREST;
450 } else if (__fortio_eq_str(CADR(round), CLEN(round), "COMPATIBLE")) {
451 gbl->round = FIO_COMPATIBLE;
452 } else if (__fortio_eq_str(CADR(round), CLEN(round),
453 "PROCESSOR_DEFINED")) {
454 gbl->round = FIO_PROCESSOR_DEFINED;
455 } else
456 s = __fortio_error(FIO_ESPEC);
457 }
458 }
459 if (s != 0) {
460 free_gbl();
461 restore_gbl();
462 __fortio_errend03();
463 }
464 return DIST_STATUS_BCST(s);
465 }
466 /* 32 bit CLEN version */
467 __INT_T
ENTF90IO(LDR_INIT03,ldr_init03)468 ENTF90IO(LDR_INIT03, ldr_init03)
469 (__INT_T *istat, DCHAR(blank), DCHAR(decimal), DCHAR(pad),
470 DCHAR(round) DCLEN(blank) DCLEN(decimal) DCLEN(pad) DCLEN(round))
471 {
472 return ENTF90IO(LDR_INIT03A, ldr_init03a) (istat, CADR(blank), CADR(decimal),
473 CADR(pad), CADR(round), (__CLEN_T)CLEN(blank),
474 (__CLEN_T)CLEN(decimal), (__CLEN_T)CLEN(pad),
475 (__CLEN_T)CLEN(round));
476 }
477
478 __INT_T
ENTCRF90IO(LDR_INIT,ldr_init)479 ENTCRF90IO(LDR_INIT, ldr_init)
480 (__INT_T *unit, /* unit number */
481 __INT_T *rec, /* record number for direct access I/O */
482 __INT_T *bitv, /* same as for ENTF90IO(open_) */
483 __INT_T *iostat) /* same as for ENTF90IO(open_) */
484 {
485 int s = 0;
486 s = _f90io_ldr_init(unit, rec, bitv, iostat);
487 if (s != 0) {
488 free_gbl();
489 restore_gbl();
490 __fortio_errend03();
491 }
492 return s;
493 }
494
495 /* ***********************************************************************/
496 /* list-directed internal file read init */
497 /* ***********************************************************************/
498
499 static int
_f90io_ldr_intern_init(char * cunit,__INT_T * rec_num,__INT_T * bitv,__INT_T * iostat,__CLEN_T cunit_siz)500 _f90io_ldr_intern_init(
501 char *cunit, /* pointer to variable or array to read from */
502 __INT_T *rec_num, /* number of records in internal file.
503 * 0 if the file is an assumed size
504 * character array */
505 __INT_T *bitv, /* same as for ENTF90IO(open_) */
506 __INT_T *iostat, /* same as for ENTF90IO(open_) */
507 __CLEN_T cunit_siz)
508 {
509 save_gbl();
510 __fortio_errinit03(-99, *bitv, iostat, "list-directed read");
511
512 allocate_new_gbl();
513
514 internal_file = TRUE;
515 in_recp = cunit;
516 n_irecs = *rec_num;
517 rec_len = cunit_siz;
518
519 shared_init();
520 return 0;
521 }
522
523 __INT_T
ENTF90IO(LDR_INTERN_INITA,ldr_intern_inita)524 ENTF90IO(LDR_INTERN_INITA, ldr_intern_inita)
525 (DCHAR(cunit), /* pointer to variable or array to read from */
526 __INT_T *rec_num, /* number of records in internal file.
527 * 0 if the file is an assumed size
528 * character array */
529 __INT_T *bitv, /* same as for ENTF90IO(open_) */
530 __INT_T *iostat /* same as for ENTF90IO(open_) */
531 DCLEN64(cunit))
532 {
533 int s = 0;
534
535 __fort_status_init(bitv, iostat);
536 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
537 s = _f90io_ldr_intern_init(CADR(cunit), rec_num, bitv, iostat, CLEN(cunit));
538 return DIST_STATUS_BCST(s);
539 }
540 /* 32 bit CLEN version */
541 __INT_T
ENTF90IO(LDR_INTERN_INIT,ldr_intern_init)542 ENTF90IO(LDR_INTERN_INIT, ldr_intern_init)
543 (DCHAR(cunit), /* pointer to variable or array to read from */
544 __INT_T *rec_num, /* number of records in internal file.
545 * 0 if the file is an assumed size
546 * character array */
547 __INT_T *bitv, /* same as for ENTF90IO(open_) */
548 __INT_T *iostat /* same as for ENTF90IO(open_) */
549 DCLEN(cunit))
550 {
551 return ENTF90IO(LDR_INTERN_INITA, ldr_intern_inita) (CADR(cunit), rec_num,
552 bitv, iostat, (__CLEN_T)CLEN(cunit));
553 }
554
555 __INT_T
ENTCRF90IO(LDR_INTERN_INITA,ldr_intern_inita)556 ENTCRF90IO(LDR_INTERN_INITA, ldr_intern_inita)
557 (DCHAR(cunit), /* pointer to variable or array to read from */
558 __INT_T *rec_num, /* number of records in internal file.
559 * 0 if the file is an assumed size
560 * character array */
561 __INT_T *bitv, /* same as for ENTF90IO(open_) */
562 __INT_T *iostat /* same as for ENTF90IO(open_) */
563 DCLEN64(cunit))
564 {
565 return _f90io_ldr_intern_init(CADR(cunit), rec_num, bitv, iostat, CLEN(cunit));
566 }
567 /* 32 bit CLEN version */
568 __INT_T
ENTCRF90IO(LDR_INTERN_INIT,ldr_intern_init)569 ENTCRF90IO(LDR_INTERN_INIT, ldr_intern_init)
570 (DCHAR(cunit), /* pointer to variable or array to read from */
571 __INT_T *rec_num, /* number of records in internal file.
572 * 0 if the file is an assumed size
573 * character array */
574 __INT_T *bitv, /* same as for ENTF90IO(open_) */
575 __INT_T *iostat /* same as for ENTF90IO(open_) */
576 DCLEN(cunit))
577 {
578 return ENTCRF90IO(LDR_INTERN_INITA, ldr_intern_inita) (CADR(cunit), rec_num,
579 bitv, iostat, (__CLEN_T)CLEN(cunit));
580 }
581
582 __INT_T
ENTF90IO(LDR_INTERN_INITE,ldr_intern_inite)583 ENTF90IO(LDR_INTERN_INITE, ldr_intern_inite)
584 (char **cunit, /* variable containing address to read from */
585 __INT_T *rec_num, /* number of records in internal file.
586 * 0 if the file is an assumed size
587 * character array */
588 __INT_T *bitv, /* same as for ENTF90IO(open_) */
589 __INT_T *iostat, /* same as for ENTF90IO(open_) */
590 __INT_T *len)
591 {
592 /* DECODE initialization */
593 int s = 0;
594
595 __fort_status_init(bitv, iostat);
596 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
597 s = _f90io_ldr_intern_init(*cunit, rec_num, bitv, iostat, *len);
598 return DIST_STATUS_BCST(s);
599 }
600
601 __INT_T
ENTCRF90IO(LDR_INTERN_INITE,ldr_intern_inite)602 ENTCRF90IO(LDR_INTERN_INITE, ldr_intern_inite)
603 (char **cunit, /* variable containing address to read from */
604 __INT_T *rec_num, /* number of records in internal file.
605 * 0 if the file is an assumed size
606 * character array */
607 __INT_T *bitv, /* same as for ENTF90IO(open_) */
608 __INT_T *iostat, /* same as for ENTF90IO(open_) */
609 __INT_T *len)
610 {
611 /* DECODE initialization */
612 return _f90io_ldr_intern_init(*cunit, rec_num, bitv, iostat, *len);
613 }
614
615 static void
shared_init(void)616 shared_init(void)
617 {
618 accessed = FALSE;
619 byte_cnt = 0;
620 repeat_cnt = 0;
621 prev_tkntyp = 0;
622 comma_seen = FALSE; /* read_record sets it TRUE */
623 }
624
625 /* **************************************************************************/
626
627 int
__f90io_ldr(int type,long length,int stride,char * item,__CLEN_T itemlen)628 __f90io_ldr(int type, /* data type (as defined in pghpft.h) */
629 long length, /* # items of type to read */
630 int stride, /* distance in bytes between items */
631 char *item, /* where to transfer data to */
632 __CLEN_T itemlen)
633 {
634 int ret_err = 0; /* return error (for iostat) */
635 long item_num;
636 char *tmpitem;
637
638 if (fioFcbTbls.error) {
639 ret_err = ERR_FLAG;
640 goto ldr_err;
641 }
642 if (fioFcbTbls.eof) {
643 ret_err = EOF_FLAG;
644 goto ldr_err;
645 }
646
647 if (DBGBIT(0x1)) {
648 __io_printf("\n__fortio_ldr: ");
649 __io_printf("item=%p, ", item);
650 __io_printf("type=%d, ", type);
651 __io_printf("length=%ld, ", length);
652 __io_printf("stride=%d\n", stride);
653 }
654
655 if (length <= 0)
656 /* no items to read */
657 return 0;
658
659 if (prev_tkntyp == TK_SLASH)
660 return 0;
661 if (byte_cnt == 0 && (ret_err = read_record()) != 0) {
662 ret_err = __fortio_error(ret_err);
663 goto ldr_err;
664 }
665
666 /* main loop is driven by number (length) of items to be read */
667
668 tmpitem = item;
669 gbl_dtype = type;
670 for (item_num = 0; item_num < length; item_num++, tmpitem += stride) {
671 get_token();
672 if (tkntyp == TK_SLASH)
673 return 0;
674 if (tkntyp == TK_ERROR) {
675 ret_err = __fortio_error(scan_err);
676 goto ldr_err;
677 }
678 if (tkntyp == TK_NULL)
679 continue;
680
681 if (tkntyp == TK_VALS) {
682 tkntyp = TK_VAL;
683 if (gbl_dtype != __STR && gbl_dtype != __NCHAR) {
684 ret_err = __fortio_error(FIO_EERR_DATA_CONVERSION);
685 goto ldr_err;
686 }
687 }
688 scan_err = __fortio_assign(tmpitem, type, itemlen, &tknval);
689 if (scan_err) {
690 ret_err = __fortio_error(scan_err);
691 goto ldr_err;
692 }
693 }
694 return 0;
695
696 ldr_err:
697 free_gbl();
698 restore_gbl();
699 __fortio_errend03();
700 return (ret_err);
701 }
702
703 __INT_T
ENTF90IO(LDRA,ldra)704 ENTF90IO(LDRA, ldra)
705 (__INT_T *type, /* data type (as defined in pghpft.h) */
706 __INT_T *count, /* # items of type to read */
707 __INT_T *stride, /* distance in bytes between items */
708 DCHAR(item) /* where to transfer data to */
709 DCLEN64(item))
710 {
711 int typ;
712 int cnt, cpu, i, ioproc, str;
713 __CLEN_T len;
714 char *adr;
715 int s = 0;
716
717 typ = *type;
718 cnt = *count;
719 str = *stride;
720 adr = CADR(item);
721 len = (typ == __STR) ? CLEN(item) : GET_DIST_SIZE_OF(typ);
722
723 #if defined(DEBUG)
724 if ((str / len) * len != str)
725 __fort_abort("f90io_ldr: stride not a multiple of item length");
726 #endif
727 ioproc = GET_DIST_IOPROC;
728 if (LOCAL_MODE || GET_DIST_LCPU == ioproc)
729 s = __f90io_ldr(typ, cnt, str, adr, len);
730 if (!LOCAL_MODE)
731 DIST_RBCSTL(ioproc, adr, cnt, str / len, typ, len);
732 return DIST_STATUS_BCST(s);
733 }
734 /* 32 bit CLEN version */
735 __INT_T
ENTF90IO(LDR,ldr)736 ENTF90IO(LDR, ldr)
737 (__INT_T *type, /* data type (as defined in pghpft.h) */
738 __INT_T *count, /* # items of type to read */
739 __INT_T *stride, /* distance in bytes between items */
740 DCHAR(item) /* where to transfer data to */
741 DCLEN(item))
742 {
743 return ENTF90IO(LDRA, ldra) (type, count, stride, CADR(item), (__CLEN_T)CLEN(item));
744 }
745
746 /* same as ldr, but item may be array - for ldr, the compiler
747 * scalarizes.
748 */
749 __INT_T
ENTF90IO(LDR_AA,ldr_aa)750 ENTF90IO(LDR_AA, ldr_aa)
751 (__INT_T *type, /* data type (as defined in pghpft.h) */
752 __INT_T *count, /* # items of type to read */
753 __INT_T *stride, /* distance in bytes between items */
754 DCHAR(item) /* where to transfer data to */
755 DCLEN64(item))
756 {
757 int typ;
758 int cnt, cpu, i, ioproc, str;
759 __CLEN_T len;
760 char *adr;
761 int s = 0;
762
763 typ = *type;
764 cnt = *count;
765 str = *stride;
766 adr = CADR(item);
767 len = (typ == __STR) ? CLEN(item) : GET_DIST_SIZE_OF(typ);
768
769 #if defined(DEBUG)
770 if ((str / len) * len != str)
771 __fort_abort("f90io_ldr_a: stride not a multiple of item length");
772 #endif
773 ioproc = GET_DIST_IOPROC;
774 if (LOCAL_MODE || GET_DIST_LCPU == ioproc)
775 s = __f90io_ldr(typ, cnt, str, adr, len);
776 if (!LOCAL_MODE)
777 DIST_RBCSTL(ioproc, adr, cnt, str / len, typ, len);
778 return DIST_STATUS_BCST(s);
779 }
780 /* 32 bit CLEN version */
781 __INT_T
ENTF90IO(LDR_A,ldr_a)782 ENTF90IO(LDR_A, ldr_a)
783 (__INT_T *type, /* data type (as defined in pghpft.h) */
784 __INT_T *count, /* # items of type to read */
785 __INT_T *stride, /* distance in bytes between items */
786 DCHAR(item) /* where to transfer data to */
787 DCLEN(item))
788 {
789 return ENTF90IO(LDR_AA, ldr_aa) (type, count, stride, CADR(item), (__CLEN_T)CLEN(item));
790 }
791
792 __INT_T
ENTF90IO(LDR64_AA,ldr64_aa)793 ENTF90IO(LDR64_AA, ldr64_aa)
794 (__INT_T *type, /* data type (as defined in pghpft.h) */
795 __INT8_T *count, /* # items of type to read */
796 __INT_T *stride, /* distance in bytes between items */
797 DCHAR(item) /* where to transfer data to */
798 DCLEN64(item))
799 {
800 int typ;
801 long cnt;
802 int cpu, i, ioproc, str;
803 __CLEN_T len;
804 char *adr;
805 int s = 0;
806
807 typ = *type;
808 cnt = *count;
809 str = *stride;
810 adr = CADR(item);
811 len = (typ == __STR) ? CLEN(item) : GET_DIST_SIZE_OF(typ);
812
813 #if defined(DEBUG)
814 if ((str / len) * len != str)
815 __fort_abort("f90io_ldr_a: stride not a multiple of item length");
816 #endif
817 ioproc = GET_DIST_IOPROC;
818 if (LOCAL_MODE || GET_DIST_LCPU == ioproc)
819 s = __f90io_ldr(typ, cnt, str, adr, len);
820 if (!LOCAL_MODE)
821 DIST_RBCSTL(ioproc, adr, cnt, str / len, typ, len);
822 return DIST_STATUS_BCST(s);
823 }
824 /* 32 bit CLEN version */
825 __INT_T
ENTF90IO(LDR64_A,ldr64_a)826 ENTF90IO(LDR64_A, ldr64_a)
827 (__INT_T *type, /* data type (as defined in pghpft.h) */
828 __INT8_T *count, /* # items of type to read */
829 __INT_T *stride, /* distance in bytes between items */
830 DCHAR(item) /* where to transfer data to */
831 DCLEN(item))
832 {
833 return ENTF90IO(LDR64_AA, ldr64_aa) (type, count, stride, CADR(item),
834 (__CLEN_T)CLEN(item));
835 }
836
837 __INT_T
ENTCRF90IO(LDRA,ldra)838 ENTCRF90IO(LDRA, ldra)
839 (__INT_T *type, /* data type (as defined in pghpft.h) */
840 __INT_T *count, /* # items of type to read */
841 __INT_T *stride, /* distance in bytes between items */
842 DCHAR(item) /* where to transfer data to */
843 DCLEN64(item))
844 {
845 int typ;
846 int cnt, cpu, i, str;
847 __CLEN_T len;
848 char *adr;
849
850 typ = *type;
851 cnt = *count;
852 str = *stride;
853 adr = CADR(item);
854 len = (typ == __STR) ? CLEN(item) : GET_DIST_SIZE_OF(typ);
855
856 #if defined(DEBUG)
857 if ((str / len) * len != str)
858 __fort_abort("__f90io_ldr: stride not a multiple of item length");
859 #endif
860 return __f90io_ldr(typ, cnt, str, adr, len);
861 }
862 /* 32 bit CLEN version */
863 __INT_T
ENTCRF90IO(LDR,ldr)864 ENTCRF90IO(LDR, ldr)
865 (__INT_T *type, /* data type (as defined in pghpft.h) */
866 __INT_T *count, /* # items of type to read */
867 __INT_T *stride, /* distance in bytes between items */
868 DCHAR(item) /* where to transfer data to */
869 DCLEN(item))
870 {
871 return ENTCRF90IO(LDRA, ldra) (type, count, stride, CADR(item), (__CLEN_T)CLEN(item));
872 }
873
874 /* **************************************************************************/
875 /* *** get_token and support routines *****/
876 /* **************************************************************************/
877
878 #undef BEGINS_NUM
879 #undef ISDELIMITER
880
881 #define BEGINS_NUM(c) (ISDIGIT(c) || (c) == '.')
882 #define ISDELIMITER(c) \
883 ((c) == ',' || (c) == ' ' || (c) == '\t' || (c) == '/' || (c == '\n'))
884
885 static int is_repeat_count(char *);
886
887 static void
get_token()888 get_token()
889 {
890 char ch;
891
892 if (DBGBIT(0x8))
893 __io_printf("get_token enter: repeat_cnt:%d\n", repeat_cnt);
894 if (repeat_cnt) {
895 repeat_cnt--;
896 return;
897 }
898 scan_err = 0;
899 tkntyp = 0;
900 if (gbl_dtype == __STR || gbl_dtype == __NCHAR)
901 /* current item is type character */
902 do {
903 switch (*currc++) {
904 case '\n':
905 /* read another record */
906 if ((scan_err = read_record()) != 0)
907 tkntyp = TK_ERROR;
908 break;
909
910 /* whitespace => delimiters */
911 case ' ':
912 case '\t':
913 break;
914
915 case ';':
916 if (gbl->decimal != FIO_COMMA)
917 break;
918 if (comma_seen) {
919 /* consecutive commas implies null value */
920 tkntyp = TK_NULL;
921 goto multiple_commas;
922 }
923 /* otherwise, it's just a delimiter */
924 comma_seen = TRUE;
925 break;
926 case ',':
927 if (gbl->decimal == FIO_COMMA)
928 break;
929 if (comma_seen) {
930 /* consecutive commas implies null value */
931 tkntyp = TK_NULL;
932 goto multiple_commas;
933 }
934 /* otherwise, it's just a delimiter */
935 comma_seen = TRUE;
936 break;
937
938 case '/':
939 tkntyp = TK_SLASH;
940 break;
941
942 case '0':
943 case '1':
944 case '2':
945 case '3':
946 case '4':
947 case '5':
948 case '6':
949 case '7':
950 case '8':
951 case '9':
952 currc--;
953 if (is_repeat_count(currc)) {
954 int rc;
955 get_number();
956 rc = tknval.val.i;
957 ch = *++currc;
958 if (ISDELIMITER(ch))
959 tkntyp = TK_NULL;
960 else
961 get_token();
962 repeat_cnt = rc - 1;
963 } else
964 get_junk();
965 break;
966
967 case '\'':
968 get_qstr('\'');
969 break;
970
971 case '\"':
972 get_qstr('\"');
973 break;
974
975 default:
976 currc--;
977 get_junk();
978 break;
979 }
980
981 } while (tkntyp == 0); /* end current item is type character */
982 else
983 /* current item is not type character */
984 do {
985 switch (*currc++) {
986 case '\n':
987 /* read another record */
988 if ((scan_err = read_record()) != 0)
989 tkntyp = TK_ERROR;
990 break;
991
992 /* whitespace => delimiters */
993 case ' ':
994 case '\t':
995 break;
996 case ';':
997 if (gbl->decimal != FIO_COMMA)
998 break;
999 if (comma_seen) {
1000 /* consecutive commas implies null value */
1001 tkntyp = TK_NULL;
1002 goto multiple_commas;
1003 }
1004 /* otherwise, it's just a delimiter */
1005 comma_seen = TRUE;
1006 break;
1007
1008 case ',':
1009 if (gbl->decimal == FIO_COMMA) {
1010 ch = *currc;
1011 if (ISDIGIT(ch)) {
1012 currc--;
1013 get_number();
1014 break;
1015 }
1016 /* check for logical */
1017 if (ch == 'T' || ch == 't') {
1018 currc++;
1019 goto have_true;
1020 }
1021 if (ch == 'F' || ch == 'f') {
1022 currc++;
1023 goto have_false;
1024 }
1025 currc--;
1026 get_number(); /* VMS extension (only if numeric or log */
1027 break;
1028 } else {
1029 if (comma_seen) {
1030 /* consecutive commas implies null value */
1031 tkntyp = TK_NULL;
1032 goto multiple_commas;
1033 }
1034 /* otherwise, it's just a delimiter */
1035 comma_seen = TRUE;
1036 break;
1037 }
1038
1039 case '/':
1040 tkntyp = TK_SLASH;
1041 break;
1042
1043 case '+':
1044 case '-':
1045 ch = *currc;
1046 if (BEGINS_NUM(ch)) {
1047 currc--;
1048 get_number();
1049 break;
1050 }
1051 /* Could also support NaN here too??? */
1052 if (ch == 'i' || ch == 'I') {
1053 currc--;
1054 get_infinity();
1055 break;
1056 }
1057 currc--;
1058 get_number(); /* VMS extension (only if numeric or log */
1059 break;
1060
1061 case '0':
1062 case '1':
1063 case '2':
1064 case '3':
1065 case '4':
1066 case '5':
1067 case '6':
1068 case '7':
1069 case '8':
1070 case '9':
1071 currc--;
1072 get_number();
1073 /* check if repeat count */
1074 if (tkntyp == TK_VAL && tknval.dtype == __BIGINT && tknval.val.i != 0 &&
1075 *currc == '*') {
1076 int rc;
1077 rc = tknval.val.i;
1078 ch = *++currc;
1079 if (ISDELIMITER(ch))
1080 tkntyp = TK_NULL;
1081 else
1082 get_token();
1083 repeat_cnt = rc - 1;
1084 }
1085 break;
1086
1087 case '.':
1088 ch = *currc;
1089 if (ISDIGIT(ch)) {
1090 currc--;
1091 get_number();
1092 break;
1093 }
1094 /* check for logical */
1095 if (ch == 'T' || ch == 't') {
1096 currc++;
1097 goto have_true;
1098 }
1099 if (ch == 'F' || ch == 'f') {
1100 currc++;
1101 goto have_false;
1102 }
1103 currc--;
1104 get_number(); /* VMS extension (only if numeric or log */
1105 break;
1106
1107 case '(':
1108 get_cmplx();
1109 break;
1110
1111 case 't':
1112 case 'T':
1113 have_true:
1114 tknval.val.i = FTN_TRUE;
1115 goto have_logical;
1116
1117 case 'f':
1118 case 'F':
1119 have_false:
1120 tknval.val.i = FTN_FALSE;
1121
1122 have_logical:
1123 while (TRUE) {
1124 ch = *currc;
1125 if (ISDELIMITER(ch))
1126 break;
1127 ++currc;
1128 }
1129 tkntyp = TK_VAL;
1130 tknval.dtype = __BIGLOG;
1131 break;
1132
1133 case '\'':
1134 get_qstr('\'');
1135 break;
1136
1137 case '\"':
1138 get_qstr('\"');
1139 break;
1140
1141 case 'e':
1142 case 'E':
1143 case 'd':
1144 case 'D':
1145 currc--;
1146 get_number(); /* VMS extension (only if numeric or log */
1147 break;
1148
1149 case 'i':
1150 case 'I':
1151 currc--;
1152 get_infinity();
1153 break;
1154 case 'n':
1155 case 'N':
1156 currc--;
1157 get_nan();
1158 break;
1159
1160 default:
1161 tkntyp = TK_ERROR;
1162 scan_err = FIO_ELEX; /* unknown token */
1163 break;
1164 }
1165
1166 } while (tkntyp == 0); /* end current item is not type character */
1167 /*
1168 * if a value is found, we did not see a comma.
1169 */
1170 comma_seen = FALSE;
1171
1172 multiple_commas:
1173
1174 prev_tkntyp = tkntyp;
1175 if (DBGBIT(0x8))
1176 __io_printf("get_token: new token %d\n", tkntyp);
1177 }
1178
1179 /** \brief Given that a string begins with a digit, is it a repeat count?
1180 *
1181 * If a string of digits is immediately followed by '*', then the
1182 * digit string is a repeat count.
1183 */
1184 static int
is_repeat_count(char * p)1185 is_repeat_count(char *p)
1186 {
1187 char *q;
1188 char ch;
1189
1190 q = p + 1;
1191 while (TRUE) {
1192 ch = *q;
1193 if (!ISDIGIT(ch))
1194 break;
1195 q++;
1196 }
1197 if ((q - p) == 1 && *p == '0')
1198 return 0;
1199 if (ch == '*')
1200 return 1;
1201 return 0;
1202 }
1203
1204 /** \brief
1205 * Extract integer, real, or double precision constant token:
1206 */
1207 static void
get_number(void)1208 get_number(void)
1209 {
1210 int ret_err;
1211 int type;
1212 union {
1213 __BIGINT_T i;
1214 __BIGREAL_T d;
1215 __INT8_T i8v;
1216 } val;
1217 int len;
1218
1219 if (gbl->decimal == FIO_COMMA)
1220 ret_err = __fortio_getnum(currc, &type, &val, &len, TRUE);
1221 else
1222 ret_err = __fortio_getnum(currc, &type, &val, &len, FALSE);
1223 currc += len;
1224 if (ret_err) {
1225 scan_err = ret_err;
1226 tkntyp = TK_ERROR;
1227 return;
1228 }
1229 if (type == 1) {
1230 tknval.dtype = __BIGREAL;
1231 tknval.val.d = val.d;
1232 }
1233 else if (type == 2) {
1234 tknval.dtype = __INT8;
1235 tknval.val.i8v = val.i8v;
1236 }
1237 else if (type == 3) {
1238 /* Degenerate VMS REAL, allow integer value 0 to be returned only if
1239 * a REAL type was expected. Otherwise its an error.
1240 */
1241 if (!REAL_ALLOWED(gbl_dtype)) {
1242 scan_err = FIO_EERR_DATA_CONVERSION;
1243 tkntyp = TK_ERROR;
1244 return;
1245 }
1246 tknval.dtype = __BIGINT;
1247 tknval.val.i = val.i;
1248 } else {
1249 tknval.dtype = __BIGINT;
1250 tknval.val.i = val.i;
1251 }
1252 tkntyp = TK_VAL;
1253
1254 }
1255
1256 /** \brief
1257 * A left paren has been found. Create a complex constant.
1258 * currc locates character after '('.
1259 */
1260 static void
get_cmplx(void)1261 get_cmplx(void)
1262 {
1263 static AVAL cmplx[2] = {{__BIGREAL, {0}}, {__BIGREAL, {0}}};
1264
1265 get_token();
1266 if (tkntyp != TK_VAL || tknval.dtype == __STR || tknval.dtype == __NCHAR)
1267 goto cmplx_err;
1268 cmplx[0].val.d = to_bigreal(&tknval);
1269 if (gbl->decimal == FIO_COMMA) {
1270 if (!find_char(';')) /* leaves ptr at after ';' */
1271 goto cmplx_err;
1272 } else {
1273 if (!find_char(',')) /* leaves ptr at after ',' */
1274 goto cmplx_err;
1275 }
1276 get_token();
1277 if (tkntyp != TK_VAL || tknval.dtype == __STR || tknval.dtype == __NCHAR)
1278 goto cmplx_err;
1279 cmplx[1].val.d = to_bigreal(&tknval);
1280 tknval.dtype = __BIGCPLX;
1281 tknval.val.cmplx = cmplx;
1282 if (!find_char(')'))
1283 goto cmplx_err;
1284 tkntyp = TK_VAL;
1285 return;
1286
1287 cmplx_err:
1288 scan_err = FIO_ELEX; /* unknown token */
1289 tkntyp = TK_ERROR;
1290 }
1291
1292 /** \brief
1293 * An 'I' has been found. Is it an infinity? Valid are +inf, -inf, inf,
1294 * +infinity, -infinity, infinity
1295 */
1296 static void
get_infinity(void)1297 get_infinity(void)
1298 {
1299 union ieee ieee_v;
1300 char c;
1301 c = *currc;
1302 ieee_v.i[0] = 0x0;
1303 ieee_v.i[1] = 0x7ff00000;
1304 if (c == '-') {
1305 ieee_v.v.s = 1;
1306 currc++;
1307 } else if (c == '+') {
1308 ieee_v.v.s = 0;
1309 currc++;
1310 } else {
1311 ieee_v.v.s = 0;
1312 }
1313 c = *currc++;
1314 if (c == 'i' || c == 'I') {
1315 c = *currc++;
1316 if (c == 'n' || c == 'N') {
1317 c = *currc++;
1318 if (c == 'f' || c == 'F') {
1319 c = *currc++;
1320 if (ISDELIMITER(c)) {
1321 currc--;
1322 tknval.dtype = __BIGREAL;
1323 tknval.val.d = ieee_v.d;
1324 tkntyp = TK_VAL;
1325 return;
1326 }
1327 if (c == 'i' || c == 'I') {
1328 c = *currc++;
1329 if (c == 'n' || c == 'N') {
1330 c = *currc++;
1331 if (c == 'i' || c == 'I') {
1332 c = *currc++;
1333 if (c == 't' || c == 'T') {
1334 c = *currc++;
1335 if (c == 'y' || c == 'Y') {
1336 c = *currc;
1337 if (ISDELIMITER(c)) {
1338 tknval.dtype = __BIGREAL;
1339 tknval.val.d = ieee_v.d;
1340 tkntyp = TK_VAL;
1341 return;
1342 }
1343 }
1344 }
1345 }
1346 }
1347 }
1348 }
1349 }
1350 }
1351 scan_err = FIO_ELEX; /* unknown token */
1352 tkntyp = TK_ERROR;
1353 }
1354
1355 /** \brief
1356 * An 'N' has been found. Is it a NaN? Valid are nan and nan(ddd...)
1357 */
1358 static void
get_nan(void)1359 get_nan(void)
1360 {
1361 union ieee ieee_v;
1362 char c;
1363 unsigned int nval, ntval, nshplaces;
1364 c = *currc++;
1365 ieee_v.i[0] = 0x0;
1366 ieee_v.i[1] = 0x7ff00000;
1367 if (c == 'n' || c == 'N') {
1368 c = *currc++;
1369 if (c == 'a' || c == 'A') {
1370 c = *currc++;
1371 if (c == 'n' || c == 'N') {
1372 c = *currc++;
1373 if (c == '(') {
1374 ieee_v.i[0] = 0x0;
1375 ieee_v.v.hm = 0x0;
1376 ieee_v.v.e = 2047;
1377 ntval = 0;
1378 c = *currc++;
1379 nshplaces = 48;
1380 while (TRUE) {
1381 if ((c >= '0') && (c <= '9'))
1382 nval = c - '0';
1383 else if ((c >= 'a') && (c <= 'f'))
1384 nval = c - 'a' + 10;
1385 else if ((c >= 'A') && (c <= 'F'))
1386 nval = c - 'A' + 10;
1387 else if (c == ')')
1388 break;
1389 else
1390 goto conv_nan_error;
1391 if (nshplaces > 28)
1392 ieee_v.v.hm |= nval << (nshplaces - 32);
1393 else
1394 ieee_v.v.lm |= nval << nshplaces;
1395 ntval += nval;
1396 c = *currc++;
1397 if (nshplaces)
1398 nshplaces -= 4;
1399 }
1400 if (c == ')') {
1401 /* Set this quiet */
1402 if (ntval == 0)
1403 ieee_v.v.hm |= 0x80000;
1404 c = *currc;
1405 }
1406 } else {
1407 ieee_v.v.hm |= 0x80000; /* quiet */
1408 }
1409 if (ISDELIMITER(c)) {
1410 tknval.dtype = __BIGREAL;
1411 tknval.val.d = ieee_v.d;
1412 tkntyp = TK_VAL;
1413 return;
1414 }
1415 }
1416 }
1417 }
1418 conv_nan_error:
1419 scan_err = FIO_ELEX; /* unknown token */
1420 tkntyp = TK_ERROR;
1421 }
1422
1423 static __BIGREAL_T
to_bigreal(AVAL * valp)1424 to_bigreal(AVAL *valp)
1425 {
1426 if (valp->dtype == __BIGREAL)
1427 return valp->val.d;
1428 if (valp->dtype == __INT8 || valp->dtype == __LOG8)
1429 return valp->val.d;
1430 assert(valp->dtype == __BIGINT || valp->dtype == __BIGLOG);
1431 return (__BIGREAL_T)valp->val.i;
1432 }
1433
1434 /* stuff for returning a string token */
1435
1436 static char chval[128];
1437 static int chval_size = sizeof(chval);
1438 static char *chvalp = chval;
1439
1440 /** \brief
1441 * A quote has been seen (' or "). Create a character constant.
1442 */
1443 static void
get_qstr(int quote)1444 get_qstr(int quote)
1445 {
1446 int len;
1447 char ch;
1448
1449 len = 0;
1450 while (TRUE) {
1451 ch = *currc++;
1452 if (ch == '\n') {
1453 if (read_record()) {
1454 scan_err = FIO_ELEX; /* unknown token */
1455 tkntyp = TK_ERROR;
1456 return;
1457 }
1458 continue;
1459 }
1460 if (ch == quote) {
1461 if (*currc != quote)
1462 break;
1463 currc++;
1464 }
1465 if (len >= chval_size) {
1466 chval_size += 128;
1467 if (chvalp == chval) {
1468 chvalp = malloc(chval_size);
1469 (void) memcpy(chvalp, chval, len);
1470 } else
1471 chvalp = realloc(chvalp, chval_size);
1472 }
1473 chvalp[len++] = ch;
1474 }
1475 /* ************** HAND CHECK ****************/
1476 tknval.val.c.len = len;
1477 tknval.val.c.str = chvalp;
1478 tknval.dtype = gbl_dtype;
1479 tkntyp = TK_VALS;
1480 }
1481
1482 /** \brief
1483 * Non-quoted strings in list-directed input.
1484 */
1485 static void
get_junk(void)1486 get_junk(void)
1487 {
1488 int len;
1489 char ch;
1490
1491 len = 0;
1492 while (TRUE) {
1493 ch = *currc++;
1494 if (ch == '\\' && *currc == '\n') {
1495 if (read_record()) {
1496 scan_err = FIO_ELEX; /* unknown token */
1497 tkntyp = TK_ERROR;
1498 return;
1499 }
1500 continue;
1501 }
1502 if (ISDELIMITER(ch)) {
1503 currc--;
1504 break;
1505 }
1506 if (len >= chval_size) {
1507 chval_size += 128;
1508 if (chvalp == chval) {
1509 chvalp = malloc(chval_size);
1510 (void) memcpy(chvalp, chval, len);
1511 } else
1512 chvalp = realloc(chvalp, chval_size);
1513 }
1514 chvalp[len++] = ch;
1515 }
1516 /* ************** HAND CHECK ****************/
1517 tknval.val.c.len = len;
1518 tknval.val.c.str = chvalp;
1519 tknval.dtype = gbl_dtype;
1520 tkntyp = TK_VAL;
1521 }
1522
1523 static bool
skip_spaces(void)1524 skip_spaces(void)
1525 /* eat spaces, read new record if necessary */
1526 {
1527 while (TRUE) {
1528 while (*currc == ' ' || *currc == '\t')
1529 currc++;
1530 if (*currc != '\n')
1531 break;
1532 scan_err = read_record();
1533 if (scan_err)
1534 return FALSE;
1535 }
1536 return TRUE;
1537 }
1538
1539 static bool
find_char(int ch)1540 find_char(int ch)
1541 /* find a given character, skip leading spaces, read new record if necessary */
1542 {
1543 if (!skip_spaces())
1544 return FALSE;
1545 if (*currc == ch) {
1546 currc++;
1547 return TRUE;
1548 }
1549 return FALSE;
1550 }
1551
1552 /* ********************/
1553 /* read support */
1554 /* ********************/
1555
1556 static int
read_record(void)1557 read_record(void)
1558 {
1559 if (internal_file) {
1560 if (n_irecs == 0)
1561 return read_record_internal();
1562 if (accessed)
1563 in_recp += rec_len;
1564 n_irecs--;
1565
1566 byte_cnt = rec_len;
1567 if (byte_cnt >= rbuf_size)
1568 (void) alloc_rbuf(byte_cnt, FALSE);
1569 (void) memcpy(rbufp, in_recp, byte_cnt);
1570 accessed = TRUE;
1571 } else {
1572 if (fcb->pread) {
1573 int ch;
1574 char *p, *f;
1575
1576 p = rbufp;
1577 f = fcb->pread;
1578 byte_cnt = 0;
1579
1580 while (TRUE) {
1581 if (byte_cnt >= rbuf_size)
1582 p = alloc_rbuf(byte_cnt, TRUE);
1583 ch = *f++;
1584 if (ch == EOF) {
1585 if (__io_feof(fcb->fp)) {
1586 if (byte_cnt)
1587 break;
1588 return FIO_EEOF;
1589 }
1590 return __io_errno();
1591 }
1592 if (ch == '\r' && EOR_CRLF) {
1593 ch = *f++;
1594 if (ch == '\n')
1595 break;
1596 --f;
1597 ch = '\r';
1598 }
1599 if (ch == '\n')
1600 break;
1601 byte_cnt++;
1602 *p++ = ch;
1603 }
1604 fcb->pread = 0;
1605 } else {
1606
1607 fcb->nextrec++;
1608 if (fcb->acc == FIO_DIRECT) {
1609 byte_cnt = rec_len;
1610 if (byte_cnt >= rbuf_size)
1611 (void) alloc_rbuf(byte_cnt, FALSE);
1612 if (fcb->nextrec > fcb->maxrec + 1)
1613 return FIO_EDREAD; /* attempt to read non-existent rec */
1614 if (__io_fread(rbufp, byte_cnt, 1, fcb->fp) != 1)
1615 return __io_errno();
1616 } else {
1617 /* sequential read */
1618 int ch;
1619 char *p;
1620
1621 p = rbufp;
1622 byte_cnt = 0;
1623
1624 while (TRUE) {
1625 if (byte_cnt >= rbuf_size)
1626 p = alloc_rbuf(byte_cnt, TRUE);
1627 ch = __io_fgetc(fcb->fp);
1628 if (ch == EOF) {
1629 if (__io_feof(fcb->fp)) {
1630 if (byte_cnt)
1631 break;
1632 return FIO_EEOF;
1633 }
1634 return __io_errno();
1635 }
1636 if (ch == '\r' && EOR_CRLF) {
1637 ch = __io_fgetc(fcb->fp);
1638 if (ch == '\n')
1639 break;
1640 __io_ungetc(ch, fcb->fp);
1641 ch = '\r';
1642 }
1643 if (ch == '\n')
1644 break;
1645 byte_cnt++;
1646 *p++ = ch;
1647 }
1648 }
1649 }
1650 }
1651 rbufp[byte_cnt] = '\n';
1652 if (!internal_file) {
1653 if (byte_cnt > 1)
1654 fcb->pback = &(rbufp[byte_cnt - 1]);
1655 else
1656 fcb->pback = &(rbufp[byte_cnt]);
1657 }
1658 currc = rbufp;
1659 comma_seen = TRUE;
1660 if (DBGBIT(0x2)) {
1661 __io_printf("read_rec: byte_cnt %d\n", byte_cnt);
1662 __io_printf("#%.*s#\n", byte_cnt, rbufp);
1663 }
1664
1665 return 0;
1666 }
1667
1668 static char *
alloc_rbuf(int size,bool copy)1669 alloc_rbuf(int size, bool copy)
1670 {
1671 int old_size;
1672
1673 old_size = rbuf_size;
1674 rbuf_size = size + 128;
1675 if (rbufp == rbuf) {
1676 rbufp = malloc(rbuf_size);
1677 if (copy)
1678 (void) memcpy(rbufp, rbuf, old_size);
1679 } else
1680 rbufp = realloc(rbufp, rbuf_size);
1681 return rbufp + size;
1682 }
1683
1684 static int
skip_record(void)1685 skip_record(void)
1686 {
1687 if (internal_file) {
1688 if (n_irecs == 0)
1689 return FIO_EEOF;
1690 n_irecs--;
1691 return 0;
1692 }
1693
1694 /* external file: check for errors */
1695 if (gbl->same_fcb) /* don't check for recursive io */
1696 return 0;
1697
1698 fcb->nextrec++;
1699 if (fcb->acc == FIO_DIRECT) {
1700 if (fcb->nextrec > fcb->maxrec + 1)
1701 return FIO_EDREAD; /* attempt to read non-existent rec */
1702 if (__io_fseek(fcb->fp, (seekoffx_t)rec_len, SEEK_CUR) != 0)
1703 return __io_errno();
1704 fcb->coherent = 0;
1705 } else {
1706 /* sequential read */
1707 int ch;
1708 int bt = 0;
1709
1710 while (TRUE) {
1711 ch = __io_fgetc(fcb->fp);
1712 if (ch == EOF) {
1713 if (__io_feof(fcb->fp)) {
1714 if (bt)
1715 break;
1716 return FIO_EEOF;
1717 }
1718 return __io_errno();
1719 }
1720 #if defined(WINNT)
1721 if (ch == '\r') {
1722 ch = __io_fgetc(fcb->fp);
1723 if (ch == '\n')
1724 break;
1725 __io_ungetc(ch, fcb->fp);
1726 ch = '\r';
1727 }
1728 #endif
1729 if (ch == '\n')
1730 break;
1731 bt++;
1732 }
1733 }
1734
1735 return 0;
1736 }
1737
1738 /* **************************************************************************/
1739
1740 static int
_f90io_ldr_end(void)1741 _f90io_ldr_end(void)
1742 {
1743 int ret_err = 0;
1744
1745 if (DBGBIT(0x4))
1746 __io_printf("ENTER: f90io_ldr_end\n");
1747
1748 if (fioFcbTbls.error) {
1749 return ERR_FLAG;
1750 }
1751 if (fioFcbTbls.eof) {
1752 return EOF_FLAG;
1753 }
1754 if (gbl->same_fcb)
1755 return 0;
1756
1757 if (byte_cnt == 0)
1758 ret_err = skip_record();
1759 if (ret_err)
1760 ret_err = __fortio_error(ret_err);
1761 return ret_err;
1762 }
1763
1764 __INT_T
ENTF90IO(LDR_END,ldr_end)1765 ENTF90IO(LDR_END, ldr_end)()
1766 {
1767 int s = 0;
1768
1769 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
1770 s = _f90io_ldr_end();
1771
1772 save_samefcb();
1773 free_gbl();
1774 restore_gbl();
1775 __fortio_errend03();
1776
1777 return DIST_STATUS_BCST(s);
1778 }
1779
1780 __INT_T
ENTCRF90IO(LDR_END,ldr_end)1781 ENTCRF90IO(LDR_END, ldr_end)()
1782 {
1783 int s = 0;
1784
1785 s = _f90io_ldr_end();
1786
1787 save_samefcb();
1788 free_gbl();
1789 restore_gbl();
1790 __fortio_errend03();
1791 return s;
1792 }
1793