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 Initialization and error handling functions for Fortran I/O
22 */
23
24 #include <errno.h>
25 #include <string.h> /* for declarations of memcpy and memset */
26 #include "global.h"
27
28 typedef struct {
29 char *name;
30 __CLEN_T len;
31 int lineno;
32 } src_info_struct;
33
34 static src_info_struct src_info;
35
36 static int current_unit;
37 static INT *iostat_ptr;
38 static int iobitv;
39 static char *err_str = "?";
40 char *envar_fortranopt;
41
42 static char *iomsg; /* pointer for optional IOMSG area */
43 static __CLEN_T iomsgl; /* length of above */
44
45 typedef struct {
46 INT *enctab;
47 } f90fmt;
48
49 typedef struct {
50 src_info_struct src_info;
51 int current_unit;
52 bool newunit;
53 INT *iostat_ptr;
54 int iobitv;
55 char *err_str;
56 char *envar_fortranopt;
57 char *iomsg;
58 __CLEN_T iomsgl;
59
60 /* fioFcbTbls stuff */
61 FIO_FCB *fcbs;
62 INT *enctab;
63 char *fname;
64 int fnamelen;
65 bool error;
66 bool eof;
67 bool pos_present;
68 seekoffx_t pos;
69
70 } fioerror;
71
72 #define GBL_SIZE 15
73 static int gbl_size = 15;
74 static int gbl_avl = 0;
75 static fioerror static_gbl[GBL_SIZE];
76 static fioerror *gbl = &static_gbl[0];
77 static fioerror *gbl_head = &static_gbl[0];
78
79 static int fmtgbl_size = 15;
80 static int fmtgbl_avl = 0;
81 static f90fmt static_fmtgbl[GBL_SIZE];
82 static f90fmt *fmtgbl = &static_fmtgbl[0];
83 static f90fmt *fmtgbl_head = &static_fmtgbl[0];
84
85 static void ioerrinfo(FIO_FCB *);
86 static void __fortio_init(void);
87
88 #include "fort_vars.h"
89 extern void f90_compiled();
90
91 /* --------------------------------------------------------------------- */
92 void
set_gbl_newunit(bool newunit)93 set_gbl_newunit(bool newunit)
94 {
95 gbl->newunit = newunit;
96 }
97
98 bool
get_gbl_newunit()99 get_gbl_newunit()
100 {
101 return gbl->newunit;
102 }
103
104 /* --------------------------------------------------------------- */
105 static void
save_gbl()106 save_gbl()
107 {
108 if (gbl_avl) {
109 gbl->iostat_ptr = iostat_ptr;
110 gbl->err_str = err_str;
111 gbl->current_unit = current_unit;
112 gbl->iobitv = iobitv;
113 gbl->envar_fortranopt = envar_fortranopt;
114
115 gbl->error = fioFcbTbls.error;
116 gbl->eof = fioFcbTbls.eof;
117 gbl->pos_present = fioFcbTbls.pos_present;
118 gbl->pos = fioFcbTbls.pos;
119 gbl->fname = fioFcbTbls.fname;
120 gbl->fnamelen = fioFcbTbls.fnamelen;
121 }
122 }
123
124 static void
restore_gbl()125 restore_gbl()
126 {
127 if (gbl_avl) {
128 iostat_ptr = gbl->iostat_ptr;
129 err_str = gbl->err_str;
130 current_unit = gbl->current_unit;
131 iobitv = gbl->iobitv;
132 envar_fortranopt = gbl->envar_fortranopt;
133 iomsg = gbl->iomsg;
134 iomsgl = gbl->iomsgl;
135 src_info.name = gbl->src_info.name;
136 src_info.len = gbl->src_info.len;
137 src_info.lineno = gbl->src_info.lineno;
138
139 if (gbl->current_unit != current_unit) {
140 fioFcbTbls.error = gbl->error;
141 fioFcbTbls.eof = gbl->eof;
142 } else {
143 /* may need to recursively check current_unit with other gbl->current_unit
144 * if it is a match, then save fioFcbTbls.error/eof to that gbl? F2008?
145 */
146 }
147 fioFcbTbls.pos_present = gbl->pos_present;
148 fioFcbTbls.pos = gbl->pos;
149 fioFcbTbls.fname = gbl->fname;
150 fioFcbTbls.fnamelen = gbl->fnamelen;
151 }
152 }
153
154 static void
free_gbl()155 free_gbl()
156 {
157 --gbl_avl;
158 if (gbl_avl <= 0)
159 gbl_avl = 0;
160 if (gbl_avl == 0)
161 gbl = &gbl_head[0];
162 else
163 gbl = &gbl_head[gbl_avl - 1];
164 }
165
166 static void
allocate_new_gbl()167 allocate_new_gbl()
168 {
169 fioerror *tmp_gbl;
170 if (gbl_avl >= gbl_size) {
171 if (gbl_size == GBL_SIZE) {
172 gbl_size = gbl_size + 15;
173 tmp_gbl = (fioerror *)malloc(sizeof(fioerror) * gbl_size);
174 memcpy(tmp_gbl, gbl_head, sizeof(fioerror) * gbl_avl);
175 gbl_head = tmp_gbl;
176 } else {
177 gbl_size = gbl_size + 15;
178 gbl_head = (fioerror *)realloc(gbl_head, sizeof(fioerror) * gbl_size);
179 }
180 }
181 gbl = &gbl_head[gbl_avl];
182 memset(gbl, 0, sizeof(fioerror));
183 ++gbl_avl;
184 }
185
186 static void
allocate_new_fmtgbl()187 allocate_new_fmtgbl()
188 {
189 f90fmt *tmp_gbl;
190 if (fmtgbl_avl >= fmtgbl_size) {
191 if (fmtgbl_size == GBL_SIZE) {
192 fmtgbl_size = fmtgbl_size + 15;
193 tmp_gbl = (f90fmt *)malloc(sizeof(f90fmt) * fmtgbl_size);
194 memcpy(tmp_gbl, fmtgbl_head, sizeof(f90fmt) * fmtgbl_avl);
195 fmtgbl_head = tmp_gbl;
196 } else {
197 fmtgbl_size = fmtgbl_size + 15;
198 fmtgbl_head =
199 (f90fmt *)realloc(fmtgbl_head, sizeof(f90fmt) * fmtgbl_size);
200 }
201 }
202 fmtgbl = &fmtgbl_head[fmtgbl_avl];
203 memset(fmtgbl, 0, sizeof(f90fmt));
204 ++fmtgbl_avl;
205 }
206
207 static void
free_fmtgbl()208 free_fmtgbl()
209 {
210 --fmtgbl_avl;
211 if (fmtgbl_avl <= 0)
212 fmtgbl_avl = 0;
213 if (fmtgbl_avl == 0)
214 fmtgbl = &fmtgbl_head[0];
215 else
216 fmtgbl = &fmtgbl_head[fmtgbl_avl - 1];
217 }
218
219 static void
restore_fmtgbl()220 restore_fmtgbl()
221 {
222 if (fmtgbl_avl) {
223 fioFcbTbls.enctab = fmtgbl->enctab;
224 }
225 }
226
227 static void
save_fmtgbl()228 save_fmtgbl()
229 {
230 if (fmtgbl_avl) {
231 fmtgbl->enctab = fioFcbTbls.enctab;
232 }
233 }
234
235 /* --------------------------------------------------------------- */
236
237 extern void
__fortio_errinit(__INT_T unit,__INT_T bitv,__INT_T * iostat,char * str)238 __fortio_errinit(__INT_T unit, __INT_T bitv, __INT_T *iostat, char *str)
239 {
240 if (fioFcbTbls.fcbs == NULL)
241 __fortio_init();
242
243 fioFcbTbls.error = FALSE;
244 fioFcbTbls.eof = FALSE;
245 fioFcbTbls.fname = NULL;
246
247 current_unit = unit;
248 iobitv = bitv;
249 if (iobitv & FIO_BITV_IOSTAT) {
250 iostat_ptr = iostat;
251 *iostat_ptr = 0;
252 } else {
253 iostat_ptr = NULL;
254 }
255
256 /* save str for error messages ... */
257 err_str = str;
258
259 }
260
261 extern void
__fortio_errinit03(__INT_T unit,__INT_T bitv,__INT_T * iostat,char * str)262 __fortio_errinit03(__INT_T unit, __INT_T bitv, __INT_T *iostat, char *str)
263 {
264 if (fioFcbTbls.fcbs == NULL)
265 __fortio_init();
266
267 save_gbl();
268
269 fioFcbTbls.error = FALSE;
270 fioFcbTbls.eof = FALSE;
271 fioFcbTbls.fname = NULL;
272
273 current_unit = unit;
274 iobitv = bitv;
275 if (iobitv & FIO_BITV_IOSTAT) {
276 iostat_ptr = iostat;
277 *iostat_ptr = 0;
278 } else {
279 iostat_ptr = NULL;
280 }
281
282 /* save str for error messages ... */
283 err_str = str;
284 }
285 extern void
__fortio_errend03()286 __fortio_errend03()
287 /* restore the previous value of previous status of io error.*/
288 {
289 free_gbl();
290 restore_gbl();
291 }
292
293 extern void
__fortio_fmtinit()294 __fortio_fmtinit()
295 /* restore the previous value of previous status of enctab.*/
296 {
297 save_fmtgbl();
298 allocate_new_fmtgbl();
299 }
300
301 extern void
__fortio_fmtend(void)302 __fortio_fmtend(void)
303 /* restore the previous value of enctab.*/
304 {
305 free_fmtgbl();
306 restore_fmtgbl();
307 }
308
309 /* --------------------------------------------------------------- */
310
311 /* define text for error messages: */
312
313 #define X(str) str,
314
315 static char *errtxt[] = {
316 X("xxx") /* 200 */
317 X("illegal value for specifier") /* ESPEC 201 */
318 X("conflicting specifiers") /* ECOMPAT 202 */
319 X("record length must be specified") /* ERECLEN 203 */
320 X("illegal use of a read-only file") /* EREADONLY 204 */
321 X("'SCRATCH' and 'SAVE'/'KEEP' both specified") /* EDISPOSE 205 */
322 X("attempt to open a named file as 'SCRATCH'") /* ESCRATCH 206 */
323 X("file is already connected to another unit") /* EOPENED 207 */
324 X("'NEW' specified for file which already exists") /* EEXIST 208 */
325 X("'OLD' specified for file which does not exist") /* ENOEXIST 209 */
326
327 X("dynamic memory allocation failed") /* ENOMEM 210 */
328 X("invalid file name") /* ENAME 211 */
329 X("invalid unit number") /* EUNIT 212 */
330 X("RECL cannot be present") /* ERECL 213 */
331 X("READ not allowed for write-only file") /* EWRITEONLY 214 */
332 X("formatted/unformatted file conflict") /* EFORM 215 */
333 X("www") /* 216 */
334 X("attempt to read past end of file") /* EEOF 217 */
335 X("attempt to read (nonadvancing) past end of record") /* EEOR 218 */
336 X("attempt to read/write past end of record") /* ETOOBIG 219 */
337
338 X("write after last internal record") /* ETOOFAR 220 */
339 X("syntax error in format string") /* EFSYNTAX 221 */
340 X("unbalanced parentheses in format string") /* EPAREN 222 */
341 X("illegal P, T or B edit descriptor - value missing") /* EPT 223 */
342 X("illegal Hollerith or character string in format") /* ESTRING 224 */
343 X("lexical error-- unknown token type") /* ELEX 225 */
344 X("unrecognized edit descriptor letter in format") /* ELETTER 226 */
345 X("ccc") /* 227 */
346 X("end of file reached without finding group") /* ENOGROUP 228 */
347 X("end of file reached while processing group") /* ENMLEOF 229 */
348
349 X("scale factor not in range -128 to 127") /* ESCALEF 230 */
350 X("error on data conversion") /* EERR_DATA_CONVERSION231 */
351 X("fff") /* 232 */
352 X("too many constants to initialize group item") /* ETOOM 233 */
353 X("invalid edit descriptor") /* EEDITDSCR 234 */
354 X("edit descriptor does not match item type") /* EMISMATCH 235 */
355 X("formatted record longer than 2000 characters") /* EBIGREC 236 */
356 X("quad precision type unsupported") /* EQUAD 237 */
357 X("tab value out of range") /* ETAB_VALUE_OUT_OF_RANGE 238 */
358 X("entity name is not member of group") /* ENOTMEM 239 */
359 X("no initial left parenthesis in format string") /* ELPAREN 240 */
360 X("unexpected end of format string") /* EENDFMT 241 */
361 X("illegal operation on direct access file") /* EDIRECT 242 */
362 X("format parentheses nesting depth too great") /* EPNEST 243 */
363 X("syntax error - entity name expected") /* ENONAME 244 */
364 X("syntax error within group definition") /* ESYNTAX 245 */
365 X("infinite format scan for edit descriptor") /* EINFINITE_REVERSION 246 */
366 X("ggg") /* 247 */
367 X("illegal subscript or substring specification") /* ESUBSC 248 */
368 X("error in format - illegal E, F, G or D descriptor") /* EFGD 249 */
369
370 X("error in format - number missing after '.', '-', or '+'") /* EDOT 250 */
371 X("illegal character in format string") /* ECHAR 251 */
372 X("operation attempted after end of file") /* EEOFERR 252 */
373 X("attempt to read non-existent record (direct access)") /* EDREAD 253 */
374 X("illegal repeat count in format") /* EREPCNT 254 */
375 X("illegal asynchronous I/O operation") /* EASYNC 255 */
376 X("POS can only be specified for a 'STREAM' file") /* EPOS 256 */
377 X("POS value must be positive") /* EPOSV 257 */
378 X("NEWUNIT requires FILE or STATUS=SCRATCH") /* ENEWUNIT 258 */
379 };
380
381 /* include Kanji error message text: */
382
383 #include "kanjidf.h"
384
385 /* ------------------------------------------------------------------ */
386
387 int
__fortio_error(int errval)388 __fortio_error(int errval)
389 {
390 FIO_FCB *fdesc;
391 char *eoln, *txt;
392 int one = 1;
393 int retval;
394
395 assert(errval > 0);
396 retval = ERR_FLAG;
397
398 if (errval == FIO_EEOF) /* handle end-of-file separately */
399 return __fortio_eoferr(FIO_EEOF);
400 if (errval == FIO_EEOFERR) /* handle end-of-file separately */
401 return __fortio_eoferr(FIO_EEOFERR);
402
403 if (errval == FIO_EEOR) /* handle end-of-record separately */
404 return __fortio_eorerr(FIO_EEOR);
405
406 fdesc = __fortio_find_unit(current_unit);
407
408 if (iobitv == FIO_BITV_NONE || iobitv == FIO_BITV_EOF) {
409 /* Abort if:
410 * 1. no specifier, or
411 * 2. just the END= was specified.
412 */
413 eoln = "\n";
414 if (errval >= FIO_ERROR_OFFSET) {
415 txt = __fortio_errmsg(errval);
416 if (current_unit == -99) /* internal file */
417 __io_fprintf(__io_stderr(), "FIO-F-%d/%s/internal file/%s.%s",
418 errval, err_str, txt, eoln);
419 else
420 __io_fprintf(__io_stderr(), "FIO-F-%d/%s/unit=%d/%s.%s", errval,
421 err_str, current_unit, txt, eoln);
422 } else {
423 __io_perror("FIO/stdio");
424 __io_fprintf(__io_stderr(), "FIO-F-/%s/unit=%d/%s - %d.%s", err_str,
425 current_unit, "error code returned by host stdio", errval,
426 eoln);
427 }
428 ioerrinfo(fdesc);
429 __fort_abort((char *)0);
430 }
431
432 /* At this point, at least one of {IOSTAT,ERR,END,EOR} was specified. */
433
434 if (iobitv & FIO_BITV_IOSTAT)
435 *iostat_ptr = errval;
436
437 if (iobitv & FIO_BITV_ERR) {
438 retval = ERR_FLAG;
439 }
440
441 if (iobitv & FIO_BITV_IOMSG) {
442 strncpy(iomsg, __fortio_errmsg(errval), iomsgl);
443 }
444
445 fioFcbTbls.error = TRUE;
446 if (fdesc && fdesc->fp && fdesc->acc == FIO_DIRECT) {
447 /* leave file in consistent state: */
448 fdesc->nextrec = 1;
449 __io_fseek(fdesc->fp, 0L, SEEK_SET);
450 }
451
452 if ((iobitv & FIO_BITV_EOR) && (errval == FIO_ETOOBIG)) {
453 retval = EOR_FLAG;
454 }
455
456 return retval;
457 }
458
459 /* ------------------------------------------------------------------ */
460
461 /* FIXME: this routine is a duplicate of
462 * runtime/lib/pgftn/error.h:__fio_errmsg
463 */
464 extern char *
__fortio_errmsg(int errval)465 __fortio_errmsg(int errval)
466 {
467 char *txt;
468 static char buf[128];
469 if (errval == 0) {
470 buf[0] = ' ';
471 buf[1] = '\0';
472 txt = buf;
473 } else if (errval >= FIO_ERROR_OFFSET) {
474 if (errval - FIO_ERROR_OFFSET >= sizeof(errtxt) / sizeof(errtxt[0])) {
475 sprintf(buf, "get_iostat_msg: iostat value %d is out of range", errval);
476 txt = buf;
477 } else if ((txt = getenv("LANG")) && strcmp(txt, "japan") == 0)
478 txt = kanjitxt[errval - FIO_ERROR_OFFSET];
479 else {
480 txt = errtxt[errval - FIO_ERROR_OFFSET];
481 }
482 } else
483 txt = strerror(errval);
484 return txt;
485 }
486
487 /* Return 0 when it's internal file and iobitv = 0 */
488 int
read_record_internal()489 read_record_internal()
490 {
491 if (iobitv == FIO_BITV_NONE && current_unit == -99) {
492 return 0;
493 } else {
494 return FIO_EEOF;
495 }
496 }
497
498 int
__fortio_eoferr(int errval)499 __fortio_eoferr(int errval)
500 {
501 FIO_FCB *fdesc;
502 char *eoln, *txt, *tmp;
503 int one = 1;
504
505 assert(errval > FIO_ERROR_OFFSET);
506
507 fdesc = __fortio_find_unit(current_unit);
508 assert(fdesc == NULL || fdesc->acc != FIO_DIRECT);
509
510 if (iobitv == FIO_BITV_NONE ||
511 (iobitv & (FIO_BITV_IOSTAT | FIO_BITV_EOF)) == 0) {
512 /* Abort if:
513 * 1. no specifier, or
514 * 2. neither iostat nor eof were specified.
515 */
516 eoln = "\n";
517 txt = __fortio_errmsg(errval);
518
519 if (current_unit == -99) /* internal file */
520 __io_fprintf(__io_stderr(), "FIO-F-%d/%s/internal file/%s.%s",
521 errval, err_str, txt, eoln);
522 else
523 __io_fprintf(__io_stderr(), "FIO-F-%d/%s/unit=%d/%s.%s", errval,
524 err_str, current_unit, txt, eoln);
525 ioerrinfo(fdesc);
526 __fort_abort((char *)0);
527 }
528
529 /* At this point, end-of-file occurred and IOSTAT, END, or both, was
530 * specified.
531 */
532 if (iobitv & FIO_BITV_IOSTAT)
533 *iostat_ptr = -1;
534 if (iobitv & FIO_BITV_IOMSG) {
535 /* tmp = __fortio_errmsg(errval);
536 strncpy(iomsg, tmp, iomsgl);*/
537 strncpy(iomsg, __fortio_errmsg(errval), iomsgl);
538 }
539
540 fioFcbTbls.eof = TRUE;
541 if (fdesc) { /* indicate that 'eof record' has been read */
542 fdesc->eof_flag = TRUE;
543 }
544 return EOF_FLAG;
545 }
546
547 /** \brief end-of-record error when a nonadvancing read */
548 int
__fortio_eorerr(int errval)549 __fortio_eorerr(int errval)
550 {
551 FIO_FCB *fdesc;
552 char *eoln, *txt;
553 int one = 1;
554
555 assert(errval > FIO_ERROR_OFFSET);
556
557 fdesc = __fortio_find_unit(current_unit);
558 assert(fdesc == NULL || fdesc->acc != FIO_DIRECT);
559
560 if (iobitv == FIO_BITV_NONE ||
561 (iobitv & (FIO_BITV_IOSTAT | FIO_BITV_EOR)) == 0) {
562 /* Abort if:
563 * 1. no specifier, or
564 * 2. neither iostat nor eor were specified.
565 */
566 eoln = "\n";
567 txt = __fortio_errmsg(errval);
568
569 if (current_unit == -99) /* internal file */
570 __io_fprintf(__io_stderr(), "FIO-F-%d/%s/internal file/%s.%s",
571 errval, err_str, txt, eoln);
572 else
573 __io_fprintf(__io_stderr(), "FIO-F-%d/%s/unit=%d/%s.%s", errval,
574 err_str, current_unit, txt, eoln);
575 ioerrinfo(fdesc);
576 __fort_abort((char *)0);
577 }
578
579 /* At this point, end-of-file occurred and IOSTAT, EOR, or both, was
580 * specified.
581 */
582 if (iobitv & FIO_BITV_IOSTAT)
583 *iostat_ptr = -2;
584 fioFcbTbls.error = TRUE; /* TBD - does there need to be fioFcbTbls.eor */
585 return EOR_FLAG;
586 }
587
588 /* ------------------------------------------------------------------- */
589
590 static void
ioerrinfo(FIO_FCB * fdesc)591 ioerrinfo(FIO_FCB *fdesc)
592 {
593 char *eoln;
594 FILE *fp; /* stderr */
595
596 fp = __io_stderr();
597 eoln = "\n";
598 if (fdesc != NULL) {
599 __io_fprintf(fp, " File name = '");
600 if (fdesc->name != NULL)
601 __io_fprintf(fp, "%s", fdesc->name);
602
603 if (fdesc->form == FIO_FORMATTED) {
604 __io_fprintf(fp, "', formatted, ");
605 } else {
606 __io_fprintf(fp, "', unformatted, ");
607 }
608
609 if (fdesc->acc == FIO_DIRECT) {
610 __io_fprintf(fp, "direct access ");
611 } else if (fdesc->acc == FIO_STREAM) {
612 __io_fprintf(fp, "stream access ");
613 } else {
614 __io_fprintf(fp, "sequential access ");
615 }
616 if (fdesc->asyptr != (void *)0) {
617 if (fdesc->asy_rw) {
618 fprintf(fp, "async/active ");
619 } else {
620 fprintf(fp, "async ");
621 }
622 }
623 __io_fprintf(fp, " record = %ld%s", fdesc->nextrec - 1, eoln);
624 } else if (fioFcbTbls.fname != NULL)
625 __io_fprintf(fp, " File name = %.*s%s", fioFcbTbls.fnamelen, fioFcbTbls.fname,
626 eoln);
627
628 __io_fprintf(fp, " In source file %.*s,", src_info.len, src_info.name);
629 __io_fprintf(fp, " at line number %d%s", src_info.lineno, eoln);
630 }
631
632 /* ---------------------------------------------------------------- */
633
634 static void
set_src_info()635 set_src_info()
636 {
637 allocate_new_gbl();
638 gbl->src_info.lineno = src_info.lineno;
639 gbl->src_info.name = src_info.name;
640 gbl->src_info.len = src_info.len;
641 gbl->pos_present = fioFcbTbls.pos_present;
642 }
643
ENTF90IO(SRC_INFOA,src_info03a)644 void ENTF90IO(SRC_INFOA, src_info03a)(
645 __INT_T *lineno, /* line number of i/o stmt in source file */
646 DCHAR(name) /* name of source file */
647 DCLEN64(name))
648 {
649 src_info.lineno = *lineno;
650 src_info.name = CADR(name);
651 src_info.len = CLEN(name);
652 fioFcbTbls.pos_present = FALSE;
653 set_src_info();
654 }
655 /* 32 bit CLEN version */
ENTF90IO(SRC_INFO,src_info03)656 void ENTF90IO(SRC_INFO, src_info03)(
657 __INT_T *lineno, /* line number of i/o stmt in source file */
658 DCHAR(name) /* name of source file */
659 DCLEN(name))
660 {
661 ENTF90IO(SRC_INFOA, src_info03a)(lineno, CADR(name), (__CLEN_T)CLEN(name));
662 }
663
ENTF90IO(SRC_INFOXA,src_infox03a)664 void ENTF90IO(SRC_INFOXA, src_infox03a)(
665 __INT_T lineno, /* line number of i/o stmt in source file */
666 DCHAR(name) /* name of source file */
667 DCLEN64(name))
668 {
669 src_info.lineno = lineno;
670 src_info.name = CADR(name);
671 src_info.len = CLEN(name);
672 fioFcbTbls.pos_present = FALSE;
673 set_src_info();
674 }
675 /* 32 bit CLEN version */
ENTF90IO(SRC_INFOX,src_infox03)676 void ENTF90IO(SRC_INFOX, src_infox03)(
677 __INT_T lineno, /* line number of i/o stmt in source file */
678 DCHAR(name) /* name of source file */
679 DCLEN(name))
680 {
681 ENTF90IO(SRC_INFOXA, src_infox03a)(lineno, CADR(name), (__CLEN_T)CLEN(name));
682 }
683
ENTCRF90IO(SRC_INFOA,src_info03a)684 void ENTCRF90IO(SRC_INFOA, src_info03a)(
685 __INT_T *lineno, /* line number of i/o stmt in source file */
686 DCHAR(name) /* name of source file */
687 DCLEN64(name))
688 {
689 src_info.lineno = *lineno;
690 src_info.name = CADR(name);
691 src_info.len = CLEN(name);
692 set_src_info();
693 }
694 /* 32 bit CLEN version */
ENTCRF90IO(SRC_INFO,src_info03)695 void ENTCRF90IO(SRC_INFO, src_info03)(
696 __INT_T *lineno, /* line number of i/o stmt in source file */
697 DCHAR(name) /* name of source file */
698 DCLEN(name))
699 {
700 ENTCRF90IO(SRC_INFOA, src_info03a)(lineno, CADR(name), (__CLEN_T)CLEN(name));
701 }
702
ENTCRF90IO(SRC_INFOXA,src_infox03a)703 void ENTCRF90IO(SRC_INFOXA, src_infox03a)(
704 __INT_T lineno, /* line number of i/o stmt in source file */
705 DCHAR(name) /* name of source file */
706 DCLEN64(name))
707 {
708 src_info.lineno = lineno;
709 src_info.name = CADR(name);
710 src_info.len = CLEN(name);
711 set_src_info();
712 }
713 /* 32 bit CLEN version */
ENTCRF90IO(SRC_INFOX,src_infox03)714 void ENTCRF90IO(SRC_INFOX, src_infox03)(
715 __INT_T lineno, /* line number of i/o stmt in source file */
716 DCHAR(name) /* name of source file */
717 DCLEN(name))
718 {
719 ENTCRF90IO(SRC_INFOXA, src_infox03a)(lineno, CADR(name), (__CLEN_T)CLEN(name));
720 }
721
ENTF90IO(SRC_INFOA,src_infoa)722 void ENTF90IO(SRC_INFOA, src_infoa)(
723 __INT_T *lineno, /* line number of i/o stmt in source file */
724 DCHAR(name) /* name of source file */
725 DCLEN64(name))
726 {
727 src_info.lineno = *lineno;
728 src_info.name = CADR(name);
729 src_info.len = CLEN(name);
730 fioFcbTbls.pos_present = FALSE;
731 }
732 /* 32 bit CLEN version */
ENTF90IO(SRC_INFO,src_info)733 void ENTF90IO(SRC_INFO, src_info)(
734 __INT_T *lineno, /* line number of i/o stmt in source file */
735 DCHAR(name) /* name of source file */
736 DCLEN(name))
737 {
738 ENTF90IO(SRC_INFOA, src_infoa)(lineno, CADR(name), (__CLEN_T)CLEN(name));
739 }
740
ENTF90IO(SRC_INFOXA,src_infoxa)741 void ENTF90IO(SRC_INFOXA, src_infoxa)(
742 __INT_T lineno, /* line number of i/o stmt in source file */
743 DCHAR(name) /* name of source file */
744 DCLEN64(name))
745 {
746 src_info.lineno = lineno;
747 src_info.name = CADR(name);
748 src_info.len = CLEN(name);
749 fioFcbTbls.pos_present = FALSE;
750 }
751 /* 32 bit CLEN version */
ENTF90IO(SRC_INFOX,src_infox)752 void ENTF90IO(SRC_INFOX, src_infox)(
753 __INT_T lineno, /* line number of i/o stmt in source file */
754 DCHAR(name) /* name of source file */
755 DCLEN(name))
756 {
757 ENTF90IO(SRC_INFOXA, src_infoxa)(lineno, CADR(name), (__CLEN_T)CLEN(name));
758 }
759
ENTCRF90IO(SRC_INFOA,src_infoa)760 void ENTCRF90IO(SRC_INFOA, src_infoa)(
761 __INT_T *lineno, /* line number of i/o stmt in source file */
762 DCHAR(name) /* name of source file */
763 DCLEN64(name))
764 {
765 src_info.lineno = *lineno;
766 src_info.name = CADR(name);
767 src_info.len = CLEN(name);
768 }
769 /* 32 bit CLEN version */
ENTCRF90IO(SRC_INFO,src_info)770 void ENTCRF90IO(SRC_INFO, src_info)(
771 __INT_T *lineno, /* line number of i/o stmt in source file */
772 DCHAR(name) /* name of source file */
773 DCLEN(name))
774 {
775 ENTCRF90IO(SRC_INFOA, src_infoa)(lineno, CADR(name), (__CLEN_T)CLEN(name));
776 }
777
ENTCRF90IO(SRC_INFOXA,src_infoxa)778 void ENTCRF90IO(SRC_INFOXA, src_infoxa)(
779 __INT_T lineno, /* line number of i/o stmt in source file */
780 DCHAR(name) /* name of source file */
781 DCLEN64(name))
782 {
783 src_info.lineno = lineno;
784 src_info.name = CADR(name);
785 src_info.len = CLEN(name);
786 }
787 /* 32 bit CLEN version */
ENTCRF90IO(SRC_INFOX,src_infox)788 void ENTCRF90IO(SRC_INFOX, src_infox)(
789 __INT_T lineno, /* line number of i/o stmt in source file */
790 DCHAR(name) /* name of source file */
791 DCLEN(name))
792 {
793 ENTCRF90IO(SRC_INFOXA, src_infoxa)(lineno, CADR(name), (__CLEN_T)CLEN(name));
794 }
795
796 /* ---------------------------------------------------------------- */
797
798 static void
set_iomsg()799 set_iomsg()
800 {
801 gbl->iomsg = iomsg;
802 gbl->iomsgl = iomsgl;
803 }
804
ENTF90IO(IOMSGA,iomsga)805 void ENTF90IO(IOMSGA, iomsga)(DCHAR(msg) DCLEN64(msg))
806 {
807 iomsg = CADR(msg);
808 iomsgl = CLEN(msg);
809 set_iomsg();
810 }
811 /* 32 bit CLEN version */
ENTF90IO(IOMSG,iomsg)812 void ENTF90IO(IOMSG, iomsg)(DCHAR(msg) DCLEN(msg))
813 {
814 ENTF90IO(IOMSGA, iomsga)(CADR(msg), (__CLEN_T)CLEN(msg));
815 }
816
ENTCRF90IO(IOMSGA,iomsga)817 void ENTCRF90IO(IOMSGA, iomsga)(DCHAR(msg) DCLEN64(msg))
818 {
819 iomsg = CADR(msg);
820 iomsgl = CLEN(msg);
821 set_iomsg();
822 }
823 /* 32 bit CLEN version */
ENTCRF90IO(IOMSG,iomsg)824 void ENTCRF90IO(IOMSG, iomsg)(DCHAR(msg) DCLEN(msg))
825 {
826 ENTCRF90IO(IOMSGA, iomsga)(CADR(msg), (__CLEN_T)CLEN(msg));
827 }
828
829 /* ------------------------------------------------------------------- */
830
831 #if !defined(TARGET_WIN)
832 #define WIN_SET_BINARY(f)
833 #else
834 #define WIN_SET_BINARY(f) win_set_binary(f)
835 static void
win_set_binary(FIO_FCB * f)836 win_set_binary(FIO_FCB *f)
837 {
838 FILE *fil;
839
840 fil = f->fp;
841 if (!__fort_isatty(__fort_getfd(fil))) {
842 __fortio_setmode_binary(fil);
843 }
844 }
845 #endif
846
847 /* *** FORTRANOPT settings *****/
848 static int check_format = 1; /* format checking enabled */
849 static int crlf = 0; /* crlf does not denote end-of-line */
850 static int legacy_large_rec_fmt = 0; /* are legacy large unf records used */
851 static int no_minus_zero = 0; /* -0 allowed in formatted 0 */
852 static int new_fp_formatter = TRUE;
853
854 /** \brief initialize Fortran I/O system. Specifically, initialize
855 preconnected units: */
856 static void
__fortio_init(void)857 __fortio_init(void)
858 {
859 FIO_FCB *f;
860
861 assert(fioFcbTbls.fcbs == NULL);
862
863 /* preconnect stdin as unit -5 for * unit specifier */
864 f = __fortio_alloc_fcb();
865
866 f->fp = __io_stdin();
867 f->unit = -5;
868 f->name = "stdin ";
869 f->reclen = 0;
870 f->wordlen = 1;
871 f->nextrec = 1;
872 f->status = FIO_OLD;
873 f->dispose = FIO_KEEP;
874 f->acc = FIO_SEQUENTIAL;
875 f->action = FIO_READ;
876 f->blank = FIO_NULL;
877 f->form = FIO_FORMATTED;
878 f->coherent = 0;
879 f->skip = 0;
880 f->eof_flag = FALSE;
881 f->eor_flag = FALSE;
882 f->named = TRUE;
883 f->pad = FIO_YES;
884 f->stdunit = TRUE;
885 f->truncflag = FALSE;
886 f->nonadvance = FALSE;
887 f->ispipe = FALSE;
888 f->asy_rw = 0; /* init async flags */
889 f->asyptr = (void *)0;
890 f->pread = 0;
891 f->pback = 0;
892 WIN_SET_BINARY(f);
893
894 /* preconnect stdout as unit -6 for * unit specifier */
895 f = __fortio_alloc_fcb();
896
897 f->fp = __io_stdout();
898 f->unit = -6;
899 f->name = "stdout ";
900 f->reclen = 0;
901 f->wordlen = 1;
902 f->nextrec = 1;
903 f->status = FIO_OLD;
904 f->dispose = FIO_KEEP;
905 f->acc = FIO_SEQUENTIAL;
906 f->action = FIO_WRITE;
907 f->blank = FIO_NULL;
908 f->delim = FIO_NONE;
909 f->form = FIO_FORMATTED;
910 f->coherent = 0;
911 f->skip = 0;
912 f->eof_flag = FALSE;
913 f->eor_flag = FALSE;
914 f->named = TRUE;
915 f->stdunit = TRUE;
916 f->truncflag = FALSE;
917 f->nonadvance = FALSE;
918 f->ispipe = FALSE;
919 f->asy_rw = 0; /* init async flags */
920 f->asyptr = (void *)0;
921 f->pread = 0;
922 f->pback = 0;
923 WIN_SET_BINARY(f);
924
925 /* preconnect stdin as unit 5 */
926 f = __fortio_alloc_fcb();
927
928 f->fp = __io_stdin();
929 f->unit = 5;
930 f->name = "stdin ";
931 f->reclen = 0;
932 f->wordlen = 1;
933 f->nextrec = 1;
934 f->status = FIO_OLD;
935 f->dispose = FIO_KEEP;
936 f->acc = FIO_SEQUENTIAL;
937 f->action = FIO_READ;
938 f->blank = FIO_NULL;
939 f->form = FIO_FORMATTED;
940 f->coherent = 0;
941 f->skip = 0;
942 f->eof_flag = FALSE;
943 f->eor_flag = FALSE;
944 f->named = TRUE;
945 f->pad = FIO_YES;
946 f->stdunit = TRUE;
947 f->truncflag = FALSE;
948 f->nonadvance = FALSE;
949 f->ispipe = FALSE;
950 f->asy_rw = 0; /* init async flags */
951 f->asyptr = (void *)0;
952 f->pread = 0;
953 f->pback = 0;
954 WIN_SET_BINARY(f);
955
956 /* preconnect stdout as unit 6 */
957 f = __fortio_alloc_fcb();
958
959 f->fp = __io_stdout();
960 f->unit = 6;
961 f->name = "stdout ";
962 f->reclen = 0;
963 f->wordlen = 1;
964 f->nextrec = 1;
965 f->status = FIO_OLD;
966 f->dispose = FIO_KEEP;
967 f->acc = FIO_SEQUENTIAL;
968 f->action = FIO_WRITE;
969 f->blank = FIO_NULL;
970 f->delim = FIO_NONE;
971 f->form = FIO_FORMATTED;
972 f->coherent = 0;
973 f->skip = 0;
974 f->eof_flag = FALSE;
975 f->eor_flag = FALSE;
976 f->named = TRUE;
977 f->stdunit = TRUE;
978 f->truncflag = FALSE;
979 f->nonadvance = FALSE;
980 f->ispipe = FALSE;
981 f->asy_rw = 0; /* init async flags */
982 f->asyptr = (void *)0;
983 f->pread = 0;
984 f->pback = 0;
985 WIN_SET_BINARY(f);
986
987 /* preconnect stderr as unit 0 */
988 f = __fortio_alloc_fcb();
989
990 f->fp = __io_stderr();
991 f->unit = 0;
992 f->name = "stderr ";
993 f->reclen = 0;
994 f->wordlen = 1;
995 f->nextrec = 1;
996 f->status = FIO_OLD;
997 f->dispose = FIO_KEEP;
998 f->acc = FIO_SEQUENTIAL;
999 f->action = FIO_WRITE;
1000 f->blank = FIO_NULL;
1001 f->delim = FIO_NONE;
1002 f->form = FIO_FORMATTED;
1003 f->coherent = 0;
1004 f->skip = 0;
1005 f->eof_flag = FALSE;
1006 f->eor_flag = FALSE;
1007 f->named = TRUE;
1008 f->stdunit = TRUE;
1009 f->truncflag = FALSE;
1010 f->nonadvance = FALSE;
1011 f->ispipe = FALSE;
1012 f->asy_rw = 0; /* init async flags */
1013 f->pread = 0;
1014 f->pback = 0;
1015 f->asyptr = (void *)0;
1016
1017 /* check environment variables */
1018
1019 envar_fortranopt = __fort_getenv("FORTRANOPT");
1020 if (envar_fortranopt) {
1021 if (strstr(envar_fortranopt, "format_relaxed")) {
1022 check_format = 0;
1023 }
1024 if (strstr(envar_fortranopt, "crlf")) {
1025 crlf = 1;
1026 }
1027 if (strstr(envar_fortranopt, "pgi_legacy_large_rec_fmt")) {
1028 legacy_large_rec_fmt = 1;
1029 }
1030 if (strstr(envar_fortranopt, "no_minus_zero")) {
1031 no_minus_zero = 1;
1032 }
1033 if (strstr(envar_fortranopt, "no_new_fp_formatter") ||
1034 strstr(envar_fortranopt, "old_fp_formatter")) {
1035 new_fp_formatter = 0;
1036 } else if (strstr(envar_fortranopt, "new_fp_formatter")) {
1037 new_fp_formatter = 1;
1038 }
1039 }
1040 }
1041
1042 int
__fortio_check_format(void)1043 __fortio_check_format(void)
1044 {
1045 return check_format;
1046 }
1047
1048 int
__fortio_eor_crlf(void)1049 __fortio_eor_crlf(void)
1050 {
1051 return crlf;
1052 }
1053
1054 int
f90_old_huge_rec_fmt(void)1055 f90_old_huge_rec_fmt(void)
1056 {
1057 return legacy_large_rec_fmt;
1058 }
1059
1060 int
__fortio_no_minus_zero(void)1061 __fortio_no_minus_zero(void)
1062 {
1063 return no_minus_zero;
1064 }
1065
1066 int
__fortio_new_fp_formatter(void)1067 __fortio_new_fp_formatter(void)
1068 {
1069 return new_fp_formatter;
1070 }
1071
1072 static void
set_pos()1073 set_pos()
1074 {
1075 gbl->pos = fioFcbTbls.pos;
1076 gbl->pos_present = fioFcbTbls.pos_present;
1077 }
1078
ENTF90IO(IOMSG_,iomsg_)1079 void ENTF90IO(IOMSG_, iomsg_)(char *p, int n)
1080 {
1081 iomsg = p;
1082 iomsgl = n;
1083 }
1084
1085 /* ---------------------------------------------------------------- */
1086
ENTF90IO(AUX_INIT,aux_init)1087 void ENTF90IO(AUX_INIT, aux_init)(int mask, __INT8_T pos)
1088 {
1089 /*
1090 * More initialization depending on the value of mask; the intent
1091 * is to have a routine that will initialize for new features
1092 * that's backward's compatible. The routine is called after
1093 * the call to src_info and before the I/O-specific init routine.
1094 */
1095 if (mask & 0x1) {
1096 fioFcbTbls.pos_present = TRUE;
1097 fioFcbTbls.pos = pos;
1098 }
1099 set_pos();
1100 }
1101