| /* Copyright (C) 2002-2021 Free Software Foundation, Inc. |
| Contributed by Andy Vaught |
| F2003 I/O support contributed by Jerry DeLisle |
| |
| This file is part of the GNU Fortran runtime library (libgfortran). |
| |
| Libgfortran is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 3, or (at your option) |
| any later version. |
| |
| Libgfortran is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU General Public License for more details. |
| |
| Under Section 7 of GPL version 3, you are granted additional |
| permissions described in the GCC Runtime Library Exception, version |
| 3.1, as published by the Free Software Foundation. |
| |
| You should have received a copy of the GNU General Public License and |
| a copy of the GCC Runtime Library Exception along with this program; |
| see the files COPYING3 and COPYING.RUNTIME respectively. If not, see |
| <http://www.gnu.org/licenses/>. */ |
| |
| #ifndef GFOR_IO_H |
| #define GFOR_IO_H |
| |
| /* IO library include. */ |
| |
| #include "libgfortran.h" |
| |
| #include <gthr.h> |
| |
| #define gcc_unreachable() __builtin_unreachable () |
| |
| /* POSIX 2008 specifies that the extended locale stuff is found in |
| locale.h, but some systems have them in xlocale.h. */ |
| |
| #include <locale.h> |
| |
| #ifdef HAVE_XLOCALE_H |
| #include <xlocale.h> |
| #endif |
| |
| |
| /* Forward declarations. */ |
| struct st_parameter_dt; |
| typedef struct stream stream; |
| struct fbuf; |
| struct format_data; |
| typedef struct fnode fnode; |
| struct gfc_unit; |
| |
| #if defined (HAVE_FREELOCALE) && defined (HAVE_NEWLOCALE) \ |
| && defined (HAVE_USELOCALE) |
| /* We have POSIX 2008 extended locale stuff. We only choose to use it |
| if all the functions required are present as some systems, e.g. NetBSD |
| do not have `uselocale'. */ |
| #define HAVE_POSIX_2008_LOCALE |
| extern locale_t c_locale; |
| internal_proto(c_locale); |
| #else |
| extern char* old_locale; |
| internal_proto(old_locale); |
| extern int old_locale_ctr; |
| internal_proto(old_locale_ctr); |
| extern __gthread_mutex_t old_locale_lock; |
| internal_proto(old_locale_lock); |
| #endif |
| |
| |
| /* Macros for testing what kinds of I/O we are doing. */ |
| |
| #define is_array_io(dtp) ((dtp)->internal_unit_desc) |
| |
| #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal) |
| |
| #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM) |
| |
| #define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4) |
| |
| /* The array_loop_spec contains the variables for the loops over index ranges |
| that are encountered. */ |
| |
| typedef struct array_loop_spec |
| { |
| /* Index counter for this dimension. */ |
| index_type idx; |
| |
| /* Start for the index counter. */ |
| index_type start; |
| |
| /* End for the index counter. */ |
| index_type end; |
| |
| /* Step for the index counter. */ |
| index_type step; |
| } |
| array_loop_spec; |
| |
| /* User defined input/output iomsg length. */ |
| |
| #define IOMSG_LEN 256 |
| |
| /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat, |
| iomsg, (_iotype), (_iomsg)) */ |
| typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *, |
| gfc_full_array_i4 *, |
| GFC_INTEGER_4 *, char *, |
| gfc_charlen_type, gfc_charlen_type); |
| |
| /* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg)) */ |
| typedef void (*unformatted_dtio)(void *, GFC_INTEGER_4 *, GFC_INTEGER_4 *, |
| char *, gfc_charlen_type); |
| |
| /* The dtio calls for namelist require a CLASS object to be built. */ |
| typedef struct gfc_class |
| { |
| void *data; |
| void *vptr; |
| index_type len; |
| } |
| gfc_class; |
| |
| |
| /* A structure to build a hash table for format data. */ |
| |
| #define FORMAT_HASH_SIZE 16 |
| |
| typedef struct format_hash_entry |
| { |
| char *key; |
| gfc_charlen_type key_len; |
| struct format_data *hashed_fmt; |
| } |
| format_hash_entry; |
| |
| /* Format tokens. Only about half of these can be stored in the |
| format nodes. */ |
| |
| typedef enum |
| { |
| FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, |
| FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL, |
| FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING, |
| FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F, |
| FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC, |
| FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT |
| } |
| format_token; |
| |
| /* Representation of a namelist object in libgfortran |
| |
| Namelist Records |
| &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../ |
| or |
| &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END |
| |
| The object can be a fully qualified, compound name for an intrinsic |
| type, derived types or derived type components. So, a substring |
| a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist |
| read. Hence full information about the structure of the object has |
| to be available to list_read.c and write. |
| |
| These requirements are met by the following data structures. |
| |
| namelist_info type contains all the scalar information about the |
| object and arrays of descriptor_dimension and array_loop_spec types for |
| arrays. */ |
| |
| typedef struct namelist_type |
| { |
| /* Object type. */ |
| bt type; |
| |
| /* Object name. */ |
| char * var_name; |
| |
| /* Address for the start of the object's data. */ |
| void * mem_pos; |
| |
| /* Address of specific DTIO subroutine. */ |
| void * dtio_sub; |
| |
| /* Address of vtable if dtio_sub non-null. */ |
| void * vtable; |
| |
| /* Flag to show that a read is to be attempted for this node. */ |
| int touched; |
| |
| /* Length of intrinsic type in bytes. */ |
| int len; |
| |
| /* Rank of the object. */ |
| int var_rank; |
| |
| /* Overall size of the object in bytes. */ |
| index_type size; |
| |
| /* Length of character string. */ |
| index_type string_length; |
| |
| descriptor_dimension * dim; |
| array_loop_spec * ls; |
| struct namelist_type * next; |
| } |
| namelist_info; |
| |
| /* Options for the OPEN statement. */ |
| |
| typedef enum |
| { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM, |
| ACCESS_UNSPECIFIED |
| } |
| unit_access; |
| |
| typedef enum |
| { ACTION_READ, ACTION_WRITE, ACTION_READWRITE, |
| ACTION_UNSPECIFIED |
| } |
| unit_action; |
| |
| typedef enum |
| { BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED } |
| unit_blank; |
| |
| typedef enum |
| { DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE, |
| DELIM_UNSPECIFIED |
| } |
| unit_delim; |
| |
| typedef enum |
| { FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED } |
| unit_form; |
| |
| typedef enum |
| { POSITION_ASIS, POSITION_REWIND, POSITION_APPEND, |
| POSITION_UNSPECIFIED |
| } |
| unit_position; |
| |
| typedef enum |
| { STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH, |
| STATUS_REPLACE, STATUS_UNSPECIFIED |
| } |
| unit_status; |
| |
| typedef enum |
| { PAD_YES, PAD_NO, PAD_UNSPECIFIED } |
| unit_pad; |
| |
| typedef enum |
| { DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED } |
| unit_decimal; |
| |
| typedef enum |
| { ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED } |
| unit_encoding; |
| |
| typedef enum |
| { ROUND_UP = GFC_FPE_UPWARD, |
| ROUND_DOWN = GFC_FPE_DOWNWARD, |
| ROUND_ZERO = GFC_FPE_TOWARDZERO, |
| ROUND_NEAREST = GFC_FPE_TONEAREST, |
| ROUND_COMPATIBLE = 10, /* round away from zero. */ |
| ROUND_PROCDEFINED, /* Here as ROUND_NEAREST. */ |
| ROUND_UNSPECIFIED /* Should never occur. */ |
| } |
| unit_round; |
| |
| /* NOTE: unit_sign must correspond with the sign_status enumerator in |
| st_parameter_dt to not break the ABI. */ |
| typedef enum |
| { SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED } |
| unit_sign; |
| |
| typedef enum |
| { ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED } |
| unit_advance; |
| |
| typedef enum |
| {READING, WRITING, LIST_READING, LIST_WRITING} |
| unit_mode; |
| |
| typedef enum |
| { ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED } |
| unit_async; |
| |
| typedef enum |
| { SHARE_DENYRW, SHARE_DENYNONE, |
| SHARE_UNSPECIFIED |
| } |
| unit_share; |
| |
| typedef enum |
| { CC_LIST, CC_FORTRAN, CC_NONE, |
| CC_UNSPECIFIED |
| } |
| unit_cc; |
| |
| /* End-of-record types for CC_FORTRAN. */ |
| typedef enum |
| { CCF_DEFAULT=0x0, |
| CCF_OVERPRINT=0x1, |
| CCF_ONE_LF=0x2, |
| CCF_TWO_LF=0x4, |
| CCF_PAGE_FEED=0x8, |
| CCF_PROMPT=0x10, |
| CCF_OVERPRINT_NOA=0x20, |
| } /* 6 bits */ |
| cc_fortran; |
| |
| typedef enum |
| { SIGN_S, SIGN_SS, SIGN_SP } |
| unit_sign_s; |
| |
| /* Make sure to keep st_parameter_* in sync with gcc/fortran/ioparm.def. */ |
| |
| #define CHARACTER1(name) \ |
| char * name; \ |
| gfc_charlen_type name ## _len |
| #define CHARACTER2(name) \ |
| gfc_charlen_type name ## _len; \ |
| char * name |
| |
| typedef struct |
| { |
| st_parameter_common common; |
| GFC_IO_INT recl_in; |
| CHARACTER2 (file); |
| CHARACTER1 (status); |
| CHARACTER2 (access); |
| CHARACTER1 (form); |
| CHARACTER2 (blank); |
| CHARACTER1 (position); |
| CHARACTER2 (action); |
| CHARACTER1 (delim); |
| CHARACTER2 (pad); |
| CHARACTER1 (convert); |
| CHARACTER2 (decimal); |
| CHARACTER1 (encoding); |
| CHARACTER2 (round); |
| CHARACTER1 (sign); |
| CHARACTER2 (asynchronous); |
| GFC_INTEGER_4 *newunit; |
| GFC_INTEGER_4 readonly; |
| CHARACTER2 (cc); |
| CHARACTER1 (share); |
| } |
| st_parameter_open; |
| |
| #define IOPARM_CLOSE_HAS_STATUS (1 << 7) |
| |
| typedef struct |
| { |
| st_parameter_common common; |
| CHARACTER1 (status); |
| } |
| st_parameter_close; |
| |
| typedef struct |
| { |
| st_parameter_common common; |
| } |
| st_parameter_filepos; |
| |
| #define IOPARM_INQUIRE_HAS_EXIST (1 << 7) |
| #define IOPARM_INQUIRE_HAS_OPENED (1 << 8) |
| #define IOPARM_INQUIRE_HAS_NUMBER (1 << 9) |
| #define IOPARM_INQUIRE_HAS_NAMED (1 << 10) |
| #define IOPARM_INQUIRE_HAS_NEXTREC (1 << 11) |
| #define IOPARM_INQUIRE_HAS_RECL_OUT (1 << 12) |
| #define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 13) |
| #define IOPARM_INQUIRE_HAS_FILE (1 << 14) |
| #define IOPARM_INQUIRE_HAS_ACCESS (1 << 15) |
| #define IOPARM_INQUIRE_HAS_FORM (1 << 16) |
| #define IOPARM_INQUIRE_HAS_BLANK (1 << 17) |
| #define IOPARM_INQUIRE_HAS_POSITION (1 << 18) |
| #define IOPARM_INQUIRE_HAS_ACTION (1 << 19) |
| #define IOPARM_INQUIRE_HAS_DELIM (1 << 20) |
| #define IOPARM_INQUIRE_HAS_PAD (1 << 21) |
| #define IOPARM_INQUIRE_HAS_NAME (1 << 22) |
| #define IOPARM_INQUIRE_HAS_SEQUENTIAL (1 << 23) |
| #define IOPARM_INQUIRE_HAS_DIRECT (1 << 24) |
| #define IOPARM_INQUIRE_HAS_FORMATTED (1 << 25) |
| #define IOPARM_INQUIRE_HAS_UNFORMATTED (1 << 26) |
| #define IOPARM_INQUIRE_HAS_READ (1 << 27) |
| #define IOPARM_INQUIRE_HAS_WRITE (1 << 28) |
| #define IOPARM_INQUIRE_HAS_READWRITE (1 << 29) |
| #define IOPARM_INQUIRE_HAS_CONVERT (1 << 30) |
| #define IOPARM_INQUIRE_HAS_FLAGS2 (1u << 31) |
| |
| #define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0) |
| #define IOPARM_INQUIRE_HAS_DECIMAL (1 << 1) |
| #define IOPARM_INQUIRE_HAS_ENCODING (1 << 2) |
| #define IOPARM_INQUIRE_HAS_ROUND (1 << 3) |
| #define IOPARM_INQUIRE_HAS_SIGN (1 << 4) |
| #define IOPARM_INQUIRE_HAS_PENDING (1 << 5) |
| #define IOPARM_INQUIRE_HAS_SIZE (1 << 6) |
| #define IOPARM_INQUIRE_HAS_ID (1 << 7) |
| #define IOPARM_INQUIRE_HAS_IQSTREAM (1 << 8) |
| #define IOPARM_INQUIRE_HAS_SHARE (1 << 9) |
| #define IOPARM_INQUIRE_HAS_CC (1 << 10) |
| |
| typedef struct |
| { |
| st_parameter_common common; |
| GFC_INTEGER_4 *exist, *opened, *number, *named; |
| GFC_IO_INT *nextrec, *recl_out, *strm_pos_out; |
| CHARACTER1 (file); |
| CHARACTER2 (access); |
| CHARACTER1 (form); |
| CHARACTER2 (blank); |
| CHARACTER1 (position); |
| CHARACTER2 (action); |
| CHARACTER1 (delim); |
| CHARACTER2 (pad); |
| CHARACTER1 (name); |
| CHARACTER2 (sequential); |
| CHARACTER1 (direct); |
| CHARACTER2 (formatted); |
| CHARACTER1 (unformatted); |
| CHARACTER2 (read); |
| CHARACTER1 (write); |
| CHARACTER2 (readwrite); |
| CHARACTER1 (convert); |
| GFC_INTEGER_4 flags2; |
| CHARACTER1 (asynchronous); |
| CHARACTER2 (decimal); |
| CHARACTER1 (encoding); |
| CHARACTER2 (round); |
| CHARACTER1 (sign); |
| GFC_INTEGER_4 *pending; |
| GFC_IO_INT *size; |
| GFC_INTEGER_4 *id; |
| CHARACTER1 (iqstream); |
| CHARACTER2 (share); |
| CHARACTER1 (cc); |
| } |
| st_parameter_inquire; |
| |
| |
| #define IOPARM_DT_LIST_FORMAT (1 << 7) |
| #define IOPARM_DT_NAMELIST_READ_MODE (1 << 8) |
| #define IOPARM_DT_HAS_REC (1 << 9) |
| #define IOPARM_DT_HAS_SIZE (1 << 10) |
| #define IOPARM_DT_HAS_IOLENGTH (1 << 11) |
| #define IOPARM_DT_HAS_FORMAT (1 << 12) |
| #define IOPARM_DT_HAS_ADVANCE (1 << 13) |
| #define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14) |
| #define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15) |
| #define IOPARM_DT_HAS_ID (1 << 16) |
| #define IOPARM_DT_HAS_POS (1 << 17) |
| #define IOPARM_DT_HAS_ASYNCHRONOUS (1 << 18) |
| #define IOPARM_DT_HAS_BLANK (1 << 19) |
| #define IOPARM_DT_HAS_DECIMAL (1 << 20) |
| #define IOPARM_DT_HAS_DELIM (1 << 21) |
| #define IOPARM_DT_HAS_PAD (1 << 22) |
| #define IOPARM_DT_HAS_ROUND (1 << 23) |
| #define IOPARM_DT_HAS_SIGN (1 << 24) |
| #define IOPARM_DT_HAS_F2003 (1 << 25) |
| #define IOPARM_DT_HAS_UDTIO (1 << 26) |
| #define IOPARM_DT_DEC_EXT (1 << 27) |
| /* Internal use bit. */ |
| #define IOPARM_DT_IONML_SET (1u << 31) |
| |
| |
| typedef struct st_parameter_dt |
| { |
| st_parameter_common common; |
| GFC_IO_INT rec; |
| GFC_IO_INT *size, *iolength; |
| gfc_array_char *internal_unit_desc; |
| CHARACTER1 (format); |
| CHARACTER2 (advance); |
| CHARACTER1 (internal_unit); |
| CHARACTER2 (namelist_name); |
| GFC_INTEGER_4 *id; |
| GFC_IO_INT pos; |
| CHARACTER1 (asynchronous); |
| CHARACTER2 (blank); |
| CHARACTER1 (decimal); |
| CHARACTER2 (delim); |
| CHARACTER1 (pad); |
| CHARACTER2 (round); |
| CHARACTER1 (sign); |
| /* Private part of the structure. The compiler just needs |
| to reserve enough space. */ |
| union |
| { |
| struct |
| { |
| void (*transfer) (struct st_parameter_dt *, bt, void *, int, |
| size_t, size_t); |
| struct gfc_unit *current_unit; |
| /* Item number in a formatted data transfer. Also used in namelist |
| read_logical as an index into line_buffer. */ |
| int item_count; |
| unit_mode mode; |
| unit_blank blank_status; |
| unit_sign sign_status; |
| int scale_factor; |
| /* Maximum righthand column written to. */ |
| int max_pos; |
| /* Number of skips + spaces to be done for T and X-editing. */ |
| int skips; |
| /* Number of spaces to be done for T and X-editing. */ |
| int pending_spaces; |
| /* Whether an EOR condition was encountered. Value is: |
| 0 if no EOR was encountered |
| 1 if an EOR was encountered due to a 1-byte marker (LF) |
| 2 if an EOR was encountered due to a 2-bytes marker (CRLF) */ |
| int sf_seen_eor; |
| unit_advance advance_status; |
| unsigned reversion_flag : 1; /* Format reversion has occurred. */ |
| unsigned first_item : 1; |
| unsigned seen_dollar : 1; |
| unsigned eor_condition : 1; |
| unsigned no_leading_blank : 1; |
| unsigned char_flag : 1; |
| unsigned input_complete : 1; |
| unsigned at_eol : 1; |
| unsigned comma_flag : 1; |
| /* A namelist specific flag used in the list directed library |
| to flag that calls are being made from namelist read (e.g. to |
| ignore comments or to treat '/' as a terminator) */ |
| unsigned namelist_mode : 1; |
| /* A namelist specific flag used in the list directed library |
| to flag read errors and return, so that an attempt can be |
| made to read a new object name. */ |
| unsigned nml_read_error : 1; |
| /* A sequential formatted read specific flag used to signal that a |
| character string is being read so don't use commas to shorten a |
| formatted field width. */ |
| unsigned sf_read_comma : 1; |
| /* A namelist specific flag used to enable reading input from |
| line_buffer for logical reads. */ |
| unsigned line_buffer_enabled : 1; |
| /* An internal unit specific flag used to identify that the associated |
| unit is internal. */ |
| unsigned unit_is_internal : 1; |
| /* An internal unit specific flag to signify an EOF condition for list |
| directed read. */ |
| unsigned at_eof : 1; |
| /* Used for g0 floating point output. */ |
| unsigned g0_no_blanks : 1; |
| /* Used to signal use of free_format_data. */ |
| unsigned format_not_saved : 1; |
| /* A flag used to identify when a non-standard expanded namelist read |
| has occurred. */ |
| unsigned expanded_read : 1; |
| /* Flag to indicate if the statement has async="YES". */ |
| unsigned async : 1; |
| /* 12 unused bits. */ |
| |
| int child_saved_iostat; |
| int nml_delim; |
| int repeat_count; |
| int saved_length; |
| int saved_used; |
| bt saved_type; |
| char *saved_string; |
| char *scratch; |
| char *line_buffer; |
| struct format_data *fmt; |
| namelist_info *ionml; |
| #ifdef HAVE_POSIX_2008_LOCALE |
| locale_t old_locale; |
| #endif |
| /* Current position within the look-ahead line buffer. */ |
| int line_buffer_pos; |
| /* Storage area for values except for strings. Must be |
| large enough to hold a complex value (two reals) of the |
| largest kind. */ |
| char value[32]; |
| GFC_IO_INT not_used; /* Needed for alignment. */ |
| formatted_dtio fdtio_ptr; |
| unformatted_dtio ufdtio_ptr; |
| /* With CC_FORTRAN, the first character of a record determines the |
| style of record end (and start) to use. We must mark down the type |
| when we write first in write_a so we remember the end type later in |
| next_record_w. */ |
| struct |
| { |
| unsigned type : 6; /* See enum cc_fortran. */ |
| unsigned len : 2; /* Always 0, 1, or 2. */ |
| /* The union is updated after start-of-record is written. */ |
| union |
| { |
| char start; /* Output character for start of record. */ |
| char end; /* Output character for end of record. */ |
| } u; |
| } cc; |
| } p; |
| /* This pad size must be equal to the pad_size declared in |
| trans-io.c (gfc_build_io_library_fndecls). The above structure |
| must be smaller or equal to this array. */ |
| char pad[16 * sizeof (char *) + 32 * sizeof (int)]; |
| } u; |
| } |
| st_parameter_dt; |
| |
| /* Ensure st_parameter_dt's u.pad is bigger or equal to u.p. */ |
| extern char check_st_parameter_dt[sizeof (((st_parameter_dt *) 0)->u.pad) |
| >= sizeof (((st_parameter_dt *) 0)->u.p) |
| ? 1 : -1]; |
| |
| #define IOPARM_WAIT_HAS_ID (1 << 7) |
| |
| typedef struct |
| { |
| st_parameter_common common; |
| GFC_INTEGER_4 *id; |
| } |
| st_parameter_wait; |
| |
| |
| #undef CHARACTER1 |
| #undef CHARACTER2 |
| |
| typedef struct |
| { |
| unit_access access; |
| unit_action action; |
| unit_blank blank; |
| unit_delim delim; |
| unit_form form; |
| int is_notpadded; |
| unit_position position; |
| unit_status status; |
| unit_pad pad; |
| unit_convert convert; |
| int has_recl; |
| unit_decimal decimal; |
| unit_encoding encoding; |
| unit_round round; |
| unit_sign sign; |
| unit_async async; |
| unit_share share; |
| unit_cc cc; |
| int readonly; |
| } |
| unit_flags; |
| |
| |
| typedef struct gfc_unit |
| { |
| int unit_number; |
| stream *s; |
| |
| /* Treap links. */ |
| struct gfc_unit *left, *right; |
| int priority; |
| |
| int read_bad, current_record, saved_pos, previous_nonadvancing_write; |
| |
| enum |
| { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE } |
| endfile; |
| |
| unit_mode mode; |
| unit_flags flags; |
| unit_pad pad_status; |
| unit_decimal decimal_status; |
| unit_delim delim_status; |
| unit_round round_status; |
| |
| /* recl -- Record length of the file. |
| last_record -- Last record number read or written |
| maxrec -- Maximum record number in a direct access file |
| bytes_left -- Bytes left in current record. |
| strm_pos -- Current position in file for STREAM I/O. |
| recl_subrecord -- Maximum length for subrecord. |
| bytes_left_subrecord -- Bytes left in current subrecord. */ |
| gfc_offset recl, last_record, maxrec, bytes_left, strm_pos, |
| recl_subrecord, bytes_left_subrecord; |
| |
| /* Set to 1 if we have read a subrecord. */ |
| |
| int continued; |
| |
| /* Contains the pointer to the async unit. */ |
| struct async_unit *au; |
| |
| __gthread_mutex_t lock; |
| /* Number of threads waiting to acquire this unit's lock. |
| When non-zero, close_unit doesn't only removes the unit |
| from the UNIT_ROOT tree, but doesn't free it and the |
| last of the waiting threads will do that. |
| This must be either atomically increased/decreased, or |
| always guarded by UNIT_LOCK. */ |
| int waiting; |
| /* Flag set by close_unit if the unit as been closed. |
| Must be manipulated under unit's lock. */ |
| int closed; |
| |
| /* For traversing arrays */ |
| array_loop_spec *ls; |
| int rank; |
| |
| /* Name of the file at the time OPEN was executed, as a |
| null-terminated C string. */ |
| char *filename; |
| |
| /* The format hash table. */ |
| struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE]; |
| |
| /* Formatting buffer. */ |
| struct fbuf *fbuf; |
| |
| /* Function pointer, points to list_read worker functions. */ |
| int (*next_char_fn_ptr) (st_parameter_dt *); |
| void (*push_char_fn_ptr) (st_parameter_dt *, int); |
| |
| /* Internal unit char string data. */ |
| char * internal_unit; |
| gfc_charlen_type internal_unit_len; |
| gfc_array_char *string_unit_desc; |
| int internal_unit_kind; |
| |
| /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */ |
| int child_dtio; |
| |
| /* Used for ungetc() style functionality. Possible values |
| are an unsigned char, EOF, or EOF - 1 used to mark the |
| field as not valid. */ |
| int last_char; |
| bool has_size; |
| GFC_IO_INT size_used; |
| } |
| gfc_unit; |
| |
| typedef struct gfc_saved_unit |
| { |
| GFC_INTEGER_4 unit_number; |
| gfc_unit *unit; |
| } |
| gfc_saved_unit; |
| |
| /* TEMP_FAILURE_RETRY macro from glibc. */ |
| |
| #ifndef TEMP_FAILURE_RETRY |
| /* Evaluate EXPRESSION, and repeat as long as it returns -1 with `errno' |
| set to EINTR. */ |
| |
| # define TEMP_FAILURE_RETRY(expression) \ |
| (__extension__ \ |
| ({ long int __result; \ |
| do __result = (long int) (expression); \ |
| while (__result == -1L && errno == EINTR); \ |
| __result; })) |
| #endif |
| |
| |
| /* unit.c */ |
| |
| /* Maximum file offset, computed at library initialization time. */ |
| extern gfc_offset max_offset; |
| internal_proto(max_offset); |
| |
| /* Default RECL for sequential access if not given in OPEN statement, |
| computed at library initialization time. */ |
| extern gfc_offset default_recl; |
| internal_proto(default_recl); |
| |
| /* Unit tree root. */ |
| extern gfc_unit *unit_root; |
| internal_proto(unit_root); |
| |
| extern __gthread_mutex_t unit_lock; |
| internal_proto(unit_lock); |
| |
| extern int close_unit (gfc_unit *); |
| internal_proto(close_unit); |
| |
| extern gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int); |
| internal_proto(set_internal_unit); |
| |
| extern void stash_internal_unit (st_parameter_dt *); |
| internal_proto(stash_internal_unit); |
| |
| extern gfc_unit *find_unit (int); |
| internal_proto(find_unit); |
| |
| extern gfc_unit *find_or_create_unit (int); |
| internal_proto(find_or_create_unit); |
| |
| extern gfc_unit *get_unit (st_parameter_dt *, int); |
| internal_proto(get_unit); |
| |
| extern void unlock_unit(gfc_unit *); |
| internal_proto(unlock_unit); |
| |
| extern void finish_last_advance_record (gfc_unit *u); |
| internal_proto(finish_last_advance_record); |
| |
| extern int unit_truncate(gfc_unit *, gfc_offset, st_parameter_common *); |
| internal_proto(unit_truncate); |
| |
| extern int newunit_alloc (void); |
| internal_proto(newunit_alloc); |
| |
| extern void newunit_free (int); |
| internal_proto(newunit_free); |
| |
| |
| /* open.c */ |
| |
| extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *); |
| internal_proto(new_unit); |
| |
| |
| /* transfer.c */ |
| |
| #define SCRATCH_SIZE 300 |
| |
| extern const char *type_name (bt); |
| internal_proto(type_name); |
| |
| extern void * read_block_form (st_parameter_dt *, size_t *); |
| internal_proto(read_block_form); |
| |
| extern void * read_block_form4 (st_parameter_dt *, size_t *); |
| internal_proto(read_block_form4); |
| |
| extern void *write_block (st_parameter_dt *, size_t); |
| internal_proto(write_block); |
| |
| extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *, |
| int*); |
| internal_proto(next_array_record); |
| |
| extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *, |
| gfc_offset *); |
| internal_proto(init_loop_spec); |
| |
| extern void next_record (st_parameter_dt *, int); |
| internal_proto(next_record); |
| |
| extern void st_wait (st_parameter_wait *); |
| export_proto (st_wait); |
| |
| extern void st_wait_async (st_parameter_wait *); |
| export_proto (st_wait_async); |
| |
| extern void hit_eof (st_parameter_dt *); |
| internal_proto(hit_eof); |
| |
| extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int, |
| gfc_charlen_type); |
| internal_proto (transfer_array_inner); |
| |
| /* read.c */ |
| |
| extern void set_integer (void *, GFC_INTEGER_LARGEST, int); |
| internal_proto(set_integer); |
| |
| extern GFC_UINTEGER_LARGEST si_max (int); |
| internal_proto(si_max); |
| |
| extern int convert_real (st_parameter_dt *, void *, const char *, int); |
| internal_proto(convert_real); |
| |
| extern int convert_infnan (st_parameter_dt *, void *, const char *, int); |
| internal_proto(convert_infnan); |
| |
| extern void read_a (st_parameter_dt *, const fnode *, char *, size_t); |
| internal_proto(read_a); |
| |
| extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, size_t); |
| internal_proto(read_a); |
| |
| extern void read_f (st_parameter_dt *, const fnode *, char *, int); |
| internal_proto(read_f); |
| |
| extern void read_l (st_parameter_dt *, const fnode *, char *, int); |
| internal_proto(read_l); |
| |
| extern void read_x (st_parameter_dt *, size_t); |
| internal_proto(read_x); |
| |
| extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int); |
| internal_proto(read_radix); |
| |
| extern void read_decimal (st_parameter_dt *, const fnode *, char *, int); |
| internal_proto(read_decimal); |
| |
| extern void read_user_defined (st_parameter_dt *, void *); |
| internal_proto(read_user_defined); |
| |
| extern void read_user_defined (st_parameter_dt *, void *); |
| internal_proto(read_user_defined); |
| |
| /* list_read.c */ |
| |
| extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t, |
| size_t); |
| internal_proto(list_formatted_read); |
| |
| extern void finish_list_read (st_parameter_dt *); |
| internal_proto(finish_list_read); |
| |
| extern void namelist_read (st_parameter_dt *); |
| internal_proto(namelist_read); |
| |
| extern void namelist_write (st_parameter_dt *); |
| internal_proto(namelist_write); |
| |
| /* write.c */ |
| |
| extern void write_a (st_parameter_dt *, const fnode *, const char *, size_t); |
| internal_proto(write_a); |
| |
| extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, size_t); |
| internal_proto(write_a_char4); |
| |
| extern void write_b (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_b); |
| |
| extern void write_d (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_d); |
| |
| extern void write_e (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_e); |
| |
| extern void write_en (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_en); |
| |
| extern void write_es (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_es); |
| |
| extern void write_f (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_f); |
| |
| extern void write_i (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_i); |
| |
| extern void write_l (st_parameter_dt *, const fnode *, char *, int); |
| internal_proto(write_l); |
| |
| extern void write_o (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_o); |
| |
| extern void write_real (st_parameter_dt *, const char *, int); |
| internal_proto(write_real); |
| |
| extern void write_real_w0 (st_parameter_dt *, const char *, int, const fnode*); |
| internal_proto(write_real_w0); |
| |
| extern void write_x (st_parameter_dt *, int, int); |
| internal_proto(write_x); |
| |
| extern void write_z (st_parameter_dt *, const fnode *, const char *, int); |
| internal_proto(write_z); |
| |
| extern void write_user_defined (st_parameter_dt *, void *); |
| internal_proto(write_user_defined); |
| |
| extern void write_user_defined (st_parameter_dt *, void *); |
| internal_proto(write_user_defined); |
| |
| extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t, |
| size_t); |
| internal_proto(list_formatted_write); |
| |
| /* size_from_kind.c */ |
| extern size_t size_from_real_kind (int); |
| internal_proto(size_from_real_kind); |
| |
| extern size_t size_from_complex_kind (int); |
| internal_proto(size_from_complex_kind); |
| |
| |
| /* lock.c */ |
| extern void free_ionml (st_parameter_dt *); |
| internal_proto(free_ionml); |
| |
| static inline void |
| inc_waiting_locked (gfc_unit *u) |
| { |
| #ifdef HAVE_ATOMIC_FETCH_ADD |
| (void) __atomic_fetch_add (&u->waiting, 1, __ATOMIC_RELAXED); |
| #else |
| u->waiting++; |
| #endif |
| } |
| |
| static inline int |
| predec_waiting_locked (gfc_unit *u) |
| { |
| #ifdef HAVE_ATOMIC_FETCH_ADD |
| /* Note that the pattern |
| |
| if (predec_waiting_locked (u) == 0) |
| // destroy u |
| |
| could be further optimized by making this be an __ATOMIC_RELEASE, |
| and then inserting a |
| |
| __atomic_thread_fence (__ATOMIC_ACQUIRE); |
| |
| inside the branch before destroying. But for now, lets keep it |
| simple. */ |
| return __atomic_add_fetch (&u->waiting, -1, __ATOMIC_ACQ_REL); |
| #else |
| return --u->waiting; |
| #endif |
| } |
| |
| static inline void |
| dec_waiting_unlocked (gfc_unit *u) |
| { |
| #ifdef HAVE_ATOMIC_FETCH_ADD |
| (void) __atomic_fetch_add (&u->waiting, -1, __ATOMIC_RELAXED); |
| #else |
| __gthread_mutex_lock (&unit_lock); |
| u->waiting--; |
| __gthread_mutex_unlock (&unit_lock); |
| #endif |
| } |
| |
| |
| static inline void |
| memset4 (gfc_char4_t *p, gfc_char4_t c, int k) |
| { |
| int j; |
| for (j = 0; j < k; j++) |
| *p++ = c; |
| } |
| |
| /* Used in width fields to indicate that the default should be used */ |
| #define DEFAULT_WIDTH -1 |
| |
| /* Defaults for certain format field descriptors. These are decided based on |
| * the type of the value being formatted. |
| * |
| * The behaviour here is modelled on the Oracle Fortran compiler. At the time |
| * of writing, the details were available at this URL: |
| * |
| * https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d |
| */ |
| |
| static inline int |
| default_width_for_integer (int kind) |
| { |
| switch (kind) |
| { |
| case 1: |
| case 2: return 7; |
| case 4: return 12; |
| case 8: return 23; |
| case 16: return 44; |
| default: return 0; |
| } |
| } |
| |
| static inline int |
| default_width_for_float (int kind) |
| { |
| switch (kind) |
| { |
| case 4: return 15; |
| case 8: return 25; |
| case 16: return 42; |
| default: return 0; |
| } |
| } |
| |
| static inline int |
| default_precision_for_float (int kind) |
| { |
| switch (kind) |
| { |
| case 4: return 7; |
| case 8: return 16; |
| case 16: return 33; |
| default: return 0; |
| } |
| } |
| |
| #endif |
| |
| extern void |
| st_write_done_worker (st_parameter_dt *, bool); |
| internal_proto (st_write_done_worker); |
| |
| extern void |
| st_read_done_worker (st_parameter_dt *, bool); |
| internal_proto (st_read_done_worker); |
| |
| extern void |
| data_transfer_init_worker (st_parameter_dt *, int); |
| internal_proto (data_transfer_init_worker); |