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 /* POSIX 2008 specifies that the extended locale stuff is found in
38 locale.h, but some systems have them in xlocale.h. */
47 /* Forward declarations. */
48 struct st_parameter_dt
;
49 typedef struct stream stream
;
52 typedef struct fnode fnode
;
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
);
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
);
73 /* Macros for testing what kinds of I/O we are doing. */
75 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
77 #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
79 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
81 #define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4)
83 /* The array_loop_spec contains the variables for the loops over index ranges
84 that are encountered. */
86 typedef struct array_loop_spec
88 /* Index counter for this dimension. */
91 /* Start for the index counter. */
94 /* End for the index counter. */
97 /* Step for the index counter. */
102 /* User defined input/output iomsg length. */
104 #define IOMSG_LEN 256
106 /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
107 iomsg, (_iotype), (_iomsg)) */
108 typedef void (*formatted_dtio
)(void *, GFC_INTEGER_4
*, char *,
110 GFC_INTEGER_4
*, char *,
111 gfc_charlen_type
, gfc_charlen_type
);
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
);
117 /* The dtio calls for namelist require a CLASS object to be built. */
118 typedef struct gfc_class
127 /* A structure to build a hash table for format data. */
129 #define FORMAT_HASH_SIZE 16
131 typedef struct format_hash_entry
134 gfc_charlen_type key_len
;
135 struct format_data
*hashed_fmt
;
139 /* Format tokens. Only about half of these can be stored in the
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
153 /* Representation of a namelist object in libgfortran
156 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
158 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
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.
166 These requirements are met by the following data structures.
168 namelist_info type contains all the scalar information about the
169 object and arrays of descriptor_dimension and array_loop_spec types for
172 typedef struct namelist_type
180 /* Address for the start of the object's data. */
183 /* Address of specific DTIO subroutine. */
186 /* Address of vtable if dtio_sub non-null. */
189 /* Flag to show that a read is to be attempted for this node. */
192 /* Length of intrinsic type in bytes. */
195 /* Rank of the object. */
198 /* Overall size of the object in bytes. */
201 /* Length of character string. */
202 index_type string_length
;
204 descriptor_dimension
* dim
;
205 array_loop_spec
* ls
;
206 struct namelist_type
* next
;
210 /* Options for the OPEN statement. */
213 { ACCESS_SEQUENTIAL
, ACCESS_DIRECT
, ACCESS_APPEND
, ACCESS_STREAM
,
219 { ACTION_READ
, ACTION_WRITE
, ACTION_READWRITE
,
225 { BLANK_NULL
, BLANK_ZERO
, BLANK_UNSPECIFIED
}
229 { DELIM_NONE
, DELIM_APOSTROPHE
, DELIM_QUOTE
,
235 { FORM_FORMATTED
, FORM_UNFORMATTED
, FORM_UNSPECIFIED
}
239 { POSITION_ASIS
, POSITION_REWIND
, POSITION_APPEND
,
245 { STATUS_UNKNOWN
, STATUS_OLD
, STATUS_NEW
, STATUS_SCRATCH
,
246 STATUS_REPLACE
, STATUS_UNSPECIFIED
251 { PAD_YES
, PAD_NO
, PAD_UNSPECIFIED
}
255 { DECIMAL_POINT
, DECIMAL_COMMA
, DECIMAL_UNSPECIFIED
}
259 { ENCODING_UTF8
, ENCODING_DEFAULT
, ENCODING_UNSPECIFIED
}
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. */
273 /* NOTE: unit_sign must correspond with the sign_status enumerator in
274 st_parameter_dt to not break the ABI. */
276 { SIGN_PROCDEFINED
, SIGN_SUPPRESS
, SIGN_PLUS
, SIGN_UNSPECIFIED
}
280 { ADVANCE_YES
, ADVANCE_NO
, ADVANCE_UNSPECIFIED
}
284 {READING
, WRITING
, LIST_READING
, LIST_WRITING
}
288 { ASYNC_YES
, ASYNC_NO
, ASYNC_UNSPECIFIED
}
292 { SHARE_DENYRW
, SHARE_DENYNONE
,
298 { CC_LIST
, CC_FORTRAN
, CC_NONE
,
303 /* End-of-record types for CC_FORTRAN. */
311 CCF_OVERPRINT_NOA
=0x20,
316 { SIGN_S
, SIGN_SS
, SIGN_SP
}
319 /* Make sure to keep st_parameter_* in sync with gcc/fortran/ioparm.def. */
321 #define CHARACTER1(name) \
323 gfc_charlen_type name ## _len
324 #define CHARACTER2(name) \
325 gfc_charlen_type name ## _len; \
330 st_parameter_common common
;
337 CHARACTER1 (position
);
341 CHARACTER1 (convert
);
342 CHARACTER2 (decimal
);
343 CHARACTER1 (encoding
);
346 CHARACTER2 (asynchronous
);
347 GFC_INTEGER_4
*newunit
;
348 GFC_INTEGER_4 readonly
;
354 #define IOPARM_CLOSE_HAS_STATUS (1 << 7)
358 st_parameter_common common
;
365 st_parameter_common common
;
367 st_parameter_filepos
;
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)
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)
409 st_parameter_common common
;
410 GFC_INTEGER_4
*exist
, *opened
, *number
, *named
;
411 GFC_IO_INT
*nextrec
, *recl_out
, *strm_pos_out
;
416 CHARACTER1 (position
);
421 CHARACTER2 (sequential
);
423 CHARACTER2 (formatted
);
424 CHARACTER1 (unformatted
);
427 CHARACTER2 (readwrite
);
428 CHARACTER1 (convert
);
429 GFC_INTEGER_4 flags2
;
430 CHARACTER1 (asynchronous
);
431 CHARACTER2 (decimal
);
432 CHARACTER1 (encoding
);
435 GFC_INTEGER_4
*pending
;
438 CHARACTER1 (iqstream
);
442 st_parameter_inquire
;
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)
470 typedef struct st_parameter_dt
472 st_parameter_common common
;
474 GFC_IO_INT
*size
, *iolength
;
475 gfc_array_char
*internal_unit_desc
;
477 CHARACTER2 (advance
);
478 CHARACTER1 (internal_unit
);
479 CHARACTER2 (namelist_name
);
482 CHARACTER1 (asynchronous
);
484 CHARACTER1 (decimal
);
489 /* Private part of the structure. The compiler just needs
490 to reserve enough space. */
495 void (*transfer
) (struct st_parameter_dt
*, bt
, void *, int,
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. */
502 unit_blank blank_status
;
503 unit_sign sign_status
;
505 /* Maximum righthand column written to. */
507 /* Number of skips + spaces to be done for T and X-editing. */
509 /* Number of spaces to be done for T and X-editing. */
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) */
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;
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
543 unsigned unit_is_internal
: 1;
544 /* An internal unit specific flag to signify an EOF condition for list
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
553 unsigned expanded_read
: 1;
554 /* Flag to indicate if the statement has async="YES". */
556 /* 12 unused bits. */
558 int child_saved_iostat
;
567 struct format_data
*fmt
;
568 namelist_info
*ionml
;
569 #ifdef HAVE_POSIX_2008_LOCALE
572 /* Current position within the look-ahead line buffer. */
574 /* Storage area for values except for strings. Must be
575 large enough to hold a complex value (two reals) of the
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
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. */
592 char start
; /* Output character for start of record. */
593 char end
; /* Output character for end of record. */
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)];
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
)
610 #define IOPARM_WAIT_HAS_ID (1 << 7)
614 st_parameter_common common
;
631 unit_position position
;
634 unit_convert convert
;
636 unit_decimal decimal
;
637 unit_encoding encoding
;
648 typedef struct gfc_unit
654 struct gfc_unit
*left
, *right
;
657 int read_bad
, current_record
, saved_pos
, previous_nonadvancing_write
;
660 { NO_ENDFILE
, AT_ENDFILE
, AFTER_ENDFILE
}
666 unit_decimal decimal_status
;
667 unit_delim delim_status
;
668 unit_round round_status
;
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
;
680 /* Set to 1 if we have read a subrecord. */
684 /* Contains the pointer to the async unit. */
685 struct async_unit
*au
;
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_RWLOCK. */
695 /* Flag set by close_unit if the unit as been closed.
696 Must be manipulated under unit's lock. */
699 /* For traversing arrays */
703 /* Name of the file at the time OPEN was executed, as a
704 null-terminated C string. */
707 /* The format hash table. */
708 struct format_hash_entry format_hash_table
[FORMAT_HASH_SIZE
];
710 /* Formatting buffer. */
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);
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
;
723 /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */
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. */
731 GFC_IO_INT size_used
;
735 typedef struct gfc_saved_unit
737 GFC_INTEGER_4 unit_number
;
742 /* TEMP_FAILURE_RETRY macro from glibc. */
744 #ifndef TEMP_FAILURE_RETRY
745 /* Evaluate EXPRESSION, and repeat as long as it returns -1 with `errno'
748 # define TEMP_FAILURE_RETRY(expression) \
750 ({ long int __result; \
751 do __result = (long int) (expression); \
752 while (__result == -1L && errno == EINTR); \
759 /* Maximum file offset, computed at library initialization time. */
760 extern gfc_offset max_offset
;
761 internal_proto(max_offset
);
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
);
768 /* Unit tree root. */
769 extern gfc_unit
*unit_root
;
770 internal_proto(unit_root
);
772 #ifdef __GTHREAD_RWLOCK_INIT
773 extern __gthread_rwlock_t unit_rwlock
;
774 internal_proto(unit_rwlock
);
776 extern __gthread_mutex_t unit_rwlock
;
777 internal_proto(unit_rwlock
);
780 extern int close_unit (gfc_unit
*);
781 internal_proto(close_unit
);
783 extern gfc_unit
*set_internal_unit (st_parameter_dt
*, gfc_unit
*, int);
784 internal_proto(set_internal_unit
);
786 extern void stash_internal_unit (st_parameter_dt
*);
787 internal_proto(stash_internal_unit
);
789 extern gfc_unit
*find_unit (int);
790 internal_proto(find_unit
);
792 extern gfc_unit
*find_or_create_unit (int);
793 internal_proto(find_or_create_unit
);
795 extern gfc_unit
*get_unit (st_parameter_dt
*, int);
796 internal_proto(get_unit
);
798 extern void unlock_unit(gfc_unit
*);
799 internal_proto(unlock_unit
);
801 extern void finish_last_advance_record (gfc_unit
*u
);
802 internal_proto(finish_last_advance_record
);
804 extern int unit_truncate(gfc_unit
*, gfc_offset
, st_parameter_common
*);
805 internal_proto(unit_truncate
);
807 extern int newunit_alloc (void);
808 internal_proto(newunit_alloc
);
810 extern void newunit_free (int);
811 internal_proto(newunit_free
);
816 extern gfc_unit
*new_unit (st_parameter_open
*, gfc_unit
*, unit_flags
*);
817 internal_proto(new_unit
);
822 #define SCRATCH_SIZE 300
824 extern const char *type_name (bt
);
825 internal_proto(type_name
);
827 extern void * read_block_form (st_parameter_dt
*, size_t *);
828 internal_proto(read_block_form
);
830 extern void * read_block_form4 (st_parameter_dt
*, size_t *);
831 internal_proto(read_block_form4
);
833 extern void *write_block (st_parameter_dt
*, size_t);
834 internal_proto(write_block
);
836 extern gfc_offset
next_array_record (st_parameter_dt
*, array_loop_spec
*,
838 internal_proto(next_array_record
);
840 extern gfc_offset
init_loop_spec (gfc_array_char
*, array_loop_spec
*,
842 internal_proto(init_loop_spec
);
844 extern void next_record (st_parameter_dt
*, int);
845 internal_proto(next_record
);
847 extern void st_wait (st_parameter_wait
*);
848 export_proto (st_wait
);
850 extern void st_wait_async (st_parameter_wait
*);
851 export_proto (st_wait_async
);
853 extern void hit_eof (st_parameter_dt
*);
854 internal_proto(hit_eof
);
856 extern void transfer_array_inner (st_parameter_dt
*, gfc_array_char
*, int,
858 internal_proto (transfer_array_inner
);
862 extern void set_integer (void *, GFC_INTEGER_LARGEST
, int);
863 internal_proto(set_integer
);
865 extern GFC_UINTEGER_LARGEST
si_max (int);
866 internal_proto(si_max
);
868 extern int convert_real (st_parameter_dt
*, void *, const char *, int);
869 internal_proto(convert_real
);
871 extern int convert_infnan (st_parameter_dt
*, void *, const char *, int);
872 internal_proto(convert_infnan
);
874 extern void read_a (st_parameter_dt
*, const fnode
*, char *, size_t);
875 internal_proto(read_a
);
877 extern void read_a_char4 (st_parameter_dt
*, const fnode
*, char *, size_t);
878 internal_proto(read_a
);
880 extern void read_f (st_parameter_dt
*, const fnode
*, char *, int);
881 internal_proto(read_f
);
883 extern void read_l (st_parameter_dt
*, const fnode
*, char *, int);
884 internal_proto(read_l
);
886 extern void read_x (st_parameter_dt
*, size_t);
887 internal_proto(read_x
);
889 extern void read_radix (st_parameter_dt
*, const fnode
*, char *, int, int);
890 internal_proto(read_radix
);
892 extern void read_decimal (st_parameter_dt
*, const fnode
*, char *, int);
893 internal_proto(read_decimal
);
895 extern void read_user_defined (st_parameter_dt
*, void *);
896 internal_proto(read_user_defined
);
898 extern void read_user_defined (st_parameter_dt
*, void *);
899 internal_proto(read_user_defined
);
903 extern void list_formatted_read (st_parameter_dt
*, bt
, void *, int, size_t,
905 internal_proto(list_formatted_read
);
907 extern void finish_list_read (st_parameter_dt
*);
908 internal_proto(finish_list_read
);
910 extern void namelist_read (st_parameter_dt
*);
911 internal_proto(namelist_read
);
913 extern void namelist_write (st_parameter_dt
*);
914 internal_proto(namelist_write
);
918 extern void write_a (st_parameter_dt
*, const fnode
*, const char *, size_t);
919 internal_proto(write_a
);
921 extern void write_a_char4 (st_parameter_dt
*, const fnode
*, const char *, size_t);
922 internal_proto(write_a_char4
);
924 extern void write_b (st_parameter_dt
*, const fnode
*, const char *, int);
925 internal_proto(write_b
);
927 extern void write_d (st_parameter_dt
*, const fnode
*, const char *, int);
928 internal_proto(write_d
);
930 extern void write_e (st_parameter_dt
*, const fnode
*, const char *, int);
931 internal_proto(write_e
);
933 extern void write_en (st_parameter_dt
*, const fnode
*, const char *, int);
934 internal_proto(write_en
);
936 extern void write_es (st_parameter_dt
*, const fnode
*, const char *, int);
937 internal_proto(write_es
);
939 extern void write_f (st_parameter_dt
*, const fnode
*, const char *, int);
940 internal_proto(write_f
);
942 extern void write_i (st_parameter_dt
*, const fnode
*, const char *, int);
943 internal_proto(write_i
);
945 extern void write_l (st_parameter_dt
*, const fnode
*, char *, int);
946 internal_proto(write_l
);
948 extern void write_o (st_parameter_dt
*, const fnode
*, const char *, int);
949 internal_proto(write_o
);
951 extern void write_real (st_parameter_dt
*, const char *, int);
952 internal_proto(write_real
);
954 extern void write_real_w0 (st_parameter_dt
*, const char *, int, const fnode
*);
955 internal_proto(write_real_w0
);
957 extern void write_x (st_parameter_dt
*, int, int);
958 internal_proto(write_x
);
960 extern void write_z (st_parameter_dt
*, const fnode
*, const char *, int);
961 internal_proto(write_z
);
963 extern void write_user_defined (st_parameter_dt
*, void *);
964 internal_proto(write_user_defined
);
966 extern void write_user_defined (st_parameter_dt
*, void *);
967 internal_proto(write_user_defined
);
969 extern void list_formatted_write (st_parameter_dt
*, bt
, void *, int, size_t,
971 internal_proto(list_formatted_write
);
973 /* size_from_kind.c */
974 extern size_t size_from_real_kind (int);
975 internal_proto(size_from_real_kind
);
977 extern size_t size_from_complex_kind (int);
978 internal_proto(size_from_complex_kind
);
982 extern void free_ionml (st_parameter_dt
*);
983 internal_proto(free_ionml
);
986 inc_waiting_locked (gfc_unit
*u
)
988 #ifdef HAVE_ATOMIC_FETCH_ADD
989 (void) __atomic_fetch_add (&u
->waiting
, 1, __ATOMIC_RELAXED
);
996 predec_waiting_locked (gfc_unit
*u
)
998 #ifdef HAVE_ATOMIC_FETCH_ADD
999 /* Note that the pattern
1001 if (predec_waiting_locked (u) == 0)
1004 could be further optimized by making this be an __ATOMIC_RELEASE,
1005 and then inserting a
1007 __atomic_thread_fence (__ATOMIC_ACQUIRE);
1009 inside the branch before destroying. But for now, lets keep it
1011 return __atomic_add_fetch (&u
->waiting
, -1, __ATOMIC_ACQ_REL
);
1013 return --u
->waiting
;
1018 dec_waiting_unlocked (gfc_unit
*u
)
1020 #ifdef HAVE_ATOMIC_FETCH_ADD
1021 (void) __atomic_fetch_add (&u
->waiting
, -1, __ATOMIC_RELAXED
);
1023 #ifdef __GTHREAD_RWLOCK_INIT
1024 __gthread_rwlock_wrlock (&unit_rwlock
);
1026 __gthread_rwlock_unlock (&unit_rwlock
);
1028 __gthread_mutex_lock (&unit_rwlock
);
1030 __gthread_mutex_unlock (&unit_rwlock
);
1037 memset4 (gfc_char4_t
*p
, gfc_char4_t c
, int k
)
1040 for (j
= 0; j
< k
; j
++)
1044 /* Used in width fields to indicate that the default should be used */
1045 #define DEFAULT_WIDTH -1
1047 /* Defaults for certain format field descriptors. These are decided based on
1048 * the type of the value being formatted.
1050 * The behaviour here is modelled on the Oracle Fortran compiler. At the time
1051 * of writing, the details were available at this URL:
1053 * https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d
1057 default_width_for_integer (int kind
)
1071 default_width_for_float (int kind
)
1084 default_precision_for_float (int kind
)
1099 st_write_done_worker (st_parameter_dt
*, bool);
1100 internal_proto (st_write_done_worker
);
1103 st_read_done_worker (st_parameter_dt
*, bool);
1104 internal_proto (st_read_done_worker
);
1107 data_transfer_init_worker (st_parameter_dt
*, int);
1108 internal_proto (data_transfer_init_worker
);