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