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 Implement namelist read statement.
22 */
23
24 #include "global.h"
25 #include "format.h"
26 #include "nml.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 #define MAX_TOKEN_LEN 300
35
36 #define TK_IDENT 1
37 #define TK_COMMA 2
38 #define TK_EQUALS 3
39 #define TK_CONST 4
40 #define TK_ENDGROUP 5
41 #define TK_SKIP 6
42 #define TK_LPAREN 7
43 #define TK_RPAREN 8
44 #define TK_COLON 9
45 #define TK_PERCENT 10
46 #define TK_SEMICOLON 11
47
48 #define IS_SPACE(c) ((c) == ' ' || (c) == '\n' || (c) == '\t' || (c) == '\r')
49
50 #define VRF_ID 0
51 #define VRF_ELEMENT 1
52 #define VRF_SECTION 2
53 #define VRF_MEMBER 3
54
55 static TRI tri;
56
57 /* Record the presence of a substring in a reference */
58 static struct {
59 bool present;
60 __BIGINT_T start;
61 __BIGINT_T end;
62 } substring;
63
64 #define TRI_SECT(i, j) tri.base[(i) + (j)]
65 #define TRI_LWB(i, j) TRI_SECT(i, j).lwb
66 #define TRI_UPB(i, j) TRI_SECT(i, j).upb
67 #define TRI_STRIDE(i, j) TRI_SECT(i, j).stride
68
69 typedef struct {
70 int type; /* VRF_... */
71 int subscript; /* nonzero, locates a set of TRIPLES */
72 NML_DESC *descp;
73 char *addr;
74 } VRF;
75
76 static struct {
77 int size;
78 int avl;
79 VRF *base;
80 } vrf;
81
82 static int vrf_cur;
83
84 #define VRF_TYPE(i) vrf.base[i].type
85 #define VRF_SUBSCRIPT(i) vrf.base[i].subscript
86 #define VRF_DESCP(i) vrf.base[i].descp
87 #define VRF_ADDR(i) vrf.base[i].addr
88
89 static FIO_FCB *f;
90 static bool accessed; /* file has been read */
91 static int byte_cnt; /* number of bytes read */
92 static int n_irecs; /* number of internal file records */
93 static bool internal_file;
94 static int rec_len;
95 static int token;
96 static char token_buff[MAX_TOKEN_LEN + 1];
97 static INT tokenval;
98 static int live_token;
99 static AVAL constval;
100 static AVAL cmplxval[2];
101 static bool lparen_is_token;
102 static bool comma_is_token;
103 static FILE *gblfp;
104
105 #define RBUF_SIZE 256
106 static char rbuf[RBUF_SIZE + 1];
107 static unsigned rbuf_size = RBUF_SIZE;
108
109 static char *rbufp = rbuf; /* ptr to read buffer */
110 static char *currc; /* current pointer in buffer */
111
112 static char *in_recp; /* internal i/o record (user's space) */
113
114 typedef struct {
115 short blank_zero; /* FIO_ ZERO or NULL */
116 short pad; /* FIO_ YES or NULL */
117 short decimal; /* COMMA, POINT, NONE */
118 short round; /* FIO_ UP, DOWN, ZERO, NEAREST, COMPATIBLE,
119 * PROCESSOR_DEFINED, NONE
120 */
121 int same_fcb_idx;
122 FIO_FCB *gblfp;
123 FIO_FCB *f;
124 char *currc;
125 char *rbufp;
126 char rbuf[RBUF_SIZE + 1];
127 char *in_recp;
128 bool comman_is_token;
129 bool lparen_is_token;
130 int live_token;
131 INT tokenval;
132 char token_buff[MAX_TOKEN_LEN + 1];
133 int rec_len;
134 bool internal_file;
135 int token;
136 int n_irecs;
137 int byte_cnt;
138 bool accessed;
139 int vrf_cur;
140 __INT_T *unit;
141 __INT_T *iostat;
142
143 } G;
144
145 static G static_gbl[GBL_SIZE];
146 static G *gbl = &static_gbl[0];
147 static G *gbl_head = &static_gbl[0];
148 static int gbl_avl = 0;
149 static int gbl_size = GBL_SIZE;
150
151 static void shared_init(void);
152 static NML_DESC *skip_to_next(NML_DESC *);
153 static NML_DESC *skip_dtio_datainit(NML_DESC *);
154 static int find_group(char *, int);
155 static int get_token(void);
156 static int do_parse(NML_GROUP *);
157 static int parse_ref(NML_DESC *);
158 static int add_vrf(int, NML_DESC *);
159 static int I8(parse_subscripts)(NML_DESC *);
160 static int I8(parse_substring)(NML_DESC *);
161 static int add_triple(int);
162 static int assign_values(void);
163 static int eval_ptr(int, char *);
164 static void I8(fillup_sb)(int, NML_DESC *, char *);
165 static int dtio_read_scalar(NML_DESC *, char *);
166
167 static bool comma_live;
168 static int eval(int, char *);
169 static int I8(eval_dtio_sb)(int d);
170 static int assign(NML_DESC *, char *, char **, bool, bool);
171 static int dtio_assign(NML_DESC *, char *, char **, bool, bool);
172
173 #undef GET_TOKEN
174 #define GET_TOKEN(i) \
175 if ((i = get_token())) \
176 return i
177
178 #undef NML_ERROR
179 #define NML_ERROR(e) (__fortio_error(e))
180
181 static int read_record(void);
182 static char *alloc_rbuf(int, bool);
183 static SB sb;
184
185 /* ------------------------------------------------------------------- */
186
187 /** \param unit unit number
188 * \param rec record number for direct access I/O; rec not used, but
189 * JUST IN CASE
190 * \param bitv same as for ENTF90IO(open_)
191 * \param iostat same as for ENTF90IO(open_)
192 */
193 static int
_f90io_nmlr_init(__INT_T * unit,__INT_T * rec,__INT_T * bitv,__INT_T * iostat)194 _f90io_nmlr_init(__INT_T *unit,
195 __INT_T *rec,
196 __INT_T *bitv,
197 __INT_T *iostat)
198 {
199 __fortio_errinit03(*unit, *bitv, iostat, "namelist read");
200
201 /* ------- perform error checking and initialization of unit: */
202
203 f = __fortio_rwinit(*unit, FIO_FORMATTED, rec, 0 /*read*/);
204 if (f == NULL) {
205 if (fioFcbTbls.eof)
206 return EOF_FLAG;
207 /* TBD - does there need to be fioFcbTbls.eor */
208 return ERR_FLAG;
209 }
210
211 f->skip = 0;
212 gblfp = f->fp;
213 internal_file = FALSE;
214 gbl->decimal = f->decimal;
215 gbl->unit = unit;
216 gbl->iostat = iostat;
217
218 shared_init();
219 return 0;
220 }
221
222 static void
shared_init(void)223 shared_init(void)
224 {
225 accessed = FALSE;
226 byte_cnt = 0;
227 }
228
229 /** \brief
230 * Initialize for namelist read to an external file
231 *
232 * \param unit - unit number
233 * \param rec - record number for direct access I/O; not used, but JUST IN CASE
234 * \param bitv - same as for ENTF90IO(open_)
235 * \param iostat - same as for ENTF90IO(open_)
236 */
237 int
ENTF90IO(NMLR_INIT,nmlr_init)238 ENTF90IO(NMLR_INIT, nmlr_init)(__INT_T *unit, __INT_T *rec, __INT_T *bitv,
239 __INT_T *iostat)
240 {
241 int s = 0;
242
243 __fort_status_init(bitv, iostat);
244 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
245 s = _f90io_nmlr_init(unit, rec, bitv, iostat);
246 return DIST_STATUS_BCST(s);
247 }
248
249 int
ENTF90IO(NMLR_INIT03A,nmlr_init03a)250 ENTF90IO(NMLR_INIT03A, nmlr_init03a)(__INT_T *istat, DCHAR(blank),
251 DCHAR(decimal), DCHAR(pad),
252 DCHAR(round) DCLEN64(blank) DCLEN64(decimal)
253 DCLEN64(pad) DCLEN64(round))
254 {
255 int s = *istat;
256
257 if (s)
258 return DIST_STATUS_BCST(s);
259
260 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC) {
261 if (ISPRESENTC(blank)) {
262 if (__fortio_eq_str(CADR(blank), CLEN(blank), "ZERO")) {
263 gbl->blank_zero = FIO_ZERO;
264 } else if (__fortio_eq_str(CADR(blank), CLEN(blank), "NULL")) {
265 gbl->blank_zero = FIO_NULL;
266 } else
267 s = __fortio_error(FIO_ESPEC);
268 }
269 if (ISPRESENTC(decimal)) {
270 if (__fortio_eq_str(CADR(decimal), CLEN(decimal), "COMMA")) {
271 gbl->decimal = FIO_COMMA;
272 } else if (__fortio_eq_str(CADR(decimal), CLEN(decimal), "POINT")) {
273 gbl->decimal = FIO_POINT;
274 } else
275 s = __fortio_error(FIO_ESPEC);
276 }
277 if (ISPRESENTC(pad)) {
278 if (__fortio_eq_str(CADR(pad), CLEN(pad), "YES"))
279 gbl->pad = FIO_YES;
280 else if (__fortio_eq_str(CADR(pad), CLEN(pad), "NO"))
281 gbl->pad = FIO_NO;
282 else
283 return __fortio_error(FIO_ESPEC);
284 }
285 if (ISPRESENTC(round)) {
286 if (__fortio_eq_str(CADR(round), CLEN(round), "UP")) {
287 gbl->round = FIO_UP;
288 } else if (__fortio_eq_str(CADR(round), CLEN(round), "DOWN")) {
289 gbl->round = FIO_DOWN;
290 } else if (__fortio_eq_str(CADR(round), CLEN(round), "ZERO")) {
291 gbl->round = FIO_ZERO;
292 } else if (__fortio_eq_str(CADR(round), CLEN(round), "NEAREST")) {
293 gbl->round = FIO_NEAREST;
294 } else if (__fortio_eq_str(CADR(round), CLEN(round), "COMPATIBLE")) {
295 gbl->round = FIO_COMPATIBLE;
296 } else if (__fortio_eq_str(CADR(round), CLEN(round),
297 "PROCESSOR_DEFINED")) {
298 gbl->round = FIO_PROCESSOR_DEFINED;
299 } else
300 s = __fortio_error(FIO_ESPEC);
301 }
302 }
303 return DIST_STATUS_BCST(s);
304 }
305 /* 32 bit CLEN version */
306 int
ENTF90IO(NMLR_INIT03,nmlr_init03)307 ENTF90IO(NMLR_INIT03, nmlr_init03)(__INT_T *istat, DCHAR(blank),
308 DCHAR(decimal), DCHAR(pad),
309 DCHAR(round) DCLEN(blank) DCLEN(decimal)
310 DCLEN(pad) DCLEN(round))
311 {
312 return ENTF90IO(NMLR_INIT03A, nmlr_init03a)(istat, CADR(blank), CADR(decimal),
313 CADR(pad), CADR(round), (__CLEN_T)CLEN(blank),
314 (__CLEN_T)CLEN(decimal), (__CLEN_T)CLEN(pad),
315 (__CLEN_T)CLEN(round));
316 }
317
318 /** \brief
319 *
320 * \param unit unit number
321 * \param rec record number for direct access I/O
322 * \param bitv same as for ENTF90IO(open_)
323 * \param iostat same as for ENTF90IO(open_)
324 */
325 int
ENTCRF90IO(NMLR_INIT,nmlr_init)326 ENTCRF90IO(NMLR_INIT, nmlr_init)(
327 __INT_T *unit,
328 __INT_T *rec,
329 __INT_T *bitv,
330 __INT_T *iostat)
331 {
332 return _f90io_nmlr_init(unit, rec, bitv, iostat);
333 }
334
335 /** \brief
336 *
337 * \param cunit ptr to var or array to read from
338 * \param rec_num number of records in internal file. 0 if the file is an
339 * assumed size character array
340 * \param bitv same as for ENTF90IO(open_)
341 * \param iostat same as for ENTF90IO(open_)
342 * \param cunit_siz size of \p cunit
343 */
344 int
I8(_f90io_nmlr_intern_init)345 I8(_f90io_nmlr_intern_init)( char *cunit,
346 __INT_T *rec_num,
347 __INT_T *bitv,
348 __INT_T *iostat,
349 __CLEN_T cunit_siz)
350 {
351 static FIO_FCB dumfcb;
352
353 __fortio_errinit03(-99, *bitv, iostat, "namelist read");
354
355 f = &dumfcb; /* so the f-> refs don't have to be guarded */
356 internal_file = TRUE;
357 in_recp = cunit;
358 n_irecs = *rec_num;
359 rec_len = cunit_siz;
360
361 shared_init();
362 return 0;
363 }
364
365 /** \brief Internal file namelist read initialization
366 *
367 * \param cunit is a pointer to variable or array to read from
368 * \param rec_num - number of records in internal file; 0 if the file
369 * is an assumed size character array
370 * \param bitv - same as for ENTF90IO(open_)
371 * \param iostat - same as for ENTF90IO(open_)
372 */
373 int
ENTF90IO(LDR_INTERN_INITA,nmlr_intern_inita)374 ENTF90IO(LDR_INTERN_INITA, nmlr_intern_inita)(
375 DCHAR(cunit),
376 __INT_T *rec_num,
377 __INT_T *bitv,
378 __INT_T *iostat
379 DCLEN64(cunit))
380 {
381 int s = 0;
382
383 __fort_status_init(bitv, iostat);
384 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
385 s = I8(_f90io_nmlr_intern_init)(CADR(cunit), rec_num, bitv, iostat,
386 CLEN(cunit));
387 return DIST_STATUS_BCST(s);
388 }
389 /* 32 bit CLEN version */
390 int
ENTF90IO(LDR_INTERN_INIT,nmlr_intern_init)391 ENTF90IO(LDR_INTERN_INIT, nmlr_intern_init)(
392 DCHAR(cunit),
393 __INT_T *rec_num,
394 __INT_T *bitv,
395 __INT_T *iostat
396 DCLEN(cunit))
397 {
398 return ENTF90IO(LDR_INTERN_INITA, nmlr_intern_init)(CADR(cunit), rec_num,
399 bitv, iostat, (__CLEN_T)CLEN(cunit));
400 }
401
402 /** \param rec_num number of records in internal file. 0 if the file is an
403 * assumed size character array
404 * \param bitv same as for ENTF90IO(open_)
405 * \param iostat same as for ENTF90IO(open_)
406 */
407 int
ENTCRF90IO(LDR_INTERN_INITA,nmlr_intern_inita)408 ENTCRF90IO(LDR_INTERN_INITA, nmlr_intern_inita)(
409 DCHAR(cunit),
410 __INT_T *rec_num,
411 __INT_T *bitv,
412 __INT_T *iostat
413 DCLEN64(cunit))
414 {
415 return I8(_f90io_nmlr_intern_init)(CADR(cunit), rec_num, bitv, iostat,
416 CLEN(cunit));
417 }
418 /* 32 bit CLEN version */
419 int
ENTCRF90IO(LDR_INTERN_INIT,nmlr_intern_init)420 ENTCRF90IO(LDR_INTERN_INIT, nmlr_intern_init)(
421 DCHAR(cunit),
422 __INT_T *rec_num,
423 __INT_T *bitv,
424 __INT_T *iostat
425 DCLEN(cunit))
426 {
427 return ENTCRF90IO(LDR_INTERN_INITA, nmlr_intern_inita)(CADR(cunit), rec_num,
428 bitv, iostat, (__CLEN_T)CLEN(cunit));
429 }
430
431 /** \param nmldesc namelist group descriptor */
432 static int
_f90io_nml_read(NML_GROUP * nmldesc)433 _f90io_nml_read(NML_GROUP *nmldesc)
434 {
435 int err;
436
437 /* first check for errors: */
438 if (fioFcbTbls.eof)
439 return EOF_FLAG;
440 if (fioFcbTbls.error)
441 return ERR_FLAG;
442
443 assert(nmldesc);
444
445 err = find_group(nmldesc->group, nmldesc->nlen);
446 if (err != 0)
447 return err; /* error or eof condition */
448
449 /* -------- file is now positioned immediately after group name: */
450
451 live_token = 0;
452 vrf.size = 32;
453 vrf.base = (VRF *)malloc(sizeof(VRF) * vrf.size);
454 tri.size = 32;
455 tri.base = (TRIPLE *)malloc(sizeof(TRIPLE) * tri.size);
456
457 /* at this point we should call a routine that will fill
458 * the lower/upper/stride for array for array pointer/allocatable
459 * nmldesc should contain enough information
460 */
461
462 while (TRUE) { /* loop once for each namelist group item */
463 err = do_parse(nmldesc);
464 if (err == -1) /* end of group token encountered */
465 break;
466 if (err != 0)
467 goto return_err; /* error or end of file */
468 err = assign_values();
469 if (err != 0)
470 goto return_err; /* error or end of file */
471 }
472 err = 0;
473 return_err:
474 free(vrf.base);
475 free(tri.base);
476 return err;
477 }
478
479 /** \brief transfer data to other processes
480 * \param nmldesc namelist group descriptor
481 *
482 */
483 static void
xfer(NML_GROUP * nmldesc)484 xfer(NML_GROUP *nmldesc)
485 {
486 int num_consts;
487 int i;
488 NML_DESC *descp;
489 int pn;
490
491 /* ------ cycle through namelist entities */
492
493 /* point to first descriptor: */
494 descp = (NML_DESC *)((char *)nmldesc + sizeof(NML_GROUP));
495
496 i = 0;
497 while (TRUE) {
498
499 /* count up number of constants ( == 1 unless array): */
500 num_consts = nelems_of(descp);
501
502 /* transfer data */
503
504 pn = (descp->len > 0 ? descp->len * num_consts : num_consts);
505 if (!LOCAL_MODE) {
506 if (descp->type != __DERIVED)
507 DIST_RBCST(GET_DIST_IOPROC, descp->addr, pn, 1, descp->type);
508 else
509 DIST_RBCST(GET_DIST_IOPROC, descp->addr, pn, 1, __STR);
510 }
511
512 i++;
513 if (i >= nmldesc->ndesc)
514 break;
515
516 descp = skip_to_next(descp);
517 }
518 }
519
520 static NML_DESC *
skip_to_next(NML_DESC * descp)521 skip_to_next(NML_DESC *descp)
522 {
523 NML_DESC *next_descp;
524 int k;
525 __POINT_T actual_ndims;
526
527 /* compute number of bytes to add to reach next descriptor: */
528 ACTUAL_NDIMS(actual_ndims);
529 if (actual_ndims >= 0)
530 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
531 else
532 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
533 next_descp = (NML_DESC *)((char *)descp + k);
534
535 if (descp->ndims == -2 || descp->ndims >= MAX_DIM) {
536 return skip_dtio_datainit(next_descp);
537 } else if (descp->type == __DERIVED) {
538 int level = 0;
539 /* skip over all members and the members of any contained
540 * derived types.
541 */
542 while (TRUE) {
543 if (next_descp->nlen) {
544 if (next_descp->type == __DERIVED)
545 level++;
546 } else {
547 next_descp = (NML_DESC *)((char *)next_descp + sizeof(__POINT_T));
548 if (level <= 0)
549 break;
550 level--;
551 continue;
552 }
553 actual_ndims = next_descp->ndims >= MAX_DIM ? next_descp->ndims - 30
554 : next_descp->ndims;
555 if (actual_ndims >= 0) {
556 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
557 } else {
558 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
559 }
560 next_descp = (NML_DESC *)((char *)next_descp + k);
561 }
562 }
563 return next_descp;
564 }
565
566 /** \brief
567 *
568 * \param unit unit number
569 * \param bitv same as for ENTF90IO(open)
570 * \param iostat same as for ENTF90IO(open)
571 * \param nmldesc namelist group descr
572 */
573 int
ENTF90IO(NML_READ,nml_read)574 ENTF90IO(NML_READ, nml_read)( __INT_T *unit,
575 __INT_T *bitv,
576 __INT_T *iostat,
577 NML_GROUP *nmldesc)
578 {
579 int s = 0;
580
581 __fort_status_init(bitv, iostat);
582 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC) {
583 s = _f90io_nmlr_init(unit, 0, bitv, iostat);
584 if (!s)
585 s = _f90io_nml_read(nmldesc);
586 }
587 xfer(nmldesc);
588 return DIST_STATUS_BCST(s);
589 }
590
591 /** \param unit unit number
592 * \param bitv same as for ENTF90IO(open)
593 * \param iostat same as for ENTF90IO(open)
594 * \param nmldesc) namelist group descr
595 */
596 extern int
ENTCRF90IO(NML_READ,nml_read)597 ENTCRF90IO(NML_READ, nml_read)(__INT_T *unit,
598 __INT_T *bitv,
599 __INT_T *iostat,
600 NML_GROUP *nmldesc)
601 {
602 int s;
603
604 s = _f90io_nmlr_init(unit, 0, bitv, iostat);
605 if (!s)
606 s = _f90io_nml_read(nmldesc);
607 return s;
608 }
609
610 /** \brief read a namelist group
611 *
612 * \param nmldesc - namelist group descriptor
613 */
614 int
ENTF90IO(NMLR,nmlr)615 ENTF90IO(NMLR, nmlr)(NML_GROUP *nmldesc)
616 {
617 int s = 0;
618
619 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC) {
620 s = _f90io_nml_read(nmldesc);
621 }
622 xfer(nmldesc);
623 return DIST_STATUS_BCST(s);
624 }
625
626 /** \brief
627 *
628 * \param nmlr namelist group descriptor
629 */
630 int
ENTCRF90IO(NMLR,nmlr)631 ENTCRF90IO(NMLR, nmlr)(NML_GROUP *nmldesc)
632 {
633 int s;
634
635 s = _f90io_nml_read(nmldesc);
636 return s;
637 }
638
639 /* ----------------------------------------------------------------------- */
640
641 /** \brief search file for line which begins with '&<groupname>' */
642 static int
find_group(char * str,int nlen)643 find_group(char *str, int nlen)
644 {
645 int c;
646 char *p;
647 FILE *fp = gblfp;
648 int i;
649 int ret_err;
650
651 while (TRUE) {
652 ret_err = read_record();
653 if (ret_err) {
654 if (ret_err == FIO_EEOF)
655 return __fortio_eoferr(FIO_ENOGROUP);
656 return __fortio_error(ret_err);
657 }
658 while ((c = *currc++) == ' ')
659 ;
660 if (c != '$' && c != '&')
661 continue; /* eat record */
662
663 for (i = 0; i < nlen; i++) { /* compare letters of group name */
664 c = *currc++;
665 if (c >= 'A' && c <= 'Z')
666 c = c + ('a' - 'A');
667 if (str[i] != c)
668 goto eat_record;
669 }
670 c = *currc++;
671 if (IS_SPACE(c)) { /* group name matched */
672 currc--;
673 break;
674 }
675 eat_record:;
676 }
677 return 0;
678 }
679
680 /* ----------------------------------------------------------------- */
681
682 static int
get_token(void)683 get_token(void)
684 {
685 static int recur = 0;
686 int i, c;
687 FILE *fp = gblfp;
688 char delim;
689 int ret_err;
690
691 if (live_token) { /* token exists from previous call to get_token */
692 assert(live_token > 0);
693 live_token--;
694 return 0;
695 }
696
697 /* scan past white space: */
698 again:
699 while (TRUE) {
700 c = *currc++;
701 if (c == '\n') {
702 ret_err = read_record();
703 if (ret_err) {
704 if (ret_err == FIO_EEOF)
705 return __fortio_eoferr(FIO_ENMLEOF);
706 return __fortio_error(ret_err);
707 }
708 continue;
709 }
710 if (IS_SPACE(c))
711 continue;
712 if (c == '!') {
713 /* comment; skip to end of line:*/
714 ret_err = read_record();
715 if (ret_err) {
716 if (ret_err == FIO_EEOF)
717 return __fortio_eoferr(FIO_ENMLEOF);
718 return __fortio_error(ret_err);
719 }
720 continue;
721 }
722 break;
723 }
724
725 /* switch based on first character of token: */
726
727 switch (c) {
728 case 'A':
729 case 'B':
730 case 'C':
731 case 'D':
732 case 'E':
733 case 'F':
734 case 'G':
735 case 'H':
736 case 'I':
737 case 'J':
738 case 'K':
739 case 'L':
740 case 'M':
741 case 'N':
742 case 'O':
743 case 'P':
744 case 'Q':
745 case 'R':
746 case 'S':
747 case 'T':
748 case 'U':
749 case 'V':
750 case 'W':
751 case 'X':
752 case 'Y':
753 case 'Z':
754 c = c + ('a' - 'A');
755 /* fall thru ... */
756
757 case 'a':
758 case 'b':
759 case 'c':
760 case 'd':
761 case 'e':
762 case 'f':
763 case 'g':
764 case 'h':
765 case 'i':
766 case 'j':
767 case 'k':
768 case 'l':
769 case 'm':
770 case 'n':
771 case 'o':
772 case 'p':
773 case 'q':
774 case 'r':
775 case 's':
776 case 't':
777 case 'u':
778 case 'v':
779 case 'w':
780 case 'x':
781 case 'y':
782 case 'z':
783 case '_':
784 for (i = 0; i < MAX_TOKEN_LEN;) { /* copy ident into buffer */
785 token_buff[i] = c;
786 c = *currc++;
787 if (c >= 'A' && c <= 'Z') /* convert to lower case */
788 c = c + ('a' - 'A');
789 i++;
790 if (!((c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '.' ||
791 c == '_' || c == '$'))
792 break;
793 }
794 token_buff[i] = '\0';
795
796 if (token_buff[0] == 't' || token_buff[0] == 'f') {
797 /* determine if this is a logical constant or an identifier: */
798 while (TRUE) {
799 if (c == '=' || c == '(' || c == '%')
800 goto return_ident;
801 if (!IS_SPACE(c))
802 break;
803 if (c == '\n') {
804 ret_err = read_record();
805 if (ret_err) {
806 if (ret_err == FIO_EEOF)
807 return __fortio_eoferr(FIO_ENMLEOF);
808 return __fortio_error(ret_err);
809 }
810 }
811 c = *currc++;
812 }
813
814 /* token is logical constant: */
815 constval.dtype = __BIGLOG;
816 constval.val.i = FTN_FALSE;
817 if (token_buff[0] == 't')
818 constval.val.i = FTN_TRUE;
819 currc--;
820 token = TK_CONST;
821 break;
822 }
823
824 return_ident:
825 currc--;
826 token = TK_IDENT;
827 break;
828
829 case '\'':
830 case '\"':
831 constval.dtype = __STR;
832 charstring_shared:
833 token = TK_CONST; /* string constant */
834 delim = c; /* delim matches first */
835 for (i = 0; i < MAX_TOKEN_LEN;) { /* copy string into buffer */
836 c = *currc++;
837 if (c == delim) {
838 c = *currc++;
839 if (c != delim) {
840 currc--; /* put back char following string */
841 break; /* exit loop */
842 }
843 } else {
844 if (c == '\r' && EOR_CRLF) {
845 c = *currc++;
846 if (c != '\n') {
847 currc--;
848 c = '\r';
849 }
850 }
851 if (c == '\n') {
852 /*
853 * do not discard 1st character of a rew record;
854 * WAS (void) __io_fgetc(fp)
855 */
856 ret_err = read_record();
857 if (ret_err) {
858 if (ret_err == FIO_EEOF)
859 return __fortio_eoferr(FIO_ENMLEOF);
860 return __fortio_error(ret_err);
861 }
862 continue; /* ignore end of line char */
863 }
864 }
865 token_buff[i++] = c;
866 }
867 token_buff[i + 1] = '\0';
868 constval.val.c.len = i;
869 constval.val.c.str = token_buff;
870 break;
871
872 case '(':
873 if (lparen_is_token) {
874 token = TK_LPAREN;
875 break;
876 }
877
878 /* else return a complex constant. Call get_token recursively to
879 process constant -which must be of form: ( TK_CONST , TK_CONST ) */
880
881 if (recur > 1) /* error if get_token is being called recursively */
882 return __fortio_error(FIO_ESYNTAX);
883 recur = 2;
884
885 GET_TOKEN(i);
886 if (token != TK_CONST || constval.dtype == __STR ||
887 constval.dtype == __NCHAR)
888 return __fortio_error(FIO_ESYNTAX);
889 cmplxval[0] = constval;
890
891 GET_TOKEN(i);
892 if (gbl->decimal == FIO_COMMA) {
893 if (token != TK_SEMICOLON)
894 return __fortio_error(FIO_ESYNTAX);
895 } else {
896 if (token != TK_COMMA)
897 return __fortio_error(FIO_ESYNTAX);
898 }
899 GET_TOKEN(i);
900 if (token != TK_CONST || constval.dtype == __STR ||
901 constval.dtype == __NCHAR)
902 return __fortio_error(FIO_ESYNTAX);
903 cmplxval[1] = constval;
904
905 GET_TOKEN(i);
906 if (token != TK_RPAREN)
907 return __fortio_error(FIO_ESYNTAX);
908
909 recur = 0;
910 token = TK_CONST;
911 constval.dtype = __BIGCPLX;
912 constval.val.cmplx = cmplxval;
913 break;
914
915 case ')':
916 token = TK_RPAREN;
917 break;
918
919 case ',':
920 if (comma_is_token) {
921 token = TK_COMMA;
922 break;
923 }
924 if (gbl->decimal != FIO_COMMA) {
925 token = TK_COMMA;
926 break;
927 }
928 c = *currc++;
929 if (c == 't' || c == 'T' || c == 'f' || c == 'F') {
930 token = TK_CONST;
931 constval.dtype = __BIGLOG;
932 constval.val.i = FTN_FALSE;
933 if (c == 't' || c == 'T')
934 constval.val.i = FTN_TRUE;
935 /* read and discard remaining alphabetic characters in token: */
936 do {
937 c = *currc++;
938 } while ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c == ',' ||
939 c == '_' || c == '$');
940 currc--;
941 break;
942 }
943
944 /* else, treat this ',' as beginning of numeric constant: */
945 currc--;
946 c = ',';
947
948 i = 0;
949 goto do_numeric_token;
950
951 case ':':
952 token = TK_COLON;
953 break;
954 case ';':
955 if (gbl->decimal == FIO_COMMA)
956 token = TK_SEMICOLON;
957 break;
958 case '%':
959 token = TK_PERCENT;
960 break;
961
962 case '=':
963 token = TK_EQUALS;
964 break;
965
966 case '0':
967 case '1':
968 case '2':
969 case '3':
970 case '4':
971 case '5':
972 case '6':
973 case '7':
974 case '8':
975 case '9':
976 token_buff[0] = c;
977 for (i = 1; i < MAX_TOKEN_LEN; i++) {
978 c = *currc++;
979 ;
980 if (c < '0' || c > '9')
981 break;
982 token_buff[i] = c;
983 }
984 token_buff[i] = '\0';
985
986 if (c != '*') /* no repeat count present */
987 goto do_numeric_token;
988
989 if (c == '*') { /* REPEAT COUNT */
990 extern long atol();
991 long k = atol(token_buff);
992 if (recur)
993 return __fortio_error(FIO_ELEX); /* unknown token */
994 assert(live_token == 0);
995
996 /* check character after '*' for blank, comma or e.o.g.: */
997 c = *currc++;
998 currc--;
999 if (c == ',' || IS_SPACE(c) || c == '$' || c == '&') {
1000 token = TK_SKIP;
1001 live_token = k - 1;
1002 } else {
1003 recur = 1;
1004 GET_TOKEN(i);
1005 recur = 0;
1006 if (token != TK_CONST)
1007 return __fortio_error(FIO_ESYNTAX); /* syntax error */
1008 live_token = k - 1;
1009 }
1010 }
1011 break;
1012 case '.':
1013 c = *currc++;
1014 if (c == 't' || c == 'T' || c == 'f' || c == 'F') {
1015 token = TK_CONST;
1016 constval.dtype = __BIGLOG;
1017 constval.val.i = FTN_FALSE;
1018 if (c == 't' || c == 'T')
1019 constval.val.i = FTN_TRUE;
1020 /* read and discard remaining alphabetic characters in token: */
1021 do {
1022 c = *currc++;
1023 } while ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c == '.' ||
1024 c == '_' || c == '$');
1025 currc--;
1026 break;
1027 }
1028
1029 /* else, treat this '.' as beginning of numeric constant: */
1030 currc--;
1031 c = '.';
1032 /* fall thru .... */
1033
1034 case '+':
1035 case '-':
1036 i = 0;
1037 do_numeric_token:
1038 /* scan for as long as we see characters which may be part of
1039 a numeric constant: */
1040 for (; i < MAX_TOKEN_LEN; i++) { /* copy number into buffer */
1041 char decimal = '.';
1042 if (gbl->decimal == FIO_COMMA)
1043 decimal = ',';
1044 if (!((c >= '0' && c <= '9') || c == decimal || c == 'e' || c == 'E' ||
1045 c == 'd' || c == 'D' || c == '-' || c == '+'))
1046 break;
1047 token_buff[i] = c;
1048 c = *currc++;
1049 }
1050 token_buff[i] = '\0';
1051 currc--;
1052 {
1053 int type; /* 0 - integer 1 - __BIGREAL_T */
1054 union {
1055 __BIGINT_T i;
1056 __BIGREAL_T d;
1057 __INT8_T i8v;
1058 } val;
1059 int len, errcode;
1060
1061 if (gbl->decimal == FIO_COMMA)
1062 errcode = __fortio_getnum(token_buff, &type, &val, &len, TRUE);
1063 else
1064 errcode = __fortio_getnum(token_buff, &type, &val, &len, FALSE);
1065 if (errcode != 0)
1066 return __fortio_error(errcode);
1067 if (len != i) /* token not entirely used up */
1068 return __fortio_error(FIO_ELEX); /* unknown token */
1069 token = TK_CONST;
1070 if (type == 0) {
1071 constval.dtype = __BIGINT;
1072 constval.val.i = val.i;
1073 }
1074 else if (type == 2) {
1075 constval.dtype = __INT8;
1076 constval.val.i8v = val.i8v;
1077 }
1078 else if (type == 3) {
1079 if (!REAL_ALLOWED(VRF_DESCP(vrf_cur)->type)) {
1080 return __fortio_error(FIO_EERR_DATA_CONVERSION);
1081 } else {
1082 constval.dtype = __BIGINT;
1083 constval.val.i = val.i;
1084 }
1085 } else {
1086 constval.dtype = __BIGREAL;
1087 constval.val.d = val.d;
1088 }
1089 }
1090 break;
1091
1092 case '/': /* f90 */
1093 case '$': /* f77 */
1094 case '&': /* extension */
1095 token = TK_ENDGROUP;
1096 break;
1097
1098 default: /* no possible legal token: */
1099 return __fortio_error(FIO_ELEX); /* unknown token */
1100 }
1101
1102 return 0;
1103 }
1104
1105 /* ----------------------------------------------------------------- */
1106
1107 static int
do_parse(NML_GROUP * nmldesc)1108 do_parse(NML_GROUP *nmldesc)
1109 {
1110 int i;
1111 int err;
1112 NML_DESC *descp;
1113
1114 /* The syntax for a reference is:
1115 * <ref> ::= <id> |
1116 * <ref> % <id>
1117 * <ref> ( <ss list> )
1118 * <ss list> ::= <ss list> , <ss> |
1119 * <ss>
1120 * <ss> ::= <ct> |
1121 * <opt ct> : <opt ct> <opt stride>
1122 * <opt ct> ::= |
1123 * <ct>
1124 * <opt stride> := |
1125 * : <ct>
1126 */
1127
1128 /* Begin by retrieving an identifier */
1129 GET_TOKEN(i);
1130 if (token != TK_IDENT) {
1131 if (token == TK_ENDGROUP)
1132 return -1;
1133 return __fortio_error(FIO_ENONAME); /* syntax error */
1134 }
1135
1136 /* find the matching namelist item descriptors */
1137
1138 /* point to the first item descriptor: */
1139 descp = (NML_DESC *)((char *)nmldesc + sizeof(NML_GROUP));
1140
1141 i = 0;
1142 while (TRUE) {
1143 if (strlen(token_buff) == descp->nlen &&
1144 strncmp(descp->sym, token_buff, (int)descp->nlen) == 0)
1145 break;
1146
1147 i++;
1148 if (i >= nmldesc->ndesc)
1149 break;
1150
1151 descp = skip_to_next(descp);
1152 }
1153 if (i == nmldesc->ndesc) /* match not found */
1154 return NML_ERROR(FIO_ENOTMEM);
1155
1156 /* Setup for the main parsing loop: */
1157 vrf.avl = 0;
1158 tri.avl = 1;
1159 lparen_is_token = TRUE; /* want get_token to recognize '(' as a token */
1160 substring.present = FALSE;
1161 vrf_cur = add_vrf(VRF_ID, descp);
1162
1163 if (descp->ndims == -1 || descp->ndims == -2)
1164 I8(fillup_sb)(vrf_cur, descp, descp->addr);
1165
1166 err = parse_ref(descp);
1167
1168 /* set pread */
1169 if (descp->ndims == -2 || descp->ndims >= 30) {
1170 if (!internal_file)
1171 f->pread = currc;
1172 }
1173
1174 /* Cleanup after the main parsing loop */
1175 lparen_is_token = FALSE;
1176
1177 return err;
1178 }
1179
1180 static NML_DESC *
skip_dtio_datainit(NML_DESC * descp)1181 skip_dtio_datainit(NML_DESC *descp)
1182 {
1183 __POINT_T *dtio_desc;
1184 NML_DESC *next_descp;
1185
1186 /*read*/
1187 dtio_desc = (__POINT_T *)((char *)descp + sizeof(__POINT_T));
1188 /*write*/
1189 dtio_desc = (__POINT_T *)((char *)dtio_desc + sizeof(__POINT_T));
1190 /*dtv*/
1191 dtio_desc = (__POINT_T *)((char *)dtio_desc + sizeof(__POINT_T));
1192 /*dtv$sd*/
1193 dtio_desc = (__POINT_T *)((char *)dtio_desc + sizeof(__POINT_T));
1194 /*past vlist*/
1195 dtio_desc = (__POINT_T *)((char *)dtio_desc + sizeof(__POINT_T));
1196 /*past vlist$sd*/
1197 dtio_desc = (__POINT_T *)((char *)dtio_desc + sizeof(__POINT_T));
1198 /*next descriptor*/
1199 dtio_desc = (__POINT_T *)((char *)dtio_desc + sizeof(__POINT_T));
1200
1201 next_descp = (NML_DESC *)dtio_desc;
1202 return next_descp;
1203 }
1204
1205 static int
parse_ref(NML_DESC * gdescp)1206 parse_ref(NML_DESC *gdescp)
1207 {
1208 int i, k;
1209 NML_DESC *descp, *next_descp;
1210 __POINT_T new_ndims;
1211 __POINT_T actual_ndims;
1212
1213 descp = gdescp;
1214
1215 /* Enter a parsing loop searching for subobject designators */
1216
1217 ref_loop:
1218 GET_TOKEN(i);
1219 ACTUAL_NDIMS(actual_ndims);
1220 switch (token) {
1221 case TK_EQUALS:
1222 return 0;
1223
1224 case TK_PERCENT:
1225 GET_TOKEN(i);
1226 if (token != TK_IDENT)
1227 return NML_ERROR(FIO_ESYNTAX);
1228 if (descp->type != __DERIVED)
1229 return NML_ERROR(FIO_ESYNTAX);
1230
1231 /* -- scan item descriptors to find one with name that matches: */
1232 /* compute number of bytes to add to reach next descriptor: */
1233 if (actual_ndims >= 0)
1234 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
1235 else
1236 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
1237 next_descp = (NML_DESC *)((char *)descp + k);
1238 if (descp->ndims >= 30) {
1239 /* need to skip dtio data init section */
1240 next_descp = skip_dtio_datainit(descp);
1241 }
1242 while (TRUE) {
1243 if (next_descp->nlen == 0) {
1244 return NML_ERROR(FIO_ESYNTAX);
1245 }
1246 if (strlen(token_buff) == next_descp->nlen &&
1247 strncmp(next_descp->sym, token_buff, next_descp->nlen) == 0)
1248 break;
1249 next_descp = skip_to_next(next_descp);
1250 }
1251 descp = next_descp;
1252 vrf_cur = add_vrf(VRF_MEMBER, descp);
1253 break;
1254
1255 case TK_LPAREN:
1256 new_ndims = *(__POINT_T *)((char *)descp + sizeof(NML_DESC));
1257 if (actual_ndims > 0 &&
1258 (VRF_TYPE(vrf_cur) == VRF_ID || VRF_TYPE(vrf_cur) == VRF_MEMBER)) {
1259 i = I8(parse_subscripts)(descp);
1260 if (i)
1261 return i;
1262 } else if ((descp->ndims == -1 || descp->ndims == -2) && new_ndims > 0) {
1263 i = I8(parse_subscripts)(descp);
1264 if (i)
1265 return i;
1266
1267 } else if (descp->type == __STR) {
1268 i = I8(parse_substring)(descp);
1269 if (i)
1270 return i;
1271 }
1272 else
1273 return NML_ERROR(FIO_ESYNTAX);
1274 break;
1275 default:
1276 return NML_ERROR(FIO_ESYNTAX);
1277 }
1278 goto ref_loop;
1279 }
1280
1281 static int
add_vrf(int type,NML_DESC * descp)1282 add_vrf(int type, NML_DESC *descp)
1283 {
1284 int i;
1285 i = vrf.avl++;
1286 VRF_TYPE(i) = type;
1287 VRF_DESCP(i) = descp;
1288 VRF_SUBSCRIPT(i) = 0;
1289 VRF_ADDR(i) = descp->addr;
1290 return i;
1291 }
1292
1293 static int
I8(parse_subscripts)1294 I8(parse_subscripts)(NML_DESC *descp)
1295 {
1296 int i, k, v;
1297 __POINT_T *desc_dims; /* base pointer to 2-dim descriptor array */
1298 __BIGINT_T val, upb, stride;
1299 bool is_section;
1300 __POINT_T new_ndims = 0;
1301 __POINT_T actual_ndims = 0;
1302 F90_Desc *sd;
1303 DECL_DIM_PTRS(acd);
1304
1305 ACTUAL_NDIMS(actual_ndims);
1306 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
1307 k = -1;
1308 is_section = FALSE;
1309 new_ndims = actual_ndims;
1310 if (descp->ndims == -1 || descp->ndims == -2) {
1311 new_ndims = *(__POINT_T *)((char *)descp + sizeof(NML_DESC));
1312 sd = get_descriptor(descp);
1313 }
1314 v = add_triple(new_ndims);
1315
1316 do {
1317 k++;
1318 if (k >= new_ndims)
1319 goto subscript_error; /* too many subscripts */
1320 /* examine first token for the current dimension */
1321 comma_is_token = TRUE;
1322 GET_TOKEN(i);
1323 if (descp->ndims == -1 || descp->ndims == -2)
1324 SET_DIM_PTRS(acd, sd, k);
1325 if (token == TK_CONST && constval.dtype == __BIGINT) {
1326 val = constval.val.i;
1327
1328 if (descp->ndims == -1 || descp->ndims == -2) {
1329 if (val < F90_DPTR_LBOUND_G(acd) || val > F90_DPTR_EXTENT_G(acd))
1330 goto subscript_error; /* subscr out of range */
1331 } else if (val < desc_dims[2 * k] || val > desc_dims[2 * k + 1]) {
1332 goto subscript_error; /* subscr out of range */
1333 }
1334
1335 /* Is this constant a subscipt or the lower bound of a section? */
1336
1337 GET_TOKEN(i);
1338 if (token == TK_COMMA || token == TK_RPAREN) {
1339 /* the constant is a subscript */
1340 TRI_LWB(v, k) = val;
1341 TRI_UPB(v, k) = val;
1342 TRI_STRIDE(v, k) = 1;
1343 if (descp->ndims == -1 || descp->ndims == -2) {
1344 sb.sect[k].lwb = val;
1345 sb.sect[k].upb = val;
1346 sb.sect[k].stride = 1;
1347 }
1348 continue;
1349 }
1350
1351 /* Expect to see a : */
1352
1353 if (token != TK_COLON)
1354 goto subscript_error;
1355 } else if (token == TK_COLON) {
1356 if (descp->ndims == -1 || descp->ndims == -2)
1357 val = F90_DPTR_LBOUND_G(acd);
1358 else
1359 val = desc_dims[2 * k]; /* default lower bound */
1360 } else
1361 goto subscript_error;
1362
1363 /* So far, we've parsed
1364 * <c> :
1365 * or
1366 * :
1367 * in which case we now have a lower bound of a section - determine
1368 * the upper bound.
1369 */
1370 is_section = TRUE;
1371 if (descp->ndims == -1 || descp->ndims == -2) {
1372 upb = F90_DPTR_EXTENT_G(acd);
1373 } else {
1374 upb = desc_dims[2 * k + 1]; /* default upper bound */
1375 }
1376 stride = 1; /* default stride */
1377 GET_TOKEN(i);
1378 if (token == TK_CONST && constval.dtype == __BIGINT) {
1379 upb = constval.val.i;
1380 if (descp->ndims == -1 || descp->ndims == -2) {
1381 if (upb < F90_DPTR_LBOUND_G(acd) || upb > F90_DPTR_EXTENT_G(acd))
1382 goto subscript_error; /* subscr out of range */
1383 } else if (upb < desc_dims[2 * k] || upb > desc_dims[2 * k + 1])
1384 goto subscript_error; /* subscr out of range */
1385
1386 /* Found <c> as the upper bound; check for stride. */
1387
1388 GET_TOKEN(i);
1389 if (token == TK_COLON) {
1390 /* expect a constant */
1391 GET_TOKEN(i);
1392 if (token != TK_CONST || constval.dtype != __BIGINT)
1393 goto subscript_error;
1394 stride = constval.val.i;
1395 if (stride < 0)
1396 goto subscript_error; /* subscr out of range */
1397 GET_TOKEN(i);
1398 }
1399 } else if (token != TK_COMMA && token != TK_RPAREN)
1400 goto subscript_error;
1401
1402 TRI_LWB(v, k) = val;
1403 TRI_UPB(v, k) = upb;
1404 TRI_STRIDE(v, k) = stride;
1405 if (descp->ndims == -1 || descp->ndims == -2) {
1406 sb.sect[k].lwb = val;
1407 sb.sect[k].upb = upb;
1408 sb.sect[k].stride = stride;
1409 }
1410
1411 } while (token != TK_RPAREN);
1412 comma_is_token = FALSE;
1413
1414 if (descp->ndims == -1 || descp->ndims == -2) {
1415 VRF_SUBSCRIPT(vrf_cur) = v;
1416 if (k != new_ndims - 1)
1417 goto subscript_error;
1418 } else if (k != actual_ndims - 1)
1419 goto subscript_error;
1420
1421 if (is_section)
1422 vrf_cur = add_vrf(VRF_SECTION, descp);
1423 else
1424 vrf_cur = add_vrf(VRF_ELEMENT, descp);
1425 VRF_SUBSCRIPT(vrf_cur) = v;
1426
1427 return 0; /* no errors encountered */
1428
1429 subscript_error:
1430 return NML_ERROR(FIO_ESUBSC);
1431 }
1432
1433 static int
I8(parse_substring)1434 I8(parse_substring)(NML_DESC *descp)
1435 {
1436 int i;
1437 __BIGINT_T val, end;
1438 F90_Desc *sd;
1439
1440 val = 1; /* default starting value */
1441 GET_TOKEN(i);
1442 if (token == TK_CONST && constval.dtype == __BIGINT) {
1443 val = constval.val.i;
1444 GET_TOKEN(i); /* expect a : */
1445 }
1446 if (token != TK_COLON) /* illegal substring spec */
1447 return NML_ERROR(FIO_ESUBSC);
1448
1449 /* At this point, ":" of substring descriptor has been read and
1450 * 'val' contains the value of the starting position.
1451 */
1452 if (descp->ndims == -1 || descp->ndims == -2) {
1453 sd = get_descriptor(descp);
1454 end = descp->len = F90_LEN_G(sd); /* deferred char */
1455 } else
1456 end = descp->len; /* default end position */
1457
1458 GET_TOKEN(i);
1459 if (token == TK_CONST && constval.dtype == __BIGINT) {
1460 end = constval.val.i;
1461 GET_TOKEN(i); /* expect right paren */
1462 }
1463 if (token != TK_RPAREN) /* check for closing paren */
1464 return NML_ERROR(FIO_ESUBSC);
1465
1466 substring.present = TRUE;
1467 substring.start = val;
1468 substring.end = end;
1469
1470 return 0; /* no errors encountered */
1471 }
1472
1473 static int
add_triple(int n)1474 add_triple(int n)
1475 {
1476 int i;
1477 i = tri.avl;
1478 tri.avl += n;
1479 return i;
1480 }
1481
1482 static int
assign_values(void)1483 assign_values(void)
1484 {
1485 int i;
1486 int err;
1487
1488 comma_live = TRUE;
1489 err = eval(0, NULL);
1490
1491 /* Have processed a name-value pair; check the next token */
1492 GET_TOKEN(i);
1493 if (token == TK_CONST) {
1494 live_token = 1;
1495 return NML_ERROR(FIO_ETOOM);
1496 }
1497 if ((token == TK_COMMA && gbl->decimal != FIO_COMMA) ||
1498 (token == TK_SEMICOLON && gbl->decimal == FIO_COMMA)) {
1499 /* cleanup get_token - eat the separating ',' */
1500 GET_TOKEN(i);
1501 if (token == TK_CONST) {
1502 live_token = 1;
1503 return NML_ERROR(FIO_ETOOM);
1504 }
1505 }
1506 /* other token - 'put token back' and exit loop. */
1507 assert(live_token == 0);
1508 live_token = 1;
1509
1510 return err;
1511 }
1512
1513 static void
I8(fillup_sb)1514 I8(fillup_sb)(int v, NML_DESC *descp, char *loc_addr)
1515 {
1516 int i, k;
1517 F90_Desc *sd = get_descriptor(descp);
1518 DECL_DIM_PTRS(acd);
1519
1520 sb.v = v;
1521 sb.ndims = *(__POINT_T *)((char *)descp + sizeof(NML_DESC));
1522 sb.elemsz = I8(siz_of)(descp);
1523 for (i = 0; i < sb.ndims; ++i) {
1524 SET_DIM_PTRS(acd, sd, i);
1525 sb.idx[i] = F90_DPTR_LBOUND_G(acd);
1526 sb.sect[i].lwb = F90_DPTR_LBOUND_G(acd);
1527 sb.sect[i].upb = F90_DPTR_EXTENT_G(acd);
1528 sb.sect[i].stride = F90_DPTR_SSTRIDE_G(acd);
1529 sb.mult[i] = F90_DPTR_LSTRIDE_G(acd);
1530 sb.lwb[i] = F90_DPTR_LBOUND_G(acd);
1531 }
1532 sb.loc_addr = loc_addr;
1533 }
1534
1535 /*
1536 * Recursively compute the index space given a set of subscripts for n
1537 * dimensions. The evaluation begins by iterating over the last dimension,
1538 * recursively evaluating the subscripts of the next (to the left) for
1539 * each iteration. For a given dimension d's index, subscripts to the left
1540 * are recursively computed. When the first dimension is reached, the address
1541 * of the element represented by the current subscript values is passed to
1542 * the 'eval' function.
1543 */
1544 static int
I8(eval_sb)1545 I8(eval_sb)(int d)
1546 {
1547 int j, err;
1548 __BIGINT_T offset;
1549 char *new_addr;
1550 NML_DESC *descp;
1551 __POINT_T *desc_dims;
1552 F90_Desc *sd;
1553
1554 descp = VRF_DESCP(sb.v);
1555
1556 if (descp->ndims == -1 || descp->ndims == -2) {
1557 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
1558 if (*desc_dims == 0) {
1559 /* $p contains an address of array/scalar */
1560 new_addr = *(char **)sb.loc_addr;
1561 err = eval_ptr(sb.v, new_addr);
1562 if (err)
1563 return err;
1564 return 0;
1565 }
1566 }
1567 if (d == 0) {
1568 /*
1569 * Reached the first dimension; iterate over the first dimension,
1570 * compute the address of each element, and pass each address to
1571 * 'eval'.
1572 */
1573 sd = get_descriptor(descp);
1574 for (sb.idx[0] = sb.sect[0].lwb; sb.idx[0] <= sb.sect[0].upb;
1575 sb.idx[0] += sb.sect[0].stride) {
1576 offset = 0;
1577 if (descp->ndims == -1 || descp->ndims == -2) {
1578 new_addr = I8(__fort_local_address)((*(char **)sb.loc_addr), sd,
1579 (__INT_T *)&sb.idx[0]);
1580 err = eval_ptr(sb.v, new_addr);
1581 } else {
1582 for (j = 0; j < sb.ndims; j++) {
1583 offset += (sb.idx[j] - sb.lwb[j]) * sb.mult[j];
1584 }
1585 offset *= sb.elemsz;
1586 new_addr = sb.loc_addr + offset;
1587 err = eval(sb.v + 1, new_addr);
1588 }
1589 if (err)
1590 return err;
1591 }
1592 return 0;
1593 }
1594
1595 /* Iterate over the current dimension, and recursively evaluate all
1596 * subscripts in the dimensions to the left.
1597 */
1598 for (sb.idx[d] = sb.sect[d].lwb; sb.idx[d] <= sb.sect[d].upb;
1599 sb.idx[d] += sb.sect[d].stride) {
1600 err = I8(eval_sb)(d - 1);
1601 if (err)
1602 return err;
1603 }
1604 return 0;
1605 }
1606
1607 /** \brief
1608 * Recursively compute the index space given a set of subscripts for n
1609 * dimensions.
1610 *
1611 * The evaluation begins by iterating over the last dimension,
1612 * recursively evaluating the subscripts of the next (to the left) for
1613 * each iteration. For a given dimension d's index, subscripts to the left
1614 * are recursively computed. When the first dimension is reached, the address
1615 * of the element represented by the current subscript values is passed to
1616 * the 'eval' function.
1617 */
1618 static int
I8(eval_dtio_sb)1619 I8(eval_dtio_sb)(int d)
1620 {
1621 int j, err;
1622 __BIGINT_T offset;
1623 char *new_addr;
1624 NML_DESC *descp;
1625 __POINT_T *desc_dims;
1626 F90_Desc *sd;
1627
1628 descp = VRF_DESCP(sb.v);
1629
1630 if (descp->ndims == -2) {
1631 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
1632 if (*desc_dims == 0) {
1633 /* $p contains an address of array/scalar */
1634 new_addr = *(char **)sb.loc_addr;
1635 err = eval_ptr(sb.v, new_addr);
1636 if (err)
1637 return err;
1638 return 0;
1639 }
1640 } else if (descp->ndims == -1) {
1641 #ifdef DEBUG
1642 printf("unexpect ndims in eval_dtio_sb\n");
1643 return ERR_FLAG;
1644 #endif
1645 }
1646 if (d == 0) {
1647 /*
1648 * Reached the first dimension; iterate over the first dimension,
1649 * compute the address of each element, and pass each address to
1650 * 'eval'.
1651 */
1652 sd = get_descriptor(descp);
1653 for (sb.idx[0] = sb.sect[0].lwb; sb.idx[0] <= sb.sect[0].upb;
1654 sb.idx[0] += sb.sect[0].stride) {
1655 offset = 0;
1656 if (descp->ndims == -2) {
1657 new_addr = I8(__fort_local_address)((*(char **)sb.loc_addr), sd,
1658 (__INT_T *)&sb.idx[0]);
1659 err = eval_ptr(sb.v, new_addr);
1660 } else {
1661 for (j = 0; j < sb.ndims; j++) {
1662 offset += (sb.idx[j] - sb.lwb[j]) * sb.mult[j];
1663 }
1664 offset *= sb.elemsz;
1665 new_addr = sb.loc_addr + offset;
1666 err = eval(sb.v + 1, new_addr);
1667 }
1668 if (err)
1669 return err;
1670 }
1671 return 0;
1672 }
1673
1674 /* Iterate over the current dimension, and recursively evaluate all
1675 * subscripts in the dimensions to the left.
1676 */
1677 for (sb.idx[d] = sb.sect[d].lwb; sb.idx[d] <= sb.sect[d].upb;
1678 sb.idx[d] += sb.sect[d].stride) {
1679 err = I8(eval_dtio_sb)(d - 1);
1680 if (err)
1681 return err;
1682 }
1683 return 0;
1684 }
1685
1686 static int
eval_ptr(int v,char * loc_addr)1687 eval_ptr(int v, char *loc_addr)
1688 {
1689
1690 switch (VRF_TYPE(v)) {
1691 case VRF_ELEMENT:
1692 /* subscripted reference, assign() stores a scalar but there
1693 * may be additional values.
1694 */
1695 return assign(VRF_DESCP(v), loc_addr, NULL, FALSE, TRUE);
1696 case VRF_SECTION:
1697 /* for this type, we're already iterating over an index space;
1698 * just have assign store a scalar.
1699 */
1700 return assign(VRF_DESCP(v), loc_addr, NULL, FALSE, FALSE);
1701 default:
1702 break;
1703 }
1704 return assign(VRF_DESCP(v), loc_addr, NULL, TRUE, FALSE);
1705 }
1706
1707 static int
eval(int v,char * loc_addr)1708 eval(int v, char *loc_addr)
1709 {
1710 NML_DESC *descp;
1711 int i, j, k;
1712 __BIGINT_T offset, mm;
1713 char *new_addr;
1714 __POINT_T *desc_dims; /* base pointer to 2-dim descriptor array */
1715 __POINT_T new_ndims;
1716 __POINT_T actual_ndims;
1717
1718 if (v > vrf_cur) {
1719
1720 descp = VRF_DESCP(v - 1);
1721 if (descp->ndims == -1)
1722 return I8(eval_sb)(sb.ndims - 1);
1723 else if (descp->ndims == -2)
1724 return I8(eval_dtio_sb)(sb.ndims - 1);
1725 switch (VRF_TYPE(v - 1)) {
1726 case VRF_ELEMENT:
1727 /* subscripted reference, assign() stores a scalar but there
1728 * may be additional values.
1729 */
1730 return assign(VRF_DESCP(v - 1), loc_addr, NULL, FALSE, TRUE);
1731 case VRF_SECTION:
1732 /* for this type, we're already iterating over an index space;
1733 * just have assign store a scalar.
1734 */
1735 return assign(VRF_DESCP(v - 1), loc_addr, NULL, FALSE, FALSE);
1736 default:
1737 break;
1738 }
1739 return assign(VRF_DESCP(v - 1), loc_addr, NULL, TRUE, FALSE);
1740 }
1741
1742 new_addr = loc_addr;
1743 descp = VRF_DESCP(v);
1744 ACTUAL_NDIMS(actual_ndims);
1745 switch (VRF_TYPE(v)) {
1746 case VRF_ID:
1747 if (descp->ndims == -1) /* scalar pointer - getting $p */
1748 new_addr = *(char **)descp->addr;
1749 else
1750 new_addr = descp->addr;
1751 break;
1752
1753 case VRF_ELEMENT:
1754 k = VRF_SUBSCRIPT(v);
1755 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
1756 if (descp->ndims != -1 && descp->ndims != -2) {
1757 offset = TRI_LWB(k, 0) - desc_dims[0];
1758 mm = 1; /* multiplier for each dimension */
1759 for (i = 1; i < actual_ndims; i++) {
1760 mm *= desc_dims[2 * (i - 1) + 1] - desc_dims[2 * (i - 1)] + 1;
1761 offset += (TRI_LWB(k, i) - desc_dims[2 * i]) * mm;
1762 }
1763 offset *= I8(siz_of)(descp);
1764 new_addr += offset;
1765 }
1766 break;
1767
1768 case VRF_SECTION:
1769 k = VRF_SUBSCRIPT(v);
1770
1771 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
1772 /*
1773 * Copy the section information into the looping sect structure.
1774 * Compute the multipliers for each dimension.
1775 */
1776 if (descp->ndims != -1 && descp->ndims != -2) {
1777 sb.mult[0] = 1;
1778 sb.sect[0] = TRI_SECT(k, 0);
1779 sb.lwb[0] = desc_dims[0];
1780 sb.ndims = actual_ndims;
1781 sb.loc_addr = loc_addr;
1782 for (i = 1; i < actual_ndims; i++) {
1783 sb.lwb[i] = desc_dims[2 * i];
1784 sb.mult[i] = sb.mult[i - 1] *
1785 (desc_dims[2 * (i - 1) + 1] - desc_dims[2 * (i - 1)] + 1);
1786 sb.sect[i] = TRI_SECT(k, i);
1787 }
1788 }
1789 sb.v = v;
1790 sb.elemsz = I8(siz_of)(descp);
1791 if (descp->ndims == -2) {
1792 return I8(eval_dtio_sb)(sb.ndims - 1);
1793 } else if (descp->ndims >= MAX_DIM) {
1794 return I8(eval_dtio_sb)(sb.ndims - 1);
1795 }
1796 return I8(eval_sb)(sb.ndims - 1);
1797
1798 case VRF_MEMBER:
1799 new_addr = loc_addr + (long)descp->addr;
1800 break;
1801 }
1802
1803 return eval(v + 1, new_addr);
1804 }
1805
1806 static int
assign(NML_DESC * descp,char * loc_addr,char ** p_next_addr,bool chkarr,bool is_subscripted)1807 assign(NML_DESC *descp, char *loc_addr, char **p_next_addr, bool chkarr,
1808 bool is_subscripted)
1809 {
1810 int i, k;
1811 int length;
1812 int err;
1813 char *new_addr;
1814 NML_DESC *new_descp;
1815
1816 if (descp->ndims == -2 || descp->ndims >= MAX_DIM) {
1817 return dtio_assign(descp, loc_addr, p_next_addr, chkarr, is_subscripted);
1818 }
1819
1820 if (p_next_addr)
1821 *p_next_addr = NULL;
1822 if (chkarr && descp->ndims > 0) {
1823 __BIGINT_T elemsz;
1824 int nitems;
1825 char *last_addr;
1826 char *next_addr;
1827
1828 /* Compute the size of each array element */
1829 elemsz = I8(siz_of)(descp);
1830 /*
1831 * Compute the number of items in the array. Loop on the number
1832 * of items in the array, assigning to the elements of the array
1833 * in lexical order; the address of the next element is just the
1834 * sum of the previous address and the element size.
1835 */
1836 nitems = nelems_of(descp);
1837 if (nitems > 0) {
1838 new_addr = loc_addr;
1839 last_addr = loc_addr + (nitems - 1) * elemsz;
1840 next_addr = NULL;
1841 while (TRUE) {
1842 err = assign(descp, new_addr, &next_addr, FALSE, FALSE);
1843 if (err)
1844 return err;
1845 if (next_addr && next_addr > new_addr)
1846 new_addr = next_addr;
1847 else
1848 new_addr += elemsz;
1849 if (new_addr > last_addr)
1850 break;
1851 }
1852 }
1853 return 0;
1854 } else if (chkarr && (descp->ndims == -1 || descp->ndims == -2)) {
1855 __BIGINT_T elemsz;
1856 int nitems;
1857 char *last_addr;
1858 char *next_addr;
1859
1860 /* Compute the size of each array element */
1861 elemsz = I8(siz_of)(descp);
1862 /*
1863 * Compute the number of items in the array. Loop on the number
1864 * of items in the array, assigning to the elements of the array
1865 * in lexical order; the address of the next element is just the
1866 * sum of the previous address and the element size.
1867 */
1868 nitems = nelems_of(descp);
1869 if (nitems > 0) {
1870 new_addr = loc_addr;
1871 last_addr = loc_addr + (nitems - 1) * elemsz;
1872 next_addr = NULL;
1873 while (TRUE) {
1874 err = assign(descp, new_addr, &next_addr, FALSE, FALSE);
1875 if (err)
1876 return err;
1877 if (next_addr && next_addr > new_addr)
1878 new_addr = next_addr;
1879 else
1880 new_addr += elemsz;
1881 if (new_addr > last_addr)
1882 break;
1883 }
1884 }
1885 return 0;
1886 }
1887
1888 if (descp->type == __DERIVED) {
1889 /*
1890 * Loop on the members of the derived type. First, compute the
1891 * number of bytes to add to reach the descriptor of the first
1892 * member.
1893 */
1894 if (descp->ndims >= 0)
1895 k = sizeof(NML_DESC) + (descp->ndims * sizeof(__POINT_T) * 2);
1896 else
1897 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
1898 new_descp = (NML_DESC *)((char *)descp + k);
1899 new_addr = loc_addr;
1900 while (TRUE) {
1901 if (new_descp->nlen == 0) {
1902 break;
1903 }
1904 new_addr = loc_addr + (long)new_descp->addr;
1905 err = assign(new_descp, new_addr, NULL, TRUE, FALSE);
1906 if (err)
1907 return err;
1908 new_descp = skip_to_next(new_descp);
1909 }
1910 return 0;
1911 }
1912
1913 /* Just store into a scalar */
1914
1915 length = descp->len; /* Need to update the length of deferchar */
1916 while (TRUE) {
1917 GET_TOKEN(i);
1918 switch (token) {
1919 case TK_CONST:
1920 if (!substring.present)
1921 err = __fortio_assign(loc_addr, descp->type, length, &constval);
1922 else {
1923 /* Given that the substring is present, it's an assertion that
1924 * the data type is a string.
1925 */
1926 new_addr = loc_addr + substring.start * FIO_TYPE_SIZE(descp->type);
1927 length = substring.end - substring.start + 1;
1928 err = __fortio_assign(new_addr, descp->type, length, &constval);
1929 }
1930 if (err != 0)
1931 return NML_ERROR(err);
1932 comma_live = FALSE;
1933 /*
1934 * If the name represents an array,
1935 * increment address just in case there are more values,
1936 * in which case the values will be stored in the next
1937 * element-order address; e.g.
1938 * A(1,1) = 1 2 3
1939 * stores
1940 * A(1,1) = 1
1941 * A(2,1) = 2
1942 * A(3,1) = 3
1943 */
1944 loc_addr += I8(siz_of)(descp);
1945 if (!is_subscripted)
1946 goto exit_loop;
1947 break;
1948 case TK_SEMICOLON:
1949 if (gbl->decimal == FIO_COMMA) {
1950 if (comma_live)
1951 loc_addr += I8(siz_of)(descp);
1952 comma_live = TRUE;
1953 }
1954 break;
1955
1956 case TK_COMMA:
1957 if (comma_live)
1958 loc_addr += I8(siz_of)(descp);
1959 comma_live = TRUE;
1960 break;
1961
1962 case TK_SKIP: /* '<repeat_count>*' null values */
1963 comma_live = FALSE;
1964 loc_addr += I8(siz_of)(descp);
1965 break;
1966
1967 default:
1968 /* other token - 'put token back' and exit loop. */
1969 assert(live_token == 0);
1970 live_token = 1;
1971 goto exit_loop;
1972 }
1973 }
1974 exit_loop:
1975 if (p_next_addr)
1976 *p_next_addr = loc_addr;
1977 return 0;
1978 }
1979
1980 static int
dtio_assign(NML_DESC * descp,char * loc_addr,char ** p_next_addr,bool chkarr,bool is_subscripted)1981 dtio_assign(NML_DESC *descp, char *loc_addr, char **p_next_addr, bool chkarr,
1982 bool is_subscripted)
1983 {
1984 int i, k;
1985 int length;
1986 int err;
1987 char *new_addr;
1988 NML_DESC *new_descp;
1989 __POINT_T actual_ndims;
1990 ACTUAL_NDIMS(actual_ndims);
1991
1992 if (p_next_addr)
1993 *p_next_addr = NULL;
1994 if (chkarr && actual_ndims > 0) {
1995 __BIGINT_T elemsz;
1996 int nitems;
1997 char *last_addr;
1998 char *next_addr;
1999
2000 /* Compute the size of each array element */
2001 elemsz = I8(siz_of)(descp);
2002 /*
2003 * Compute the number of items in the array. Loop on the number
2004 * of items in the array, assigning to the elements of the array
2005 * in lexical order; the address of the next element is just the
2006 * sum of the previous address and the element size.
2007 */
2008 nitems = nelems_of(descp);
2009 if (nitems > 0) {
2010 new_addr = loc_addr;
2011 last_addr = loc_addr + (nitems - 1) * elemsz;
2012 next_addr = NULL;
2013 while (TRUE) {
2014 err = dtio_assign(descp, new_addr, &next_addr, FALSE, FALSE);
2015 if (err)
2016 return err;
2017 if (next_addr && next_addr > new_addr)
2018 new_addr = next_addr;
2019 else
2020 new_addr += elemsz;
2021 if (new_addr > last_addr)
2022 break;
2023 }
2024 }
2025 return 0;
2026 } else if (chkarr && (descp->ndims == -2)) {
2027 __BIGINT_T elemsz;
2028 int nitems;
2029 char *last_addr;
2030 char *next_addr;
2031
2032 /* Compute the size of each array element */
2033 elemsz = I8(siz_of)(descp);
2034 /*
2035 * Compute the number of items in the array. Loop on the number
2036 * of items in the array, assigning to the elements of the array
2037 * in lexical order; the address of the next element is just the
2038 * sum of the previous address and the element size.
2039 */
2040 nitems = nelems_of(descp);
2041 if (nitems > 0) {
2042 new_addr = loc_addr;
2043 last_addr = loc_addr + (nitems - 1) * elemsz;
2044 next_addr = NULL;
2045 while (TRUE) {
2046 err = dtio_assign(descp, new_addr, &next_addr, FALSE, FALSE);
2047 if (err)
2048 return err;
2049 if (next_addr && next_addr > new_addr)
2050 new_addr = next_addr;
2051 else
2052 new_addr += elemsz;
2053 if (new_addr > last_addr)
2054 break;
2055 }
2056 }
2057 return 0;
2058 }
2059
2060 while (TRUE) {
2061 /* call dtio here */
2062 err = dtio_read_scalar(descp, loc_addr);
2063 if (err)
2064 return err;
2065 comma_live = FALSE;
2066 loc_addr += I8(siz_of)(descp);
2067 GET_TOKEN(i);
2068
2069 switch (token) {
2070 case TK_SEMICOLON:
2071 if (gbl->decimal == FIO_COMMA) {
2072 if (comma_live)
2073 loc_addr += I8(siz_of)(descp);
2074 comma_live = TRUE;
2075 }
2076 if (!is_subscripted)
2077 goto exit_loop;
2078 break;
2079
2080 case TK_COMMA:
2081 if (comma_live)
2082 loc_addr += I8(siz_of)(descp);
2083 comma_live = TRUE;
2084 if (!is_subscripted)
2085 goto exit_loop;
2086 break;
2087
2088 case TK_SKIP: /* '<repeat_count>*' null values */
2089 comma_live = FALSE;
2090 loc_addr += I8(siz_of)(descp);
2091 if (!is_subscripted)
2092 goto exit_loop;
2093 break;
2094
2095 default:
2096 /* other token - 'put token back' and exit loop. */
2097 /* comma_live = FALSE;*/
2098 if (!is_subscripted) {
2099 goto exit_loop;
2100 } else {
2101 assert(live_token == 0);
2102 live_token = 1;
2103 goto exit_loop;
2104 }
2105 }
2106 }
2107 exit_loop:
2108 if (p_next_addr)
2109 *p_next_addr = loc_addr;
2110 return 0;
2111 }
2112
2113 /* -------------------------------------------------------------------- */
2114
2115 static int
_f90io_nmlr_end()2116 _f90io_nmlr_end()
2117 {
2118 gbl->decimal = 0;
2119 if (!gbl->same_fcb_idx) {
2120 gbl->unit = 0;
2121 gbl->iostat = 0;
2122 }
2123
2124 /* first check for errors: */
2125 if (fioFcbTbls.eof)
2126 return EOF_FLAG;
2127 if (fioFcbTbls.error)
2128 return ERR_FLAG;
2129
2130 return 0;
2131 }
2132
2133 /** \brief Read a namelist group
2134 */
2135 int
ENTF90IO(NMLR_END,nmlr_end)2136 ENTF90IO(NMLR_END, nmlr_end)()
2137 {
2138 int s = 0;
2139
2140 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
2141 s = _f90io_nmlr_end();
2142 __fortio_errend03();
2143 return DIST_STATUS_BCST(s);
2144 }
2145
2146 int
ENTCRF90IO(NMLR_END,nmlr_end)2147 ENTCRF90IO(NMLR_END, nmlr_end)()
2148 {
2149 int s = 0;
2150 s = _f90io_nmlr_end();
2151 __fortio_errend03();
2152 return s;
2153 }
2154
2155 /* ********************/
2156 /* read support */
2157 /* ********************/
2158
2159 static int
read_record(void)2160 read_record(void)
2161 {
2162 if (internal_file) {
2163 if (n_irecs == 0)
2164 return FIO_EEOF;
2165 if (accessed)
2166 in_recp += rec_len;
2167 n_irecs--;
2168
2169 byte_cnt = rec_len;
2170 if (byte_cnt >= rbuf_size)
2171 (void) alloc_rbuf(byte_cnt, FALSE);
2172 (void) memcpy(rbufp, in_recp, byte_cnt);
2173 accessed = TRUE;
2174 } else {
2175 /* sequential read */
2176 int ch;
2177 char *p;
2178
2179 f->nextrec++;
2180 p = rbufp;
2181 byte_cnt = 0;
2182
2183 while (TRUE) {
2184 if (byte_cnt >= rbuf_size)
2185 p = alloc_rbuf(byte_cnt, TRUE);
2186 ch = __io_fgetc(f->fp);
2187 if (ch == EOF) {
2188 if (__io_feof(f->fp)) {
2189 if (byte_cnt)
2190 break;
2191 return FIO_EEOF;
2192 }
2193 return __io_errno();
2194 }
2195 if (ch == '\r' && EOR_CRLF) {
2196 ch = __io_fgetc(f->fp);
2197 if (ch == '\n')
2198 break;
2199 __io_ungetc(ch, f->fp);
2200 ch = '\r';
2201 }
2202 if (ch == '\n')
2203 break;
2204 byte_cnt++;
2205 *p++ = ch;
2206 }
2207 }
2208 rbufp[byte_cnt] = '\n';
2209 currc = rbufp;
2210 if (DBGBIT(0x2)) {
2211 __io_printf("read_rec: byte_cnt %d\n", byte_cnt);
2212 __io_printf("#%.*s#\n", byte_cnt, rbufp);
2213 }
2214
2215 return 0;
2216 }
2217
2218 static char *
alloc_rbuf(int size,bool copy)2219 alloc_rbuf(int size, bool copy)
2220 {
2221 int old_size;
2222
2223 old_size = rbuf_size;
2224 rbuf_size = size + 128;
2225 if (rbufp == rbuf) {
2226 rbufp = malloc(rbuf_size);
2227 if (copy)
2228 (void) memcpy(rbufp, rbuf, old_size);
2229 } else
2230 rbufp = realloc(rbufp, rbuf_size);
2231 return rbufp + size;
2232 }
2233
2234 static int
dtio_read_scalar(NML_DESC * descp,char * loc_addr)2235 dtio_read_scalar(NML_DESC *descp, char *loc_addr)
2236 {
2237
2238 static __INT_T internal_unit = -1;
2239 __INT_T tmp_iostat = 0;
2240 __INT_T *iostat;
2241 __INT_T *unit;
2242 void (*dtio)(char *, INT *, char *, INT *, INT *, char *, F90_Desc *,
2243 F90_Desc *, __CLEN_T, __CLEN_T);
2244 char *dtv;
2245 F90_Desc *dtv_sd;
2246 F90_Desc *vlist_sd;
2247 INT *vlist;
2248 NML_DESC *next_descp;
2249 NML_DESC *start_descp;
2250 __CLEN_T iotypelen = 8;
2251 __CLEN_T iomsglen = 250;
2252 static char iomsg[250];
2253 int k, num_consts, ret_err, j;
2254 char *iotype = "NAMELIST";
2255 char *start_addr;
2256 char *mem_addr;
2257 __POINT_T *desc_dims, new_ndims;
2258 __POINT_T actual_ndims;
2259 int ch, i;
2260
2261 /* if this is array */
2262 num_consts = 1;
2263 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
2264 if (descp->ndims == -2) {
2265 new_ndims = *(__POINT_T *)((char *)descp + sizeof(__POINT_T));
2266 num_consts = nelems_of(descp);
2267 } else {
2268 num_consts = nelems_of(descp);
2269 }
2270
2271 actual_ndims = 0;
2272 if (descp->ndims == -2) {
2273 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
2274 } else if (descp->ndims == MAX_DIM) {
2275 ACTUAL_NDIMS(actual_ndims);
2276 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
2277 } else if (descp->ndims > MAX_DIM) {
2278 ACTUAL_NDIMS(actual_ndims);
2279 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
2280 } else {
2281 #if DEBUG
2282 printf("ERROR unexpected ndims:%d\n", (int)descp->ndims);
2283 #endif
2284 return ERR_FLAG;
2285 }
2286
2287 /* next_descp is now at the start of the defined io arguments */
2288 next_descp = (NML_DESC *)((char *)descp + k);
2289
2290 /* after above, next_descp is now at -98, beginning of dinit define io
2291 * arguments */
2292
2293 if (descp->type != __DERIVED) {
2294 #if DEBUG
2295 printf("ERROR unexpected dtype, expecting derived type\n");
2296 #endif
2297 return ERR_FLAG;
2298 }
2299
2300 /* move to user defined io read*/
2301 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
2302 next_descp = (NML_DESC *)desc_dims;
2303 dtio = (void *)*(char **)((char *)desc_dims);
2304 #if DEBUG
2305 if ((INT *)dtio == 0) {
2306 printf("ERROR: unable find user defined io read routine \n");
2307 }
2308 #endif
2309
2310 /* skip write routine */
2311 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
2312 next_descp = (NML_DESC *)desc_dims;
2313
2314 /* dtv */
2315 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
2316 next_descp = (NML_DESC *)desc_dims;
2317 dtv = (char *)*(char **)((char *)desc_dims);
2318 start_addr = (char *)dtv;
2319
2320 /* dtv$sd */
2321 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
2322 next_descp = (NML_DESC *)desc_dims;
2323 dtv_sd = (F90_Desc *)*(char **)((char *)desc_dims);
2324
2325 /* vlist */
2326 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
2327 next_descp = (NML_DESC *)desc_dims;
2328 vlist = (INT *)*(char **)((char *)desc_dims);
2329
2330 /* vlist$sd */
2331 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
2332 next_descp = (NML_DESC *)desc_dims;
2333 vlist_sd = (F90_Desc *)*(char **)((char *)desc_dims);
2334
2335 /* move to next descriptor */
2336 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
2337 next_descp = (NML_DESC *)desc_dims;
2338
2339 start_descp = next_descp;
2340 start_addr = loc_addr;
2341 if (gbl->unit)
2342 unit = gbl->unit;
2343 else
2344 unit = &internal_unit;
2345
2346 if (gbl->iostat)
2347 iostat = gbl->iostat;
2348 else
2349 iostat = &tmp_iostat;
2350
2351 (*dtio)(start_addr, unit, iotype, vlist, iostat, iomsg, dtv_sd, vlist_sd,
2352 iotypelen, iomsglen);
2353 if (*iostat != 0)
2354 return *iostat;
2355 start_addr = start_addr + descp->len;
2356 if (!internal_file && f->pback) {
2357 currc = f->pback;
2358 f->pback = 0;
2359 }
2360 return 0;
2361 }
2362