1 /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
10 any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 #ifndef GFOR_IO_H
27 #define GFOR_IO_H
28
29 /* IO library include. */
30
31 #include "libgfortran.h"
32
33 #include <gthr.h>
34
35 #define gcc_unreachable() __builtin_unreachable ()
36
37 /* POSIX 2008 specifies that the extended locale stuff is found in
38 locale.h, but some systems have them in xlocale.h. */
39
40 #include <locale.h>
41
42 #ifdef HAVE_XLOCALE_H
43 #include <xlocale.h>
44 #endif
45
46
47 /* Forward declarations. */
48 struct st_parameter_dt;
49 typedef struct stream stream;
50 struct fbuf;
51 struct format_data;
52 typedef struct fnode fnode;
53 struct gfc_unit;
54
55 #ifdef HAVE_NEWLOCALE
56 /* We have POSIX 2008 extended locale stuff. */
57 extern locale_t c_locale;
58 internal_proto(c_locale);
59 #else
60 extern char* old_locale;
61 internal_proto(old_locale);
62 extern int old_locale_ctr;
63 internal_proto(old_locale_ctr);
64 extern __gthread_mutex_t old_locale_lock;
65 internal_proto(old_locale_lock);
66 #endif
67
68
69 /* Macros for testing what kinds of I/O we are doing. */
70
71 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
72
73 #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
74
75 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
76
77 #define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4)
78
79 /* The array_loop_spec contains the variables for the loops over index ranges
80 that are encountered. */
81
82 typedef struct array_loop_spec
83 {
84 /* Index counter for this dimension. */
85 index_type idx;
86
87 /* Start for the index counter. */
88 index_type start;
89
90 /* End for the index counter. */
91 index_type end;
92
93 /* Step for the index counter. */
94 index_type step;
95 }
96 array_loop_spec;
97
98 /* User defined input/output iomsg length. */
99
100 #define IOMSG_LEN 256
101
102 /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
103 iomsg, (_iotype), (_iomsg)) */
104 typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *,
105 gfc_full_array_i4 *,
106 GFC_INTEGER_4 *, char *,
107 gfc_charlen_type, gfc_charlen_type);
108
109 /* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg)) */
110 typedef void (*unformatted_dtio)(void *, GFC_INTEGER_4 *, GFC_INTEGER_4 *,
111 char *, gfc_charlen_type);
112
113 /* The dtio calls for namelist require a CLASS object to be built. */
114 typedef struct gfc_class
115 {
116 void *data;
117 void *vptr;
118 index_type len;
119 }
120 gfc_class;
121
122
123 /* A structure to build a hash table for format data. */
124
125 #define FORMAT_HASH_SIZE 16
126
127 typedef struct format_hash_entry
128 {
129 char *key;
130 gfc_charlen_type key_len;
131 struct format_data *hashed_fmt;
132 }
133 format_hash_entry;
134
135 /* Format tokens. Only about half of these can be stored in the
136 format nodes. */
137
138 typedef enum
139 {
140 FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
141 FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
142 FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
143 FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
144 FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
145 FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
146 }
147 format_token;
148
149 /* Representation of a namelist object in libgfortran
150
151 Namelist Records
152 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
153 or
154 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
155
156 The object can be a fully qualified, compound name for an intrinsic
157 type, derived types or derived type components. So, a substring
158 a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
159 read. Hence full information about the structure of the object has
160 to be available to list_read.c and write.
161
162 These requirements are met by the following data structures.
163
164 namelist_info type contains all the scalar information about the
165 object and arrays of descriptor_dimension and array_loop_spec types for
166 arrays. */
167
168 typedef struct namelist_type
169 {
170 /* Object type. */
171 bt type;
172
173 /* Object name. */
174 char * var_name;
175
176 /* Address for the start of the object's data. */
177 void * mem_pos;
178
179 /* Address of specific DTIO subroutine. */
180 void * dtio_sub;
181
182 /* Address of vtable if dtio_sub non-null. */
183 void * vtable;
184
185 /* Flag to show that a read is to be attempted for this node. */
186 int touched;
187
188 /* Length of intrinsic type in bytes. */
189 int len;
190
191 /* Rank of the object. */
192 int var_rank;
193
194 /* Overall size of the object in bytes. */
195 index_type size;
196
197 /* Length of character string. */
198 index_type string_length;
199
200 descriptor_dimension * dim;
201 array_loop_spec * ls;
202 struct namelist_type * next;
203 }
204 namelist_info;
205
206 /* Options for the OPEN statement. */
207
208 typedef enum
209 { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM,
210 ACCESS_UNSPECIFIED
211 }
212 unit_access;
213
214 typedef enum
215 { ACTION_READ, ACTION_WRITE, ACTION_READWRITE,
216 ACTION_UNSPECIFIED
217 }
218 unit_action;
219
220 typedef enum
221 { BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED }
222 unit_blank;
223
224 typedef enum
225 { DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE,
226 DELIM_UNSPECIFIED
227 }
228 unit_delim;
229
230 typedef enum
231 { FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED }
232 unit_form;
233
234 typedef enum
235 { POSITION_ASIS, POSITION_REWIND, POSITION_APPEND,
236 POSITION_UNSPECIFIED
237 }
238 unit_position;
239
240 typedef enum
241 { STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH,
242 STATUS_REPLACE, STATUS_UNSPECIFIED
243 }
244 unit_status;
245
246 typedef enum
247 { PAD_YES, PAD_NO, PAD_UNSPECIFIED }
248 unit_pad;
249
250 typedef enum
251 { DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
252 unit_decimal;
253
254 typedef enum
255 { ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
256 unit_encoding;
257
258 typedef enum
259 { ROUND_UP = GFC_FPE_UPWARD,
260 ROUND_DOWN = GFC_FPE_DOWNWARD,
261 ROUND_ZERO = GFC_FPE_TOWARDZERO,
262 ROUND_NEAREST = GFC_FPE_TONEAREST,
263 ROUND_COMPATIBLE = 10, /* round away from zero. */
264 ROUND_PROCDEFINED, /* Here as ROUND_NEAREST. */
265 ROUND_UNSPECIFIED /* Should never occur. */
266 }
267 unit_round;
268
269 /* NOTE: unit_sign must correspond with the sign_status enumerator in
270 st_parameter_dt to not break the ABI. */
271 typedef enum
272 { SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
273 unit_sign;
274
275 typedef enum
276 { ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
277 unit_advance;
278
279 typedef enum
280 {READING, WRITING, LIST_READING, LIST_WRITING}
281 unit_mode;
282
283 typedef enum
284 { ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
285 unit_async;
286
287 typedef enum
288 { SHARE_DENYRW, SHARE_DENYNONE,
289 SHARE_UNSPECIFIED
290 }
291 unit_share;
292
293 typedef enum
294 { CC_LIST, CC_FORTRAN, CC_NONE,
295 CC_UNSPECIFIED
296 }
297 unit_cc;
298
299 /* End-of-record types for CC_FORTRAN. */
300 typedef enum
301 { CCF_DEFAULT=0x0,
302 CCF_OVERPRINT=0x1,
303 CCF_ONE_LF=0x2,
304 CCF_TWO_LF=0x4,
305 CCF_PAGE_FEED=0x8,
306 CCF_PROMPT=0x10,
307 CCF_OVERPRINT_NOA=0x20,
308 } /* 6 bits */
309 cc_fortran;
310
311 typedef enum
312 { SIGN_S, SIGN_SS, SIGN_SP }
313 unit_sign_s;
314
315 /* Make sure to keep st_parameter_* in sync with gcc/fortran/ioparm.def. */
316
317 #define CHARACTER1(name) \
318 char * name; \
319 gfc_charlen_type name ## _len
320 #define CHARACTER2(name) \
321 gfc_charlen_type name ## _len; \
322 char * name
323
324 typedef struct
325 {
326 st_parameter_common common;
327 GFC_IO_INT recl_in;
328 CHARACTER2 (file);
329 CHARACTER1 (status);
330 CHARACTER2 (access);
331 CHARACTER1 (form);
332 CHARACTER2 (blank);
333 CHARACTER1 (position);
334 CHARACTER2 (action);
335 CHARACTER1 (delim);
336 CHARACTER2 (pad);
337 CHARACTER1 (convert);
338 CHARACTER2 (decimal);
339 CHARACTER1 (encoding);
340 CHARACTER2 (round);
341 CHARACTER1 (sign);
342 CHARACTER2 (asynchronous);
343 GFC_INTEGER_4 *newunit;
344 GFC_INTEGER_4 readonly;
345 CHARACTER2 (cc);
346 CHARACTER1 (share);
347 }
348 st_parameter_open;
349
350 #define IOPARM_CLOSE_HAS_STATUS (1 << 7)
351
352 typedef struct
353 {
354 st_parameter_common common;
355 CHARACTER1 (status);
356 }
357 st_parameter_close;
358
359 typedef struct
360 {
361 st_parameter_common common;
362 }
363 st_parameter_filepos;
364
365 #define IOPARM_INQUIRE_HAS_EXIST (1 << 7)
366 #define IOPARM_INQUIRE_HAS_OPENED (1 << 8)
367 #define IOPARM_INQUIRE_HAS_NUMBER (1 << 9)
368 #define IOPARM_INQUIRE_HAS_NAMED (1 << 10)
369 #define IOPARM_INQUIRE_HAS_NEXTREC (1 << 11)
370 #define IOPARM_INQUIRE_HAS_RECL_OUT (1 << 12)
371 #define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 13)
372 #define IOPARM_INQUIRE_HAS_FILE (1 << 14)
373 #define IOPARM_INQUIRE_HAS_ACCESS (1 << 15)
374 #define IOPARM_INQUIRE_HAS_FORM (1 << 16)
375 #define IOPARM_INQUIRE_HAS_BLANK (1 << 17)
376 #define IOPARM_INQUIRE_HAS_POSITION (1 << 18)
377 #define IOPARM_INQUIRE_HAS_ACTION (1 << 19)
378 #define IOPARM_INQUIRE_HAS_DELIM (1 << 20)
379 #define IOPARM_INQUIRE_HAS_PAD (1 << 21)
380 #define IOPARM_INQUIRE_HAS_NAME (1 << 22)
381 #define IOPARM_INQUIRE_HAS_SEQUENTIAL (1 << 23)
382 #define IOPARM_INQUIRE_HAS_DIRECT (1 << 24)
383 #define IOPARM_INQUIRE_HAS_FORMATTED (1 << 25)
384 #define IOPARM_INQUIRE_HAS_UNFORMATTED (1 << 26)
385 #define IOPARM_INQUIRE_HAS_READ (1 << 27)
386 #define IOPARM_INQUIRE_HAS_WRITE (1 << 28)
387 #define IOPARM_INQUIRE_HAS_READWRITE (1 << 29)
388 #define IOPARM_INQUIRE_HAS_CONVERT (1 << 30)
389 #define IOPARM_INQUIRE_HAS_FLAGS2 (1u << 31)
390
391 #define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0)
392 #define IOPARM_INQUIRE_HAS_DECIMAL (1 << 1)
393 #define IOPARM_INQUIRE_HAS_ENCODING (1 << 2)
394 #define IOPARM_INQUIRE_HAS_ROUND (1 << 3)
395 #define IOPARM_INQUIRE_HAS_SIGN (1 << 4)
396 #define IOPARM_INQUIRE_HAS_PENDING (1 << 5)
397 #define IOPARM_INQUIRE_HAS_SIZE (1 << 6)
398 #define IOPARM_INQUIRE_HAS_ID (1 << 7)
399 #define IOPARM_INQUIRE_HAS_IQSTREAM (1 << 8)
400 #define IOPARM_INQUIRE_HAS_SHARE (1 << 9)
401 #define IOPARM_INQUIRE_HAS_CC (1 << 10)
402
403 typedef struct
404 {
405 st_parameter_common common;
406 GFC_INTEGER_4 *exist, *opened, *number, *named;
407 GFC_IO_INT *nextrec, *recl_out, *strm_pos_out;
408 CHARACTER1 (file);
409 CHARACTER2 (access);
410 CHARACTER1 (form);
411 CHARACTER2 (blank);
412 CHARACTER1 (position);
413 CHARACTER2 (action);
414 CHARACTER1 (delim);
415 CHARACTER2 (pad);
416 CHARACTER1 (name);
417 CHARACTER2 (sequential);
418 CHARACTER1 (direct);
419 CHARACTER2 (formatted);
420 CHARACTER1 (unformatted);
421 CHARACTER2 (read);
422 CHARACTER1 (write);
423 CHARACTER2 (readwrite);
424 CHARACTER1 (convert);
425 GFC_INTEGER_4 flags2;
426 CHARACTER1 (asynchronous);
427 CHARACTER2 (decimal);
428 CHARACTER1 (encoding);
429 CHARACTER2 (round);
430 CHARACTER1 (sign);
431 GFC_INTEGER_4 *pending;
432 GFC_IO_INT *size;
433 GFC_INTEGER_4 *id;
434 CHARACTER1 (iqstream);
435 CHARACTER2 (share);
436 CHARACTER1 (cc);
437 }
438 st_parameter_inquire;
439
440
441 #define IOPARM_DT_LIST_FORMAT (1 << 7)
442 #define IOPARM_DT_NAMELIST_READ_MODE (1 << 8)
443 #define IOPARM_DT_HAS_REC (1 << 9)
444 #define IOPARM_DT_HAS_SIZE (1 << 10)
445 #define IOPARM_DT_HAS_IOLENGTH (1 << 11)
446 #define IOPARM_DT_HAS_FORMAT (1 << 12)
447 #define IOPARM_DT_HAS_ADVANCE (1 << 13)
448 #define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14)
449 #define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15)
450 #define IOPARM_DT_HAS_ID (1 << 16)
451 #define IOPARM_DT_HAS_POS (1 << 17)
452 #define IOPARM_DT_HAS_ASYNCHRONOUS (1 << 18)
453 #define IOPARM_DT_HAS_BLANK (1 << 19)
454 #define IOPARM_DT_HAS_DECIMAL (1 << 20)
455 #define IOPARM_DT_HAS_DELIM (1 << 21)
456 #define IOPARM_DT_HAS_PAD (1 << 22)
457 #define IOPARM_DT_HAS_ROUND (1 << 23)
458 #define IOPARM_DT_HAS_SIGN (1 << 24)
459 #define IOPARM_DT_HAS_F2003 (1 << 25)
460 #define IOPARM_DT_HAS_UDTIO (1 << 26)
461 #define IOPARM_DT_DEC_EXT (1 << 27)
462 /* Internal use bit. */
463 #define IOPARM_DT_IONML_SET (1u << 31)
464
465
466 typedef struct st_parameter_dt
467 {
468 st_parameter_common common;
469 GFC_IO_INT rec;
470 GFC_IO_INT *size, *iolength;
471 gfc_array_char *internal_unit_desc;
472 CHARACTER1 (format);
473 CHARACTER2 (advance);
474 CHARACTER1 (internal_unit);
475 CHARACTER2 (namelist_name);
476 GFC_INTEGER_4 *id;
477 GFC_IO_INT pos;
478 CHARACTER1 (asynchronous);
479 CHARACTER2 (blank);
480 CHARACTER1 (decimal);
481 CHARACTER2 (delim);
482 CHARACTER1 (pad);
483 CHARACTER2 (round);
484 CHARACTER1 (sign);
485 /* Private part of the structure. The compiler just needs
486 to reserve enough space. */
487 union
488 {
489 struct
490 {
491 void (*transfer) (struct st_parameter_dt *, bt, void *, int,
492 size_t, size_t);
493 struct gfc_unit *current_unit;
494 /* Item number in a formatted data transfer. Also used in namelist
495 read_logical as an index into line_buffer. */
496 int item_count;
497 unit_mode mode;
498 unit_blank blank_status;
499 unit_sign sign_status;
500 int scale_factor;
501 /* Maximum righthand column written to. */
502 int max_pos;
503 /* Number of skips + spaces to be done for T and X-editing. */
504 int skips;
505 /* Number of spaces to be done for T and X-editing. */
506 int pending_spaces;
507 /* Whether an EOR condition was encountered. Value is:
508 0 if no EOR was encountered
509 1 if an EOR was encountered due to a 1-byte marker (LF)
510 2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
511 int sf_seen_eor;
512 unit_advance advance_status;
513 unsigned reversion_flag : 1; /* Format reversion has occurred. */
514 unsigned first_item : 1;
515 unsigned seen_dollar : 1;
516 unsigned eor_condition : 1;
517 unsigned no_leading_blank : 1;
518 unsigned char_flag : 1;
519 unsigned input_complete : 1;
520 unsigned at_eol : 1;
521 unsigned comma_flag : 1;
522 /* A namelist specific flag used in the list directed library
523 to flag that calls are being made from namelist read (e.g. to
524 ignore comments or to treat '/' as a terminator) */
525 unsigned namelist_mode : 1;
526 /* A namelist specific flag used in the list directed library
527 to flag read errors and return, so that an attempt can be
528 made to read a new object name. */
529 unsigned nml_read_error : 1;
530 /* A sequential formatted read specific flag used to signal that a
531 character string is being read so don't use commas to shorten a
532 formatted field width. */
533 unsigned sf_read_comma : 1;
534 /* A namelist specific flag used to enable reading input from
535 line_buffer for logical reads. */
536 unsigned line_buffer_enabled : 1;
537 /* An internal unit specific flag used to identify that the associated
538 unit is internal. */
539 unsigned unit_is_internal : 1;
540 /* An internal unit specific flag to signify an EOF condition for list
541 directed read. */
542 unsigned at_eof : 1;
543 /* Used for g0 floating point output. */
544 unsigned g0_no_blanks : 1;
545 /* Used to signal use of free_format_data. */
546 unsigned format_not_saved : 1;
547 /* A flag used to identify when a non-standard expanded namelist read
548 has occurred. */
549 unsigned expanded_read : 1;
550 /* Flag to indicate if the statement has async="YES". */
551 unsigned async : 1;
552 /* 12 unused bits. */
553
554 int child_saved_iostat;
555 int nml_delim;
556 int repeat_count;
557 int saved_length;
558 int saved_used;
559 bt saved_type;
560 char *saved_string;
561 char *scratch;
562 char *line_buffer;
563 struct format_data *fmt;
564 namelist_info *ionml;
565 #ifdef HAVE_NEWLOCALE
566 locale_t old_locale;
567 #endif
568 /* Current position within the look-ahead line buffer. */
569 int line_buffer_pos;
570 /* Storage area for values except for strings. Must be
571 large enough to hold a complex value (two reals) of the
572 largest kind. */
573 char value[32];
574 GFC_IO_INT not_used; /* Needed for alignment. */
575 formatted_dtio fdtio_ptr;
576 unformatted_dtio ufdtio_ptr;
577 /* With CC_FORTRAN, the first character of a record determines the
578 style of record end (and start) to use. We must mark down the type
579 when we write first in write_a so we remember the end type later in
580 next_record_w. */
581 struct
582 {
583 unsigned type : 6; /* See enum cc_fortran. */
584 unsigned len : 2; /* Always 0, 1, or 2. */
585 /* The union is updated after start-of-record is written. */
586 union
587 {
588 char start; /* Output character for start of record. */
589 char end; /* Output character for end of record. */
590 } u;
591 } cc;
592 } p;
593 /* This pad size must be equal to the pad_size declared in
594 trans-io.c (gfc_build_io_library_fndecls). The above structure
595 must be smaller or equal to this array. */
596 char pad[16 * sizeof (char *) + 32 * sizeof (int)];
597 } u;
598 }
599 st_parameter_dt;
600
601 /* Ensure st_parameter_dt's u.pad is bigger or equal to u.p. */
602 extern char check_st_parameter_dt[sizeof (((st_parameter_dt *) 0)->u.pad)
603 >= sizeof (((st_parameter_dt *) 0)->u.p)
604 ? 1 : -1];
605
606 #define IOPARM_WAIT_HAS_ID (1 << 7)
607
608 typedef struct
609 {
610 st_parameter_common common;
611 GFC_INTEGER_4 *id;
612 }
613 st_parameter_wait;
614
615
616 #undef CHARACTER1
617 #undef CHARACTER2
618
619 typedef struct
620 {
621 unit_access access;
622 unit_action action;
623 unit_blank blank;
624 unit_delim delim;
625 unit_form form;
626 int is_notpadded;
627 unit_position position;
628 unit_status status;
629 unit_pad pad;
630 unit_convert convert;
631 int has_recl;
632 unit_decimal decimal;
633 unit_encoding encoding;
634 unit_round round;
635 unit_sign sign;
636 unit_async async;
637 unit_share share;
638 unit_cc cc;
639 int readonly;
640 }
641 unit_flags;
642
643
644 typedef struct gfc_unit
645 {
646 int unit_number;
647 stream *s;
648
649 /* Treap links. */
650 struct gfc_unit *left, *right;
651 int priority;
652
653 int read_bad, current_record, saved_pos, previous_nonadvancing_write;
654
655 enum
656 { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
657 endfile;
658
659 unit_mode mode;
660 unit_flags flags;
661 unit_pad pad_status;
662 unit_decimal decimal_status;
663 unit_delim delim_status;
664 unit_round round_status;
665
666 /* recl -- Record length of the file.
667 last_record -- Last record number read or written
668 maxrec -- Maximum record number in a direct access file
669 bytes_left -- Bytes left in current record.
670 strm_pos -- Current position in file for STREAM I/O.
671 recl_subrecord -- Maximum length for subrecord.
672 bytes_left_subrecord -- Bytes left in current subrecord. */
673 gfc_offset recl, last_record, maxrec, bytes_left, strm_pos,
674 recl_subrecord, bytes_left_subrecord;
675
676 /* Set to 1 if we have read a subrecord. */
677
678 int continued;
679
680 /* Contains the pointer to the async unit. */
681 struct async_unit *au;
682
683 __gthread_mutex_t lock;
684 /* Number of threads waiting to acquire this unit's lock.
685 When non-zero, close_unit doesn't only removes the unit
686 from the UNIT_ROOT tree, but doesn't free it and the
687 last of the waiting threads will do that.
688 This must be either atomically increased/decreased, or
689 always guarded by UNIT_LOCK. */
690 int waiting;
691 /* Flag set by close_unit if the unit as been closed.
692 Must be manipulated under unit's lock. */
693 int closed;
694
695 /* For traversing arrays */
696 array_loop_spec *ls;
697 int rank;
698
699 /* Name of the file at the time OPEN was executed, as a
700 null-terminated C string. */
701 char *filename;
702
703 /* The format hash table. */
704 struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
705
706 /* Formatting buffer. */
707 struct fbuf *fbuf;
708
709 /* Function pointer, points to list_read worker functions. */
710 int (*next_char_fn_ptr) (st_parameter_dt *);
711 void (*push_char_fn_ptr) (st_parameter_dt *, int);
712
713 /* Internal unit char string data. */
714 char * internal_unit;
715 gfc_charlen_type internal_unit_len;
716 gfc_array_char *string_unit_desc;
717 int internal_unit_kind;
718
719 /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */
720 int child_dtio;
721
722 /* Used for ungetc() style functionality. Possible values
723 are an unsigned char, EOF, or EOF - 1 used to mark the
724 field as not valid. */
725 int last_char;
726 bool has_size;
727 GFC_IO_INT size_used;
728 }
729 gfc_unit;
730
731 typedef struct gfc_saved_unit
732 {
733 GFC_INTEGER_4 unit_number;
734 gfc_unit *unit;
735 }
736 gfc_saved_unit;
737
738 /* TEMP_FAILURE_RETRY macro from glibc. */
739
740 #ifndef TEMP_FAILURE_RETRY
741 /* Evaluate EXPRESSION, and repeat as long as it returns -1 with `errno'
742 set to EINTR. */
743
744 # define TEMP_FAILURE_RETRY(expression) \
745 (__extension__ \
746 ({ long int __result; \
747 do __result = (long int) (expression); \
748 while (__result == -1L && errno == EINTR); \
749 __result; }))
750 #endif
751
752
753 /* unit.c */
754
755 /* Maximum file offset, computed at library initialization time. */
756 extern gfc_offset max_offset;
757 internal_proto(max_offset);
758
759 /* Default RECL for sequential access if not given in OPEN statement,
760 computed at library initialization time. */
761 extern gfc_offset default_recl;
762 internal_proto(default_recl);
763
764 /* Unit tree root. */
765 extern gfc_unit *unit_root;
766 internal_proto(unit_root);
767
768 extern __gthread_mutex_t unit_lock;
769 internal_proto(unit_lock);
770
771 extern int close_unit (gfc_unit *);
772 internal_proto(close_unit);
773
774 extern gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int);
775 internal_proto(set_internal_unit);
776
777 extern void stash_internal_unit (st_parameter_dt *);
778 internal_proto(stash_internal_unit);
779
780 extern gfc_unit *find_unit (int);
781 internal_proto(find_unit);
782
783 extern gfc_unit *find_or_create_unit (int);
784 internal_proto(find_or_create_unit);
785
786 extern gfc_unit *get_unit (st_parameter_dt *, int);
787 internal_proto(get_unit);
788
789 extern void unlock_unit(gfc_unit *);
790 internal_proto(unlock_unit);
791
792 extern void finish_last_advance_record (gfc_unit *u);
793 internal_proto(finish_last_advance_record);
794
795 extern int unit_truncate(gfc_unit *, gfc_offset, st_parameter_common *);
796 internal_proto(unit_truncate);
797
798 extern int newunit_alloc (void);
799 internal_proto(newunit_alloc);
800
801 extern void newunit_free (int);
802 internal_proto(newunit_free);
803
804
805 /* open.c */
806
807 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
808 internal_proto(new_unit);
809
810
811 /* transfer.c */
812
813 #define SCRATCH_SIZE 300
814
815 extern const char *type_name (bt);
816 internal_proto(type_name);
817
818 extern void * read_block_form (st_parameter_dt *, size_t *);
819 internal_proto(read_block_form);
820
821 extern void * read_block_form4 (st_parameter_dt *, size_t *);
822 internal_proto(read_block_form4);
823
824 extern void *write_block (st_parameter_dt *, size_t);
825 internal_proto(write_block);
826
827 extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *,
828 int*);
829 internal_proto(next_array_record);
830
831 extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *,
832 gfc_offset *);
833 internal_proto(init_loop_spec);
834
835 extern void next_record (st_parameter_dt *, int);
836 internal_proto(next_record);
837
838 extern void st_wait (st_parameter_wait *);
839 export_proto (st_wait);
840
841 extern void st_wait_async (st_parameter_wait *);
842 export_proto (st_wait_async);
843
844 extern void hit_eof (st_parameter_dt *);
845 internal_proto(hit_eof);
846
847 extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int,
848 gfc_charlen_type);
849 internal_proto (transfer_array_inner);
850
851 /* read.c */
852
853 extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
854 internal_proto(set_integer);
855
856 extern GFC_UINTEGER_LARGEST si_max (int);
857 internal_proto(si_max);
858
859 extern int convert_real (st_parameter_dt *, void *, const char *, int);
860 internal_proto(convert_real);
861
862 extern int convert_infnan (st_parameter_dt *, void *, const char *, int);
863 internal_proto(convert_infnan);
864
865 extern void read_a (st_parameter_dt *, const fnode *, char *, size_t);
866 internal_proto(read_a);
867
868 extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, size_t);
869 internal_proto(read_a);
870
871 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
872 internal_proto(read_f);
873
874 extern void read_l (st_parameter_dt *, const fnode *, char *, int);
875 internal_proto(read_l);
876
877 extern void read_x (st_parameter_dt *, size_t);
878 internal_proto(read_x);
879
880 extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
881 internal_proto(read_radix);
882
883 extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
884 internal_proto(read_decimal);
885
886 extern void read_user_defined (st_parameter_dt *, void *);
887 internal_proto(read_user_defined);
888
889 extern void read_user_defined (st_parameter_dt *, void *);
890 internal_proto(read_user_defined);
891
892 /* list_read.c */
893
894 extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
895 size_t);
896 internal_proto(list_formatted_read);
897
898 extern void finish_list_read (st_parameter_dt *);
899 internal_proto(finish_list_read);
900
901 extern void namelist_read (st_parameter_dt *);
902 internal_proto(namelist_read);
903
904 extern void namelist_write (st_parameter_dt *);
905 internal_proto(namelist_write);
906
907 /* write.c */
908
909 extern void write_a (st_parameter_dt *, const fnode *, const char *, size_t);
910 internal_proto(write_a);
911
912 extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, size_t);
913 internal_proto(write_a_char4);
914
915 extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
916 internal_proto(write_b);
917
918 extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
919 internal_proto(write_d);
920
921 extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
922 internal_proto(write_e);
923
924 extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
925 internal_proto(write_en);
926
927 extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
928 internal_proto(write_es);
929
930 extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
931 internal_proto(write_f);
932
933 extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
934 internal_proto(write_i);
935
936 extern void write_l (st_parameter_dt *, const fnode *, char *, int);
937 internal_proto(write_l);
938
939 extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
940 internal_proto(write_o);
941
942 extern void write_real (st_parameter_dt *, const char *, int);
943 internal_proto(write_real);
944
945 extern void write_real_w0 (st_parameter_dt *, const char *, int, const fnode*);
946 internal_proto(write_real_w0);
947
948 extern void write_x (st_parameter_dt *, int, int);
949 internal_proto(write_x);
950
951 extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
952 internal_proto(write_z);
953
954 extern void write_user_defined (st_parameter_dt *, void *);
955 internal_proto(write_user_defined);
956
957 extern void write_user_defined (st_parameter_dt *, void *);
958 internal_proto(write_user_defined);
959
960 extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
961 size_t);
962 internal_proto(list_formatted_write);
963
964 /* size_from_kind.c */
965 extern size_t size_from_real_kind (int);
966 internal_proto(size_from_real_kind);
967
968 extern size_t size_from_complex_kind (int);
969 internal_proto(size_from_complex_kind);
970
971
972 /* lock.c */
973 extern void free_ionml (st_parameter_dt *);
974 internal_proto(free_ionml);
975
976 static inline void
inc_waiting_locked(gfc_unit * u)977 inc_waiting_locked (gfc_unit *u)
978 {
979 #ifdef HAVE_ATOMIC_FETCH_ADD
980 (void) __atomic_fetch_add (&u->waiting, 1, __ATOMIC_RELAXED);
981 #else
982 u->waiting++;
983 #endif
984 }
985
986 static inline int
predec_waiting_locked(gfc_unit * u)987 predec_waiting_locked (gfc_unit *u)
988 {
989 #ifdef HAVE_ATOMIC_FETCH_ADD
990 /* Note that the pattern
991
992 if (predec_waiting_locked (u) == 0)
993 // destroy u
994
995 could be further optimized by making this be an __ATOMIC_RELEASE,
996 and then inserting a
997
998 __atomic_thread_fence (__ATOMIC_ACQUIRE);
999
1000 inside the branch before destroying. But for now, lets keep it
1001 simple. */
1002 return __atomic_add_fetch (&u->waiting, -1, __ATOMIC_ACQ_REL);
1003 #else
1004 return --u->waiting;
1005 #endif
1006 }
1007
1008 static inline void
dec_waiting_unlocked(gfc_unit * u)1009 dec_waiting_unlocked (gfc_unit *u)
1010 {
1011 #ifdef HAVE_ATOMIC_FETCH_ADD
1012 (void) __atomic_fetch_add (&u->waiting, -1, __ATOMIC_RELAXED);
1013 #else
1014 __gthread_mutex_lock (&unit_lock);
1015 u->waiting--;
1016 __gthread_mutex_unlock (&unit_lock);
1017 #endif
1018 }
1019
1020
1021 static inline void
memset4(gfc_char4_t * p,gfc_char4_t c,int k)1022 memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
1023 {
1024 int j;
1025 for (j = 0; j < k; j++)
1026 *p++ = c;
1027 }
1028
1029 /* Used in width fields to indicate that the default should be used */
1030 #define DEFAULT_WIDTH -1
1031
1032 /* Defaults for certain format field descriptors. These are decided based on
1033 * the type of the value being formatted.
1034 *
1035 * The behaviour here is modelled on the Oracle Fortran compiler. At the time
1036 * of writing, the details were available at this URL:
1037 *
1038 * https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d
1039 */
1040
1041 static inline int
default_width_for_integer(int kind)1042 default_width_for_integer (int kind)
1043 {
1044 switch (kind)
1045 {
1046 case 1:
1047 case 2: return 7;
1048 case 4: return 12;
1049 case 8: return 23;
1050 case 16: return 44;
1051 default: return 0;
1052 }
1053 }
1054
1055 static inline int
default_width_for_float(int kind)1056 default_width_for_float (int kind)
1057 {
1058 switch (kind)
1059 {
1060 case 4: return 15;
1061 case 8: return 25;
1062 case 16: return 42;
1063 default: return 0;
1064 }
1065 }
1066
1067 static inline int
default_precision_for_float(int kind)1068 default_precision_for_float (int kind)
1069 {
1070 switch (kind)
1071 {
1072 case 4: return 7;
1073 case 8: return 16;
1074 case 16: return 33;
1075 default: return 0;
1076 }
1077 }
1078
1079 #endif
1080
1081 extern void
1082 st_write_done_worker (st_parameter_dt *);
1083 internal_proto (st_write_done_worker);
1084
1085 extern void
1086 st_read_done_worker (st_parameter_dt *);
1087 internal_proto (st_read_done_worker);
1088
1089 extern void
1090 data_transfer_init_worker (st_parameter_dt *, int);
1091 internal_proto (data_transfer_init_worker);
1092