1 /* Copyright (C) 2002-2024 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran runtime library (libgfortran).
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)
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.
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.
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/>. */
29 /* IO library include. */
31 #include "libgfortran.h"
35 #define gcc_unreachable() __builtin_unreachable ()
37 /* Used for building error message strings. */
40 /* POSIX 2008 specifies that the extended locale stuff is found in
41 locale.h, but some systems have them in xlocale.h. */
50 /* Forward declarations. */
51 struct st_parameter_dt
;
52 typedef struct stream stream
;
55 typedef struct fnode fnode
;
58 #if defined (HAVE_FREELOCALE) && defined (HAVE_NEWLOCALE) \
59 && defined (HAVE_USELOCALE)
60 /* We have POSIX 2008 extended locale stuff. We only choose to use it
61 if all the functions required are present as some systems, e.g. NetBSD
62 do not have `uselocale'. */
63 #define HAVE_POSIX_2008_LOCALE
64 extern locale_t c_locale
;
65 internal_proto(c_locale
);
67 extern char* old_locale
;
68 internal_proto(old_locale
);
69 extern int old_locale_ctr
;
70 internal_proto(old_locale_ctr
);
71 extern __gthread_mutex_t old_locale_lock
;
72 internal_proto(old_locale_lock
);
76 /* Macros for testing what kinds of I/O we are doing. */
78 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
80 #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
82 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
84 #define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4)
86 /* The array_loop_spec contains the variables for the loops over index ranges
87 that are encountered. */
89 typedef struct array_loop_spec
91 /* Index counter for this dimension. */
94 /* Start for the index counter. */
97 /* End for the index counter. */
100 /* Step for the index counter. */
105 /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
106 iomsg, (_iotype), (_iomsg)) */
107 typedef void (*formatted_dtio
)(void *, GFC_INTEGER_4
*, char *,
109 GFC_INTEGER_4
*, char *,
110 gfc_charlen_type
, gfc_charlen_type
);
112 /* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg)) */
113 typedef void (*unformatted_dtio
)(void *, GFC_INTEGER_4
*, GFC_INTEGER_4
*,
114 char *, gfc_charlen_type
);
116 /* The dtio calls for namelist require a CLASS object to be built. */
117 typedef struct gfc_class
126 /* A structure to build a hash table for format data. */
128 #define FORMAT_HASH_SIZE 16
130 typedef struct format_hash_entry
133 gfc_charlen_type key_len
;
134 struct format_data
*hashed_fmt
;
138 /* Format tokens. Only about half of these can be stored in the
143 FMT_NONE
= 0, FMT_UNKNOWN
, FMT_SIGNED_INT
, FMT_ZERO
, FMT_POSINT
, FMT_PERIOD
,
144 FMT_COMMA
, FMT_COLON
, FMT_SLASH
, FMT_DOLLAR
, FMT_T
, FMT_TR
, FMT_TL
,
145 FMT_LPAREN
, FMT_RPAREN
, FMT_X
, FMT_S
, FMT_SS
, FMT_SP
, FMT_STRING
,
146 FMT_BADSTRING
, FMT_P
, FMT_I
, FMT_B
, FMT_BN
, FMT_BZ
, FMT_O
, FMT_Z
, FMT_F
,
147 FMT_E
, FMT_EN
, FMT_ES
, FMT_G
, FMT_L
, FMT_A
, FMT_D
, FMT_H
, FMT_END
, FMT_DC
,
148 FMT_DP
, FMT_STAR
, FMT_RC
, FMT_RD
, FMT_RN
, FMT_RP
, FMT_RU
, FMT_RZ
, FMT_DT
152 /* Representation of a namelist object in libgfortran
155 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
157 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
159 The object can be a fully qualified, compound name for an intrinsic
160 type, derived types or derived type components. So, a substring
161 a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
162 read. Hence full information about the structure of the object has
163 to be available to list_read.c and write.
165 These requirements are met by the following data structures.
167 namelist_info type contains all the scalar information about the
168 object and arrays of descriptor_dimension and array_loop_spec types for
171 typedef struct namelist_type
179 /* Address for the start of the object's data. */
182 /* Address of specific DTIO subroutine. */
185 /* Address of vtable if dtio_sub non-null. */
188 /* Flag to show that a read is to be attempted for this node. */
191 /* Length of intrinsic type in bytes. */
194 /* Rank of the object. */
197 /* Overall size of the object in bytes. */
200 /* Length of character string. */
201 index_type string_length
;
203 descriptor_dimension
* dim
;
204 array_loop_spec
* ls
;
205 struct namelist_type
* next
;
209 /* Options for the OPEN statement. */
212 { ACCESS_SEQUENTIAL
, ACCESS_DIRECT
, ACCESS_APPEND
, ACCESS_STREAM
,
218 { ACTION_READ
, ACTION_WRITE
, ACTION_READWRITE
,
224 { BLANK_NULL
, BLANK_ZERO
, BLANK_UNSPECIFIED
}
228 { DELIM_NONE
, DELIM_APOSTROPHE
, DELIM_QUOTE
,
234 { FORM_FORMATTED
, FORM_UNFORMATTED
, FORM_UNSPECIFIED
}
238 { POSITION_ASIS
, POSITION_REWIND
, POSITION_APPEND
,
244 { STATUS_UNKNOWN
, STATUS_OLD
, STATUS_NEW
, STATUS_SCRATCH
,
245 STATUS_REPLACE
, STATUS_UNSPECIFIED
250 { PAD_YES
, PAD_NO
, PAD_UNSPECIFIED
}
254 { DECIMAL_POINT
, DECIMAL_COMMA
, DECIMAL_UNSPECIFIED
}
258 { ENCODING_UTF8
, ENCODING_DEFAULT
, ENCODING_UNSPECIFIED
}
262 { ROUND_UP
= GFC_FPE_UPWARD
,
263 ROUND_DOWN
= GFC_FPE_DOWNWARD
,
264 ROUND_ZERO
= GFC_FPE_TOWARDZERO
,
265 ROUND_NEAREST
= GFC_FPE_TONEAREST
,
266 ROUND_COMPATIBLE
= 10, /* round away from zero. */
267 ROUND_PROCDEFINED
, /* Here as ROUND_NEAREST. */
268 ROUND_UNSPECIFIED
/* Should never occur. */
272 /* NOTE: unit_sign must correspond with the sign_status enumerator in
273 st_parameter_dt to not break the ABI. */
275 { SIGN_PROCDEFINED
, SIGN_SUPPRESS
, SIGN_PLUS
, SIGN_UNSPECIFIED
}
279 { ADVANCE_YES
, ADVANCE_NO
, ADVANCE_UNSPECIFIED
}
283 {READING
, WRITING
, LIST_READING
, LIST_WRITING
}
287 { ASYNC_YES
, ASYNC_NO
, ASYNC_UNSPECIFIED
}
291 { SHARE_DENYRW
, SHARE_DENYNONE
,
297 { CC_LIST
, CC_FORTRAN
, CC_NONE
,
302 /* End-of-record types for CC_FORTRAN. */
310 CCF_OVERPRINT_NOA
=0x20,
315 { SIGN_S
, SIGN_SS
, SIGN_SP
}
318 /* Make sure to keep st_parameter_* in sync with gcc/fortran/ioparm.def. */
320 #define CHARACTER1(name) \
322 gfc_charlen_type name ## _len
323 #define CHARACTER2(name) \
324 gfc_charlen_type name ## _len; \
329 st_parameter_common common
;
336 CHARACTER1 (position
);
340 CHARACTER1 (convert
);
341 CHARACTER2 (decimal
);
342 CHARACTER1 (encoding
);
345 CHARACTER2 (asynchronous
);
346 GFC_INTEGER_4
*newunit
;
347 GFC_INTEGER_4 readonly
;
353 #define IOPARM_CLOSE_HAS_STATUS (1 << 7)
357 st_parameter_common common
;
364 st_parameter_common common
;
366 st_parameter_filepos
;
368 #define IOPARM_INQUIRE_HAS_EXIST (1 << 7)
369 #define IOPARM_INQUIRE_HAS_OPENED (1 << 8)
370 #define IOPARM_INQUIRE_HAS_NUMBER (1 << 9)
371 #define IOPARM_INQUIRE_HAS_NAMED (1 << 10)
372 #define IOPARM_INQUIRE_HAS_NEXTREC (1 << 11)
373 #define IOPARM_INQUIRE_HAS_RECL_OUT (1 << 12)
374 #define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 13)
375 #define IOPARM_INQUIRE_HAS_FILE (1 << 14)
376 #define IOPARM_INQUIRE_HAS_ACCESS (1 << 15)
377 #define IOPARM_INQUIRE_HAS_FORM (1 << 16)
378 #define IOPARM_INQUIRE_HAS_BLANK (1 << 17)
379 #define IOPARM_INQUIRE_HAS_POSITION (1 << 18)
380 #define IOPARM_INQUIRE_HAS_ACTION (1 << 19)
381 #define IOPARM_INQUIRE_HAS_DELIM (1 << 20)
382 #define IOPARM_INQUIRE_HAS_PAD (1 << 21)
383 #define IOPARM_INQUIRE_HAS_NAME (1 << 22)
384 #define IOPARM_INQUIRE_HAS_SEQUENTIAL (1 << 23)
385 #define IOPARM_INQUIRE_HAS_DIRECT (1 << 24)
386 #define IOPARM_INQUIRE_HAS_FORMATTED (1 << 25)
387 #define IOPARM_INQUIRE_HAS_UNFORMATTED (1 << 26)
388 #define IOPARM_INQUIRE_HAS_READ (1 << 27)
389 #define IOPARM_INQUIRE_HAS_WRITE (1 << 28)
390 #define IOPARM_INQUIRE_HAS_READWRITE (1 << 29)
391 #define IOPARM_INQUIRE_HAS_CONVERT (1 << 30)
392 #define IOPARM_INQUIRE_HAS_FLAGS2 (1u << 31)
394 #define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0)
395 #define IOPARM_INQUIRE_HAS_DECIMAL (1 << 1)
396 #define IOPARM_INQUIRE_HAS_ENCODING (1 << 2)
397 #define IOPARM_INQUIRE_HAS_ROUND (1 << 3)
398 #define IOPARM_INQUIRE_HAS_SIGN (1 << 4)
399 #define IOPARM_INQUIRE_HAS_PENDING (1 << 5)
400 #define IOPARM_INQUIRE_HAS_SIZE (1 << 6)
401 #define IOPARM_INQUIRE_HAS_ID (1 << 7)
402 #define IOPARM_INQUIRE_HAS_IQSTREAM (1 << 8)
403 #define IOPARM_INQUIRE_HAS_SHARE (1 << 9)
404 #define IOPARM_INQUIRE_HAS_CC (1 << 10)
408 st_parameter_common common
;
409 GFC_INTEGER_4
*exist
, *opened
, *number
, *named
;
410 GFC_IO_INT
*nextrec
, *recl_out
, *strm_pos_out
;
415 CHARACTER1 (position
);
420 CHARACTER2 (sequential
);
422 CHARACTER2 (formatted
);
423 CHARACTER1 (unformatted
);
426 CHARACTER2 (readwrite
);
427 CHARACTER1 (convert
);
428 GFC_INTEGER_4 flags2
;
429 CHARACTER1 (asynchronous
);
430 CHARACTER2 (decimal
);
431 CHARACTER1 (encoding
);
434 GFC_INTEGER_4
*pending
;
437 CHARACTER1 (iqstream
);
441 st_parameter_inquire
;
444 #define IOPARM_DT_LIST_FORMAT (1 << 7)
445 #define IOPARM_DT_NAMELIST_READ_MODE (1 << 8)
446 #define IOPARM_DT_HAS_REC (1 << 9)
447 #define IOPARM_DT_HAS_SIZE (1 << 10)
448 #define IOPARM_DT_HAS_IOLENGTH (1 << 11)
449 #define IOPARM_DT_HAS_FORMAT (1 << 12)
450 #define IOPARM_DT_HAS_ADVANCE (1 << 13)
451 #define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14)
452 #define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15)
453 #define IOPARM_DT_HAS_ID (1 << 16)
454 #define IOPARM_DT_HAS_POS (1 << 17)
455 #define IOPARM_DT_HAS_ASYNCHRONOUS (1 << 18)
456 #define IOPARM_DT_HAS_BLANK (1 << 19)
457 #define IOPARM_DT_HAS_DECIMAL (1 << 20)
458 #define IOPARM_DT_HAS_DELIM (1 << 21)
459 #define IOPARM_DT_HAS_PAD (1 << 22)
460 #define IOPARM_DT_HAS_ROUND (1 << 23)
461 #define IOPARM_DT_HAS_SIGN (1 << 24)
462 #define IOPARM_DT_HAS_F2003 (1 << 25)
463 #define IOPARM_DT_HAS_UDTIO (1 << 26)
464 #define IOPARM_DT_DEC_EXT (1 << 27)
465 /* Internal use bit. */
466 #define IOPARM_DT_IONML_SET (1u << 31)
469 typedef struct st_parameter_dt
471 st_parameter_common common
;
473 GFC_IO_INT
*size
, *iolength
;
474 gfc_array_char
*internal_unit_desc
;
476 CHARACTER2 (advance
);
477 CHARACTER1 (internal_unit
);
478 CHARACTER2 (namelist_name
);
481 CHARACTER1 (asynchronous
);
483 CHARACTER1 (decimal
);
488 /* Private part of the structure. The compiler just needs
489 to reserve enough space. */
494 void (*transfer
) (struct st_parameter_dt
*, bt
, void *, int,
496 struct gfc_unit
*current_unit
;
497 /* Item number in a formatted data transfer. Also used in namelist
498 read_logical as an index into line_buffer. */
501 unit_blank blank_status
;
502 unit_sign sign_status
;
504 /* Maximum righthand column written to. */
506 /* Number of skips + spaces to be done for T and X-editing. */
508 /* Number of spaces to be done for T and X-editing. */
510 /* Whether an EOR condition was encountered. Value is:
511 0 if no EOR was encountered
512 1 if an EOR was encountered due to a 1-byte marker (LF)
513 2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
515 unit_advance advance_status
;
516 unsigned reversion_flag
: 1; /* Format reversion has occurred. */
517 unsigned first_item
: 1;
518 unsigned seen_dollar
: 1;
519 unsigned eor_condition
: 1;
520 unsigned no_leading_blank
: 1;
521 unsigned char_flag
: 1;
522 unsigned input_complete
: 1;
524 unsigned comma_flag
: 1;
525 /* A namelist specific flag used in the list directed library
526 to flag that calls are being made from namelist read (e.g. to
527 ignore comments or to treat '/' as a terminator) */
528 unsigned namelist_mode
: 1;
529 /* A namelist specific flag used in the list directed library
530 to flag read errors and return, so that an attempt can be
531 made to read a new object name. */
532 unsigned nml_read_error
: 1;
533 /* A sequential formatted read specific flag used to signal that a
534 character string is being read so don't use commas to shorten a
535 formatted field width. */
536 unsigned sf_read_comma
: 1;
537 /* A namelist specific flag used to enable reading input from
538 line_buffer for logical reads. */
539 unsigned line_buffer_enabled
: 1;
540 /* An internal unit specific flag used to identify that the associated
542 unsigned unit_is_internal
: 1;
543 /* An internal unit specific flag to signify an EOF condition for list
546 /* Used for g0 floating point output. */
547 unsigned g0_no_blanks
: 1;
548 /* Used to signal use of free_format_data. */
549 unsigned format_not_saved
: 1;
550 /* A flag used to identify when a non-standard expanded namelist read
552 unsigned expanded_read
: 1;
553 /* Flag to indicate if the statement has async="YES". */
555 /* 12 unused bits. */
557 int child_saved_iostat
;
566 struct format_data
*fmt
;
567 namelist_info
*ionml
;
568 #ifdef HAVE_POSIX_2008_LOCALE
571 /* Current position within the look-ahead line buffer. */
573 /* Storage area for values except for strings. Must be
574 large enough to hold a complex value (two reals) of the
577 GFC_IO_INT not_used
; /* Needed for alignment. */
578 formatted_dtio fdtio_ptr
;
579 unformatted_dtio ufdtio_ptr
;
580 /* With CC_FORTRAN, the first character of a record determines the
581 style of record end (and start) to use. We must mark down the type
582 when we write first in write_a so we remember the end type later in
586 unsigned type
: 6; /* See enum cc_fortran. */
587 unsigned len
: 2; /* Always 0, 1, or 2. */
588 /* The union is updated after start-of-record is written. */
591 char start
; /* Output character for start of record. */
592 char end
; /* Output character for end of record. */
596 /* This pad size must be equal to the pad_size declared in
597 trans-io.c (gfc_build_io_library_fndecls). The above structure
598 must be smaller or equal to this array. */
599 char pad
[16 * sizeof (char *) + 32 * sizeof (int)];
604 /* Ensure st_parameter_dt's u.pad is bigger or equal to u.p. */
605 extern char check_st_parameter_dt
[sizeof (((st_parameter_dt
*) 0)->u
.pad
)
606 >= sizeof (((st_parameter_dt
*) 0)->u
.p
)
609 #define IOPARM_WAIT_HAS_ID (1 << 7)
613 st_parameter_common common
;
630 unit_position position
;
633 unit_convert convert
;
635 unit_decimal decimal
;
636 unit_encoding encoding
;
647 typedef struct gfc_unit
653 struct gfc_unit
*left
, *right
;
656 int read_bad
, current_record
, saved_pos
, previous_nonadvancing_write
;
659 { NO_ENDFILE
, AT_ENDFILE
, AFTER_ENDFILE
}
665 unit_decimal decimal_status
;
666 unit_delim delim_status
;
667 unit_round round_status
;
669 /* recl -- Record length of the file.
670 last_record -- Last record number read or written
671 maxrec -- Maximum record number in a direct access file
672 bytes_left -- Bytes left in current record.
673 strm_pos -- Current position in file for STREAM I/O.
674 recl_subrecord -- Maximum length for subrecord.
675 bytes_left_subrecord -- Bytes left in current subrecord. */
676 gfc_offset recl
, last_record
, maxrec
, bytes_left
, strm_pos
,
677 recl_subrecord
, bytes_left_subrecord
;
679 /* Set to 1 if we have read a subrecord. */
683 /* Contains the pointer to the async unit. */
684 struct async_unit
*au
;
686 __gthread_mutex_t lock
;
687 /* Number of threads waiting to acquire this unit's lock.
688 When non-zero, close_unit doesn't only removes the unit
689 from the UNIT_ROOT tree, but doesn't free it and the
690 last of the waiting threads will do that.
691 This must be either atomically increased/decreased, or
692 always guarded by UNIT_RWLOCK. */
694 /* Flag set by close_unit if the unit as been closed.
695 Must be manipulated under unit's lock. */
698 /* For traversing arrays */
702 /* Name of the file at the time OPEN was executed, as a
703 null-terminated C string. */
706 /* The format hash table. */
707 struct format_hash_entry format_hash_table
[FORMAT_HASH_SIZE
];
709 /* Formatting buffer. */
712 /* Function pointer, points to list_read worker functions. */
713 int (*next_char_fn_ptr
) (st_parameter_dt
*);
714 void (*push_char_fn_ptr
) (st_parameter_dt
*, int);
716 /* Internal unit char string data. */
717 char * internal_unit
;
718 gfc_charlen_type internal_unit_len
;
719 gfc_array_char
*string_unit_desc
;
720 int internal_unit_kind
;
722 /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */
725 /* Used for ungetc() style functionality. Possible values
726 are an unsigned char, EOF, or EOF - 1 used to mark the
727 field as not valid. */
730 GFC_IO_INT size_used
;
734 typedef struct gfc_saved_unit
736 GFC_INTEGER_4 unit_number
;
741 /* TEMP_FAILURE_RETRY macro from glibc. */
743 #ifndef TEMP_FAILURE_RETRY
744 /* Evaluate EXPRESSION, and repeat as long as it returns -1 with `errno'
747 # define TEMP_FAILURE_RETRY(expression) \
749 ({ long int __result; \
750 do __result = (long int) (expression); \
751 while (__result == -1L && errno == EINTR); \
758 /* Maximum file offset, computed at library initialization time. */
759 extern gfc_offset max_offset
;
760 internal_proto(max_offset
);
762 /* Default RECL for sequential access if not given in OPEN statement,
763 computed at library initialization time. */
764 extern gfc_offset default_recl
;
765 internal_proto(default_recl
);
767 /* Unit tree root. */
768 extern gfc_unit
*unit_root
;
769 internal_proto(unit_root
);
771 #ifdef __GTHREAD_RWLOCK_INIT
772 extern __gthread_rwlock_t unit_rwlock
;
773 internal_proto(unit_rwlock
);
775 extern __gthread_mutex_t unit_rwlock
;
776 internal_proto(unit_rwlock
);
779 extern int close_unit (gfc_unit
*);
780 internal_proto(close_unit
);
782 extern gfc_unit
*set_internal_unit (st_parameter_dt
*, gfc_unit
*, int);
783 internal_proto(set_internal_unit
);
785 extern void stash_internal_unit (st_parameter_dt
*);
786 internal_proto(stash_internal_unit
);
788 extern gfc_unit
*find_unit (int);
789 internal_proto(find_unit
);
791 extern gfc_unit
*find_or_create_unit (int);
792 internal_proto(find_or_create_unit
);
794 extern gfc_unit
*get_unit (st_parameter_dt
*, int);
795 internal_proto(get_unit
);
797 extern void unlock_unit(gfc_unit
*);
798 internal_proto(unlock_unit
);
800 extern void finish_last_advance_record (gfc_unit
*u
);
801 internal_proto(finish_last_advance_record
);
803 extern int unit_truncate(gfc_unit
*, gfc_offset
, st_parameter_common
*);
804 internal_proto(unit_truncate
);
806 extern int newunit_alloc (void);
807 internal_proto(newunit_alloc
);
809 extern void newunit_free (int);
810 internal_proto(newunit_free
);
815 extern gfc_unit
*new_unit (st_parameter_open
*, gfc_unit
*, unit_flags
*);
816 internal_proto(new_unit
);
821 #define SCRATCH_SIZE 300
823 extern const char *type_name (bt
);
824 internal_proto(type_name
);
826 extern void * read_block_form (st_parameter_dt
*, size_t *);
827 internal_proto(read_block_form
);
829 extern void * read_block_form4 (st_parameter_dt
*, size_t *);
830 internal_proto(read_block_form4
);
832 extern void *write_block (st_parameter_dt
*, size_t);
833 internal_proto(write_block
);
835 extern gfc_offset
next_array_record (st_parameter_dt
*, array_loop_spec
*,
837 internal_proto(next_array_record
);
839 extern gfc_offset
init_loop_spec (gfc_array_char
*, array_loop_spec
*,
841 internal_proto(init_loop_spec
);
843 extern void next_record (st_parameter_dt
*, int);
844 internal_proto(next_record
);
846 extern void st_wait (st_parameter_wait
*);
847 export_proto (st_wait
);
849 extern void st_wait_async (st_parameter_wait
*);
850 export_proto (st_wait_async
);
852 extern void hit_eof (st_parameter_dt
*);
853 internal_proto(hit_eof
);
855 extern void transfer_array_inner (st_parameter_dt
*, gfc_array_char
*, int,
857 internal_proto (transfer_array_inner
);
861 extern void set_integer (void *, GFC_INTEGER_LARGEST
, int);
862 internal_proto(set_integer
);
864 extern GFC_UINTEGER_LARGEST
si_max (int);
865 internal_proto(si_max
);
867 extern int convert_real (st_parameter_dt
*, void *, const char *, int);
868 internal_proto(convert_real
);
870 extern int convert_infnan (st_parameter_dt
*, void *, const char *, int);
871 internal_proto(convert_infnan
);
873 extern void read_a (st_parameter_dt
*, const fnode
*, char *, size_t);
874 internal_proto(read_a
);
876 extern void read_a_char4 (st_parameter_dt
*, const fnode
*, char *, size_t);
877 internal_proto(read_a
);
879 extern void read_f (st_parameter_dt
*, const fnode
*, char *, int);
880 internal_proto(read_f
);
882 extern void read_l (st_parameter_dt
*, const fnode
*, char *, int);
883 internal_proto(read_l
);
885 extern void read_x (st_parameter_dt
*, size_t);
886 internal_proto(read_x
);
888 extern void read_radix (st_parameter_dt
*, const fnode
*, char *, int, int);
889 internal_proto(read_radix
);
891 extern void read_decimal (st_parameter_dt
*, const fnode
*, char *, int);
892 internal_proto(read_decimal
);
894 extern void read_user_defined (st_parameter_dt
*, void *);
895 internal_proto(read_user_defined
);
897 extern void read_user_defined (st_parameter_dt
*, void *);
898 internal_proto(read_user_defined
);
902 extern void list_formatted_read (st_parameter_dt
*, bt
, void *, int, size_t,
904 internal_proto(list_formatted_read
);
906 extern void finish_list_read (st_parameter_dt
*);
907 internal_proto(finish_list_read
);
909 extern void namelist_read (st_parameter_dt
*);
910 internal_proto(namelist_read
);
912 extern void namelist_write (st_parameter_dt
*);
913 internal_proto(namelist_write
);
917 extern void write_a (st_parameter_dt
*, const fnode
*, const char *, size_t);
918 internal_proto(write_a
);
920 extern void write_a_char4 (st_parameter_dt
*, const fnode
*, const char *, size_t);
921 internal_proto(write_a_char4
);
923 extern void write_b (st_parameter_dt
*, const fnode
*, const char *, int);
924 internal_proto(write_b
);
926 extern void write_d (st_parameter_dt
*, const fnode
*, const char *, int);
927 internal_proto(write_d
);
929 extern void write_e (st_parameter_dt
*, const fnode
*, const char *, int);
930 internal_proto(write_e
);
932 extern void write_en (st_parameter_dt
*, const fnode
*, const char *, int);
933 internal_proto(write_en
);
935 extern void write_es (st_parameter_dt
*, const fnode
*, const char *, int);
936 internal_proto(write_es
);
938 extern void write_f (st_parameter_dt
*, const fnode
*, const char *, int);
939 internal_proto(write_f
);
941 extern void write_i (st_parameter_dt
*, const fnode
*, const char *, int);
942 internal_proto(write_i
);
944 extern void write_l (st_parameter_dt
*, const fnode
*, char *, int);
945 internal_proto(write_l
);
947 extern void write_o (st_parameter_dt
*, const fnode
*, const char *, int);
948 internal_proto(write_o
);
950 extern void write_real (st_parameter_dt
*, const char *, int);
951 internal_proto(write_real
);
953 extern void write_real_w0 (st_parameter_dt
*, const char *, int, const fnode
*);
954 internal_proto(write_real_w0
);
956 extern void write_x (st_parameter_dt
*, int, int);
957 internal_proto(write_x
);
959 extern void write_z (st_parameter_dt
*, const fnode
*, const char *, int);
960 internal_proto(write_z
);
962 extern void write_user_defined (st_parameter_dt
*, void *);
963 internal_proto(write_user_defined
);
965 extern void write_user_defined (st_parameter_dt
*, void *);
966 internal_proto(write_user_defined
);
968 extern void list_formatted_write (st_parameter_dt
*, bt
, void *, int, size_t,
970 internal_proto(list_formatted_write
);
972 /* size_from_kind.c */
973 extern size_t size_from_real_kind (int);
974 internal_proto(size_from_real_kind
);
976 extern size_t size_from_complex_kind (int);
977 internal_proto(size_from_complex_kind
);
981 extern void free_ionml (st_parameter_dt
*);
982 internal_proto(free_ionml
);
985 inc_waiting_locked (gfc_unit
*u
)
987 #ifdef HAVE_ATOMIC_FETCH_ADD
988 (void) __atomic_fetch_add (&u
->waiting
, 1, __ATOMIC_RELAXED
);
995 predec_waiting_locked (gfc_unit
*u
)
997 #ifdef HAVE_ATOMIC_FETCH_ADD
998 /* Note that the pattern
1000 if (predec_waiting_locked (u) == 0)
1003 could be further optimized by making this be an __ATOMIC_RELEASE,
1004 and then inserting a
1006 __atomic_thread_fence (__ATOMIC_ACQUIRE);
1008 inside the branch before destroying. But for now, lets keep it
1010 return __atomic_add_fetch (&u
->waiting
, -1, __ATOMIC_ACQ_REL
);
1012 return --u
->waiting
;
1017 dec_waiting_unlocked (gfc_unit
*u
)
1019 #ifdef HAVE_ATOMIC_FETCH_ADD
1020 (void) __atomic_fetch_add (&u
->waiting
, -1, __ATOMIC_RELAXED
);
1022 #ifdef __GTHREAD_RWLOCK_INIT
1023 __gthread_rwlock_wrlock (&unit_rwlock
);
1025 __gthread_rwlock_unlock (&unit_rwlock
);
1027 __gthread_mutex_lock (&unit_rwlock
);
1029 __gthread_mutex_unlock (&unit_rwlock
);
1036 memset4 (gfc_char4_t
*p
, gfc_char4_t c
, int k
)
1039 for (j
= 0; j
< k
; j
++)
1043 /* Used in width fields to indicate that the default should be used */
1044 #define DEFAULT_WIDTH -1
1046 /* Defaults for certain format field descriptors. These are decided based on
1047 * the type of the value being formatted.
1049 * The behaviour here is modelled on the Oracle Fortran compiler. At the time
1050 * of writing, the details were available at this URL:
1052 * https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d
1056 default_width_for_integer (int kind
)
1070 default_width_for_float (int kind
)
1083 default_precision_for_float (int kind
)
1098 st_write_done_worker (st_parameter_dt
*, bool);
1099 internal_proto (st_write_done_worker
);
1102 st_read_done_worker (st_parameter_dt
*, bool);
1103 internal_proto (st_read_done_worker
);
1106 data_transfer_init_worker (st_parameter_dt
*, int);
1107 internal_proto (data_transfer_init_worker
);