1/* Copyright (C) 2002-2022 Free Software Foundation, Inc. 2 Contributed by Andy Vaught 3 F2003 I/O support contributed by Jerry DeLisle 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 3, or (at your option) 10any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see 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. */ 48struct st_parameter_dt; 49typedef struct stream stream; 50struct fbuf; 51struct format_data; 52typedef struct fnode fnode; 53struct 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 61extern locale_t c_locale; 62internal_proto(c_locale); 63#else 64extern char* old_locale; 65internal_proto(old_locale); 66extern int old_locale_ctr; 67internal_proto(old_locale_ctr); 68extern __gthread_mutex_t old_locale_lock; 69internal_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 86typedef 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} 100array_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)) */ 108typedef 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)) */ 114typedef 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. */ 118typedef struct gfc_class 119{ 120 void *data; 121 void *vptr; 122 index_type len; 123} 124gfc_class; 125 126 127/* A structure to build a hash table for format data. */ 128 129#define FORMAT_HASH_SIZE 16 130 131typedef struct format_hash_entry 132{ 133 char *key; 134 gfc_charlen_type key_len; 135 struct format_data *hashed_fmt; 136} 137format_hash_entry; 138 139/* Format tokens. Only about half of these can be stored in the 140 format nodes. */ 141 142typedef 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} 151format_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 172typedef 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} 208namelist_info; 209 210/* Options for the OPEN statement. */ 211 212typedef enum 213{ ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM, 214 ACCESS_UNSPECIFIED 215} 216unit_access; 217 218typedef enum 219{ ACTION_READ, ACTION_WRITE, ACTION_READWRITE, 220 ACTION_UNSPECIFIED 221} 222unit_action; 223 224typedef enum 225{ BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED } 226unit_blank; 227 228typedef enum 229{ DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE, 230 DELIM_UNSPECIFIED 231} 232unit_delim; 233 234typedef enum 235{ FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED } 236unit_form; 237 238typedef enum 239{ POSITION_ASIS, POSITION_REWIND, POSITION_APPEND, 240 POSITION_UNSPECIFIED 241} 242unit_position; 243 244typedef enum 245{ STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH, 246 STATUS_REPLACE, STATUS_UNSPECIFIED 247} 248unit_status; 249 250typedef enum 251{ PAD_YES, PAD_NO, PAD_UNSPECIFIED } 252unit_pad; 253 254typedef enum 255{ DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED } 256unit_decimal; 257 258typedef enum 259{ ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED } 260unit_encoding; 261 262typedef 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} 271unit_round; 272 273/* NOTE: unit_sign must correspond with the sign_status enumerator in 274 st_parameter_dt to not break the ABI. */ 275typedef enum 276{ SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED } 277unit_sign; 278 279typedef enum 280{ ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED } 281unit_advance; 282 283typedef enum 284{READING, WRITING, LIST_READING, LIST_WRITING} 285unit_mode; 286 287typedef enum 288{ ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED } 289unit_async; 290 291typedef enum 292{ SHARE_DENYRW, SHARE_DENYNONE, 293 SHARE_UNSPECIFIED 294} 295unit_share; 296 297typedef enum 298{ CC_LIST, CC_FORTRAN, CC_NONE, 299 CC_UNSPECIFIED 300} 301unit_cc; 302 303/* End-of-record types for CC_FORTRAN. */ 304typedef 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 */ 313cc_fortran; 314 315typedef enum 316{ SIGN_S, SIGN_SS, SIGN_SP } 317unit_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 328typedef 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} 352st_parameter_open; 353 354#define IOPARM_CLOSE_HAS_STATUS (1 << 7) 355 356typedef struct 357{ 358 st_parameter_common common; 359 CHARACTER1 (status); 360} 361st_parameter_close; 362 363typedef struct 364{ 365 st_parameter_common common; 366} 367st_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 407typedef 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} 442st_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 470typedef 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} 603st_parameter_dt; 604 605/* Ensure st_parameter_dt's u.pad is bigger or equal to u.p. */ 606extern 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 612typedef struct 613{ 614 st_parameter_common common; 615 GFC_INTEGER_4 *id; 616} 617st_parameter_wait; 618 619 620#undef CHARACTER1 621#undef CHARACTER2 622 623typedef 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} 645unit_flags; 646 647 648typedef 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} 733gfc_unit; 734 735typedef struct gfc_saved_unit 736{ 737 GFC_INTEGER_4 unit_number; 738 gfc_unit *unit; 739} 740gfc_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. */ 760extern gfc_offset max_offset; 761internal_proto(max_offset); 762 763/* Default RECL for sequential access if not given in OPEN statement, 764 computed at library initialization time. */ 765extern gfc_offset default_recl; 766internal_proto(default_recl); 767 768/* Unit tree root. */ 769extern gfc_unit *unit_root; 770internal_proto(unit_root); 771 772extern __gthread_mutex_t unit_lock; 773internal_proto(unit_lock); 774 775extern int close_unit (gfc_unit *); 776internal_proto(close_unit); 777 778extern gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int); 779internal_proto(set_internal_unit); 780 781extern void stash_internal_unit (st_parameter_dt *); 782internal_proto(stash_internal_unit); 783 784extern gfc_unit *find_unit (int); 785internal_proto(find_unit); 786 787extern gfc_unit *find_or_create_unit (int); 788internal_proto(find_or_create_unit); 789 790extern gfc_unit *get_unit (st_parameter_dt *, int); 791internal_proto(get_unit); 792 793extern void unlock_unit(gfc_unit *); 794internal_proto(unlock_unit); 795 796extern void finish_last_advance_record (gfc_unit *u); 797internal_proto(finish_last_advance_record); 798 799extern int unit_truncate(gfc_unit *, gfc_offset, st_parameter_common *); 800internal_proto(unit_truncate); 801 802extern int newunit_alloc (void); 803internal_proto(newunit_alloc); 804 805extern void newunit_free (int); 806internal_proto(newunit_free); 807 808 809/* open.c */ 810 811extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *); 812internal_proto(new_unit); 813 814 815/* transfer.c */ 816 817#define SCRATCH_SIZE 300 818 819extern const char *type_name (bt); 820internal_proto(type_name); 821 822extern void * read_block_form (st_parameter_dt *, size_t *); 823internal_proto(read_block_form); 824 825extern void * read_block_form4 (st_parameter_dt *, size_t *); 826internal_proto(read_block_form4); 827 828extern void *write_block (st_parameter_dt *, size_t); 829internal_proto(write_block); 830 831extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *, 832 int*); 833internal_proto(next_array_record); 834 835extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *, 836 gfc_offset *); 837internal_proto(init_loop_spec); 838 839extern void next_record (st_parameter_dt *, int); 840internal_proto(next_record); 841 842extern void st_wait (st_parameter_wait *); 843export_proto (st_wait); 844 845extern void st_wait_async (st_parameter_wait *); 846export_proto (st_wait_async); 847 848extern void hit_eof (st_parameter_dt *); 849internal_proto(hit_eof); 850 851extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int, 852 gfc_charlen_type); 853internal_proto (transfer_array_inner); 854 855/* read.c */ 856 857extern void set_integer (void *, GFC_INTEGER_LARGEST, int); 858internal_proto(set_integer); 859 860extern GFC_UINTEGER_LARGEST si_max (int); 861internal_proto(si_max); 862 863extern int convert_real (st_parameter_dt *, void *, const char *, int); 864internal_proto(convert_real); 865 866extern int convert_infnan (st_parameter_dt *, void *, const char *, int); 867internal_proto(convert_infnan); 868 869extern void read_a (st_parameter_dt *, const fnode *, char *, size_t); 870internal_proto(read_a); 871 872extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, size_t); 873internal_proto(read_a); 874 875extern void read_f (st_parameter_dt *, const fnode *, char *, int); 876internal_proto(read_f); 877 878extern void read_l (st_parameter_dt *, const fnode *, char *, int); 879internal_proto(read_l); 880 881extern void read_x (st_parameter_dt *, size_t); 882internal_proto(read_x); 883 884extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int); 885internal_proto(read_radix); 886 887extern void read_decimal (st_parameter_dt *, const fnode *, char *, int); 888internal_proto(read_decimal); 889 890extern void read_user_defined (st_parameter_dt *, void *); 891internal_proto(read_user_defined); 892 893extern void read_user_defined (st_parameter_dt *, void *); 894internal_proto(read_user_defined); 895 896/* list_read.c */ 897 898extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t, 899 size_t); 900internal_proto(list_formatted_read); 901 902extern void finish_list_read (st_parameter_dt *); 903internal_proto(finish_list_read); 904 905extern void namelist_read (st_parameter_dt *); 906internal_proto(namelist_read); 907 908extern void namelist_write (st_parameter_dt *); 909internal_proto(namelist_write); 910 911/* write.c */ 912 913extern void write_a (st_parameter_dt *, const fnode *, const char *, size_t); 914internal_proto(write_a); 915 916extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, size_t); 917internal_proto(write_a_char4); 918 919extern void write_b (st_parameter_dt *, const fnode *, const char *, int); 920internal_proto(write_b); 921 922extern void write_d (st_parameter_dt *, const fnode *, const char *, int); 923internal_proto(write_d); 924 925extern void write_e (st_parameter_dt *, const fnode *, const char *, int); 926internal_proto(write_e); 927 928extern void write_en (st_parameter_dt *, const fnode *, const char *, int); 929internal_proto(write_en); 930 931extern void write_es (st_parameter_dt *, const fnode *, const char *, int); 932internal_proto(write_es); 933 934extern void write_f (st_parameter_dt *, const fnode *, const char *, int); 935internal_proto(write_f); 936 937extern void write_i (st_parameter_dt *, const fnode *, const char *, int); 938internal_proto(write_i); 939 940extern void write_l (st_parameter_dt *, const fnode *, char *, int); 941internal_proto(write_l); 942 943extern void write_o (st_parameter_dt *, const fnode *, const char *, int); 944internal_proto(write_o); 945 946extern void write_real (st_parameter_dt *, const char *, int); 947internal_proto(write_real); 948 949extern void write_real_w0 (st_parameter_dt *, const char *, int, const fnode*); 950internal_proto(write_real_w0); 951 952extern void write_x (st_parameter_dt *, int, int); 953internal_proto(write_x); 954 955extern void write_z (st_parameter_dt *, const fnode *, const char *, int); 956internal_proto(write_z); 957 958extern void write_user_defined (st_parameter_dt *, void *); 959internal_proto(write_user_defined); 960 961extern void write_user_defined (st_parameter_dt *, void *); 962internal_proto(write_user_defined); 963 964extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t, 965 size_t); 966internal_proto(list_formatted_write); 967 968/* size_from_kind.c */ 969extern size_t size_from_real_kind (int); 970internal_proto(size_from_real_kind); 971 972extern size_t size_from_complex_kind (int); 973internal_proto(size_from_complex_kind); 974 975 976/* lock.c */ 977extern void free_ionml (st_parameter_dt *); 978internal_proto(free_ionml); 979 980static inline void 981inc_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 990static inline int 991predec_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 1012static inline void 1013dec_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 1025static inline void 1026memset4 (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 1045static inline int 1046default_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 1059static inline int 1060default_width_for_float (int kind) 1061{ 1062 switch (kind) 1063 { 1064 case 4: return 15; 1065 case 8: return 25; 1066 case 16: 1067 case 17: return 42; 1068 default: return 0; 1069 } 1070} 1071 1072static inline int 1073default_precision_for_float (int kind) 1074{ 1075 switch (kind) 1076 { 1077 case 4: return 7; 1078 case 8: return 16; 1079 case 16: 1080 case 17: return 33; 1081 default: return 0; 1082 } 1083} 1084 1085#endif 1086 1087extern void 1088st_write_done_worker (st_parameter_dt *, bool); 1089internal_proto (st_write_done_worker); 1090 1091extern void 1092st_read_done_worker (st_parameter_dt *, bool); 1093internal_proto (st_read_done_worker); 1094 1095extern void 1096data_transfer_init_worker (st_parameter_dt *, int); 1097internal_proto (data_transfer_init_worker); 1098