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 /** \file
19 * \brief Utility functions for fortran i.o.
20 */
21
22 #include <errno.h>
23 #include "global.h"
24 #include "open_close.h"
25 #include "stdioInterf.h"
26 #include "fioMacros.h"
27 #include "async.h"
28
29 /* --------------------------------------------------------------- */
30
31 /* number of FCBs to malloc at a time: */
32 #define CHUNKSZ 100
33
34 /* pointer to list of available File Control Blocks: */
35 static FIO_FCB *fcb_avail = NULL;
36
37 /* pointer to the allocatated chunks of File Control Blocks: */
38 static FIO_FCB *fcb_chunks;
39
40 static int __fortio_trunc(FIO_FCB *, seekoffx_t);
41
42 extern void *
__fortio_fiofcb_asyptr(FIO_FCB * f)43 __fortio_fiofcb_asyptr(FIO_FCB *f)
44 {
45 return f->asyptr;
46 }
47
48 extern bool
__fortio_fiofcb_asy_rw(FIO_FCB * f)49 __fortio_fiofcb_asy_rw(FIO_FCB *f)
50 {
51 return f->asy_rw;
52 }
53
54 extern void
__fortio_set_asy_rw(FIO_FCB * f,bool value)55 __fortio_set_asy_rw(FIO_FCB *f, bool value)
56 {
57 f->asy_rw = (sbool)value;
58 }
59
60 extern bool
__fortio_fiofcb_stdunit(FIO_FCB * f)61 __fortio_fiofcb_stdunit(FIO_FCB *f)
62 {
63 return f->stdunit;
64 }
65
66 extern FILE *
__fortio_fiofcb_fp(FIO_FCB * f)67 __fortio_fiofcb_fp(FIO_FCB *f)
68 {
69 return f->fp;
70 }
71
72 extern short
__fortio_fiofcb_form(FIO_FCB * f)73 __fortio_fiofcb_form(FIO_FCB *f)
74 {
75 return f->form;
76 }
77
78 extern char *
__fortio_fiofcb_name(FIO_FCB * f)79 __fortio_fiofcb_name(FIO_FCB *f)
80 {
81 return f->name;
82 }
83
84 extern void *
__fortio_fiofcb_next(FIO_FCB * f)85 __fortio_fiofcb_next(FIO_FCB *f)
86 {
87 return f->next;
88 }
89
90 extern FIO_FCB *
__fortio_alloc_fcb(void)91 __fortio_alloc_fcb(void)
92 {
93 FIO_FCB *p;
94
95 if (fcb_avail) { /* return item from avail list */
96 p = fcb_avail;
97 fcb_avail = p->next;
98 } else { /* call malloc for some new space */
99 int i;
100 p = (FIO_FCB *)malloc(CHUNKSZ * sizeof(FIO_FCB));
101 assert(p);
102 /*
103 * Waste the first element of the chunk; the first element is
104 * used to link all of the chunks together so that they can
105 * be freed upon program termination.
106 */
107 for (i = 2; i < CHUNKSZ - 1; i++) /* create avail list */
108 p[i].next = &p[i + 1];
109 p[CHUNKSZ - 1].next = NULL; /* end of avail list */
110 fcb_avail = &p[2];
111
112 p[0].next = fcb_chunks;
113 fcb_chunks = p;
114
115 p++;
116 }
117
118 memset(p, 0, sizeof(FIO_FCB));
119 p[0].next = fioFcbTbls.fcbs; /* add new FCB to front of list */
120 fioFcbTbls.fcbs = p;
121 return p;
122 }
123
124 extern void
__fortio_free_fcb(FIO_FCB * p)125 __fortio_free_fcb(FIO_FCB *p)
126 {
127 if (fioFcbTbls.fcbs == p) /* delete p from list */
128 fioFcbTbls.fcbs = p->next;
129 else {
130 FIO_FCB *q;
131 for (q = fioFcbTbls.fcbs; q; q = q->next) /* find predecessor of p */
132 if (q->next == p)
133 break;
134 assert(q != NULL); /* trying to free unallocated block */
135 q->next = p->next;
136 }
137
138 p->next = fcb_avail; /* add to front of avail list */
139 fcb_avail = p;
140 }
141
142 extern void
__fortio_cleanup_fcb()143 __fortio_cleanup_fcb()
144 {
145 FIO_FCB *p, *p_next;
146 for (p = fcb_chunks; p; p = p_next) {
147 p_next = p->next;
148 free(p);
149 }
150 fcb_avail = NULL;
151 fcb_chunks = NULL;
152 }
153
154 /* --------------------------------------------------------------- */
155
__fortio_rwinit(int unit,int form,__INT_T * recptr,int optype)156 extern FIO_FCB *__fortio_rwinit(
157 int unit, int form, /* FIO_FORMATTED, FIO_UNFORMATTED */
158 __INT_T *recptr, /* ptr to record number, may be present or NULL */
159 int optype) /* 0,1,2 - read, write, endfile */
160 {
161 FIO_FCB *f;
162 int errflag;
163 seekoffx_t pos; /* typedef in pgstdio.h */
164 seekoffx_t rec;
165 bool rec_specified;
166
167 #define ERR(code) \
168 { \
169 (void)__fortio_error(code); \
170 return NULL; \
171 }
172
173 if (recptr == 0 || !ISPRESENT(recptr)) {
174 rec = 0;
175 rec_specified = FALSE;
176 } else {
177 rec = *recptr;
178 rec_specified = TRUE;
179 }
180
181 f = __fortio_find_unit(unit);
182 if (f == NULL) { /* unit not connected */
183 int status = FIO_UNKNOWN;
184
185 if (optype == 0) /* if READ, error if file does not exist */
186 status = FIO_OLD;
187 if (!fioFcbTbls.pos_present) {
188 errflag = __fortio_open(unit, FIO_READWRITE, status, FIO_KEEP,
189 FIO_SEQUENTIAL, FIO_NULL, form, FIO_NONE,
190 FIO_ASIS, FIO_YES, 0, NULL /*name*/, 0);
191 if (errflag != 0)
192 return NULL;
193 f = __fortio_find_unit(unit);
194 assert(f && f->acc == FIO_SEQUENTIAL);
195 } else {
196 errflag = __fortio_open(unit, FIO_READWRITE, status, FIO_KEEP, FIO_STREAM,
197 FIO_NULL, form, FIO_NONE, FIO_ASIS, FIO_YES, 0,
198 NULL /*name*/, 0);
199 if (errflag != 0)
200 return NULL;
201 f = __fortio_find_unit(unit);
202 assert(f && f->acc == FIO_STREAM);
203 if (f->form == FIO_UNFORMATTED)
204 f->binary = TRUE;
205 fioFcbTbls.pos_present = FALSE;
206 pos = fioFcbTbls.pos;
207 /*
208 * spec says a pos of 1 => beginning of file
209 * INQUIRE always adds one.
210 */
211 if (pos > 0)
212 --pos;
213 else
214 ERR(FIO_EPOSV);
215 if (__io_fseek(f->fp, (seekoffx_t)pos, SEEK_SET) != 0)
216 ERR(__io_errno());
217 f->coherent = 0;
218 }
219 } else { /* unit is already connected: */
220
221 /* check for outstanding async i/o */
222
223 if (f->asy_rw) { /* stop any async i/o */
224 f->asy_rw = 0;
225 if (Fio_asy_disable(f->asyptr) == -1) {
226 return (NULL);
227 }
228 }
229
230 if (fioFcbTbls.pos_present) {
231 fioFcbTbls.pos_present = FALSE;
232 if (f->acc != FIO_STREAM) {
233 ERR(FIO_EPOS);
234 } else {
235 pos = fioFcbTbls.pos;
236 /*
237 * spec says a pos of 1 => beginning of file
238 * INQUIRE always adds one.
239 */
240 if (pos > 0)
241 --pos;
242 else
243 ERR(FIO_EPOSV);
244 if (__io_fseek(f->fp, (seekoffx_t)pos, SEEK_SET) != 0)
245 ERR(__io_errno());
246 f->coherent = 0;
247 f->eof_flag = FALSE; /* clear it for the ensuing test */
248 }
249 }
250
251 if (optype != 0 && f->action == FIO_READ)
252 ERR(FIO_EREADONLY);
253 if (optype == 0 && f->action == FIO_WRITE)
254 ERR(FIO_EWRITEONLY);
255
256 /* error if attempt operation while positioned past end of file.
257 For write or endfile statements, ignore error for compatibility
258 with other Fortran compilers. */
259 if (f->eof_flag && optype == 0 /*read*/)
260 ERR(FIO_EEOFERR);
261 f->eof_flag = FALSE;
262
263 if (form != f->form && optype != 2)
264 ERR(FIO_EFORM);
265
266 if (f->acc == FIO_DIRECT) {
267 assert(f->reclen > 0);
268
269 if (!rec_specified || rec == 0)
270 /* since rec not specified, assume the next record */
271 rec = f->nextrec;
272 else if (rec < 1)
273 ERR(FIO_EDIRECT);
274 if (optype == 0 && rec > f->maxrec) {
275 seekoffx_t len;
276 seekoffx_t sav_pos;
277
278 sav_pos = __io_ftell(f->fp);
279 if (__io_fseek(f->fp, (seekoffx_t)0, SEEK_END) != 0)
280 ERR(__io_errno());
281 len = __io_ftell(f->fp);
282 f->partial = len % f->reclen;
283 if (form == FIO_UNFORMATTED && f->partial) {
284 /* allow read of partial record */
285 if (__io_fseek(f->fp, sav_pos, SEEK_SET) != 0)
286 ERR(__io_errno());
287 } else {
288
289 /* Add simple check to see if maxrec has been
290 changed by another process before bailing out */
291 f->maxrec = len / f->reclen;
292
293 /* Now check with recomputed maxrec */
294 if (rec > f->maxrec) {
295 f->nextrec = rec + 1; /* make error info come out correct */
296 ERR(FIO_EDREAD); /* read of non-existing record */
297 }
298
299 /* We recovered, so seek to the right point */
300 pos = f->reclen * (rec - 1);
301 if (__io_fseek(f->fp, (seekoffx_t)pos, SEEK_SET) != 0)
302 ERR(__io_errno());
303 f->coherent = 0;
304 }
305 }
306
307 if (f->nextrec != rec) {
308 /* FS 3662 Add simple check to see if maxrec has been
309 changed by another process before bailing out.
310 Certainly need to recompute it before bb is calculated
311 below, as multiple writers can cause a file to grow
312 enormously. If it has changed, and the record is not
313 past the end, we can just use the normal seek and reset
314 coherent section of code below.
315 */
316 if (rec > f->maxrec + 1) {
317 seekoffx_t len;
318 if (__io_fseek(f->fp, 0L, SEEK_END) != 0)
319 ERR(__io_errno());
320 len = __io_ftell(f->fp);
321 f->maxrec = len / f->reclen;
322 } /* Now go to next if-check with recomputed maxrec */
323
324 if (rec <= f->maxrec + 1) {
325 pos = f->reclen * (rec - 1);
326 if (__io_fseek(f->fp, (seekoffx_t)pos, SEEK_SET) != 0)
327 ERR(__io_errno());
328 f->coherent = 0;
329 } else {
330 /* pad with (rec-maxrec-1)*reclen bytes: */
331
332 seekoffx_t bb = (rec - f->maxrec - 1) * f->reclen;
333 /*
334 * It has been reported that extending the file by writing
335 * to the file is very slow when the number of bytes is
336 * large. Rather than use writes to pad the file, use fseek
337 * to extend the file 1 less the number of bytes and
338 * complete the padding by writing a single byte. A write
339 * is necessary after the fseek to ensure that the file's
340 * physical size is increased.
341 if (__io_fseek(f->fp, 0L, SEEK_END) != 0)
342 ERR(__io_errno());
343 errflag =
344 __fortio_zeropad(f->fp, (rec-f->maxrec-1) * f->reclen);
345 */
346 /* With multiple writers, there is a chance that
347 this could clobber a byte of data, but a very
348 small chance now that we've added the
349 recomputation of f->maxrec above
350 */
351 if (__io_fseek(f->fp, (seekoffx_t)(bb - 1), SEEK_END) != 0)
352 ERR(__io_errno());
353 errflag = __fortio_zeropad(f->fp, 1);
354 if (errflag != 0)
355 ERR(errflag);
356 f->coherent = 1;
357 }
358 }
359 if (optype == 0 /*read*/ && form == FIO_FORMATTED)
360 f->nextrec = rec;
361 else
362 f->nextrec = rec + 1;
363
364 if (rec > f->maxrec)
365 f->maxrec = rec;
366 }
367 }
368
369 /* for write into sequential file, may need to truncate file: */
370
371 assert(f->form == FIO_FORMATTED || f->form == FIO_UNFORMATTED);
372 assert(f->acc == FIO_DIRECT || f->acc == FIO_SEQUENTIAL ||
373 f->acc == FIO_STREAM);
374 if (f->acc == FIO_SEQUENTIAL) {
375 if (f->form == FIO_UNFORMATTED)
376 f->skip = 0;
377 if (rec_specified)
378 ERR(FIO_ECOMPAT);
379 if (optype != 0 && f->truncflag) {
380 pos = __io_ftell(f->fp);
381 if (__io_fseek(f->fp, 0L, SEEK_END) != 0)
382 ERR(__io_errno());
383 f->coherent = 0;
384 /* if not currently positioned at end of file, need to trunc: */
385 if (pos != __io_ftell(f->fp)) {
386 if (__io_fseek(f->fp, (seekoffx_t)pos, SEEK_SET) != 0)
387 ERR(__io_errno());
388 errflag = __fortio_trunc(f, pos);
389 if (errflag != 0)
390 return NULL;
391 }
392 f->truncflag = FALSE;
393 }
394 if (optype == 0 /*read*/) {
395 if (f->ispipe) {
396 f->truncflag = FALSE;
397 f->nextrec = 1;
398 if (f->coherent == 1)
399 /* last operation was a write */
400 fflush(f->fp);
401 f->coherent = 0;
402 f->skip = 0;
403 return f;
404 }
405 f->truncflag = TRUE;
406 } else
407 f->nextrec++; /* endfile or write */
408 } else /* FIO_DIRECT */
409 f->skip = 0;
410
411 /* coherent flag of fcb indicates how the file was last accessed
412 (read/write). If an operation occurs which is not identical with
413 the previous operation, the file's buffer must be
414 flushed. NOTE: coherent is set to 0 by open and rewind. */
415
416 if (optype != 2) {
417 if (f->coherent && (f->coherent != 2 - optype)) {
418 (void)__io_fseek(f->fp, 0L, SEEK_CUR);
419 f->skip = 0;
420 }
421 f->coherent = 2 - optype; /* write ==> 1, read ==> 2*/
422 } else
423 f->skip = 0;
424
425 return f;
426 }
427
428 /* --------------------------------------------------------------- */
429
430 extern FIO_FCB *
__fortio_find_unit(int unit)431 __fortio_find_unit(
432 /* search FCB table for entry with matching unit number: */
433 int unit)
434 {
435 FIO_FCB *p;
436
437 for (p = fioFcbTbls.fcbs; p; p = p->next)
438 if (p->unit == unit)
439 return p;
440
441 return NULL; /* not found */
442 }
443
444 /* ---------------------------------------------------------------- */
445
446 extern int
__fortio_zeropad(FILE * fp,long len)447 __fortio_zeropad(FILE *fp, long len)
448 {
449 #define BFSZ 512L
450 static struct { /* (double aligned buff may be faster) */
451 char b[BFSZ];
452 double dalign;
453 } b = {{0}, 0};
454
455 while (len >= BFSZ) {
456 if (FWRITE(b.b, BFSZ, 1, fp) != 1)
457 return __io_errno();
458 len -= BFSZ;
459 }
460
461 if (len > 0)
462 if (FWRITE(b.b, len, 1, fp) != 1)
463 return __io_errno();
464
465 return 0;
466 }
467
468 /* --------------------------------------------------------------- */
469
__fortio_eq_str(char * str,__CLEN_T len,char * pattern)470 extern bool __fortio_eq_str(
471 /* return TRUE if string 'str' of length 'len' is equal to 'pattern'. */
472
473 char *str, /* user specified string, not null terminated */
474 __CLEN_T len, char *pattern) /* upper case, null terminated string */
475 {
476 char c1, c2;
477
478 if (str == NULL || len <= 0)
479 return FALSE;
480
481 while (1) {
482 c1 = *str++;
483 c2 = *pattern++;
484
485 if (len == 0)
486 break;
487 len--;
488
489 if (c1 >= 'a' && c1 <= 'z') /* convert to upper case */
490 c1 = c1 + ('A' - 'a');
491
492 if (c2 == '\0' || c1 != c2)
493 break;
494 }
495
496 if (c2 != 0)
497 return FALSE;
498
499 if (len == 0)
500 return TRUE;
501
502 /* verify that remaining characters of str are blank: */
503
504 while (len--)
505 if (*str++ != ' ')
506 return FALSE;
507
508 return TRUE;
509 }
510
511 /* ---------------------------------------------------------------------- */
512
513 /* ---------------------------------------------------------------------- */
514
515 #define SWAPB(p, b1, b2, tmp) \
516 { \
517 tmp = p[b1]; \
518 p[b1] = p[b2]; \
519 p[b2] = tmp; \
520 }
521
__fortio_swap_bytes(char * p,int type,long cnt)522 void __fortio_swap_bytes(
523 /*
524 * swap bytes where the value located by p is in the wrong endian order.
525 * swapping is endian-independent.
526 */
527 char *p, /* locates first byte of items */
528 int type, /* data type of item */
529 long cnt) /* number of 'unit_sz' items to be swapped */
530 {
531 char btmp;
532 int unit_sz; /* basic size of item to be swapped */
533
534 switch (type) {
535 case __STR:
536 return;
537 case __CPLX8:
538 unit_sz = FIO_TYPE_SIZE(__REAL4);
539 cnt <<= 1;
540 break;
541 case __CPLX16:
542 unit_sz = FIO_TYPE_SIZE(__REAL8);
543 cnt <<= 1;
544 break;
545 case __CPLX32:
546 unit_sz = FIO_TYPE_SIZE(__REAL16);
547 cnt <<= 1;
548 break;
549 default:
550 unit_sz = FIO_TYPE_SIZE(type);
551 break;
552 }
553 while (cnt--) {
554 switch (unit_sz) {
555 case 1: /* byte */
556 return;
557 case 2: /* half-word */
558 SWAPB(p, 0, 1, btmp);
559 break;
560 case 4: /* word */
561 SWAPB(p, 0, 3, btmp);
562 SWAPB(p, 1, 2, btmp);
563 break;
564 case 8: /* double-word */
565 SWAPB(p, 0, 7, btmp);
566 SWAPB(p, 1, 6, btmp);
567 SWAPB(p, 2, 5, btmp);
568 SWAPB(p, 3, 4, btmp);
569 break;
570 default: /* error */
571 assert(0);
572 return;
573 }
574 p += unit_sz;
575 }
576 }
577
578 /* ---------------------------------------------------------------------- */
579
580 static int
__fortio_trunc(FIO_FCB * p,seekoffx_t length)581 __fortio_trunc(FIO_FCB *p, seekoffx_t length)
582 {
583 __io_fflush(p->fp);
584 if (ftruncate(__fort_getfd(p->fp), length))
585 return __fortio_error(__io_errno());
586 if (length == 0) {
587 /*
588 * For a file which is now empty, ensure that certain FCB attributes
589 * are reset.
590 */
591 p->nextrec = 1;
592 p->truncflag = FALSE;
593 p->coherent = 0;
594 p->eof_flag = FALSE;
595 }
596 return 0;
597 }
598