libgfortran/io/io.h

   1 /* Copyright (C) 2002-2024 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    F2003 I/O support contributed by Jerry DeLisle
   4
   5 This file is part of the GNU Fortran runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 3, or (at your option)
  10 any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #ifndef GFOR_IO_H
  27 #define GFOR_IO_H
  28
  29 /* IO library include.  */
  30
  31 #include "libgfortran.h"
  32
  33 #include <gthr.h>
  34
  35 #define gcc_unreachable() __builtin_unreachable ()
  36
  37 /* Used for building error message strings.  */
  38 #define IOMSG_LEN 256
  39
  40 /* POSIX 2008 specifies that the extended locale stuff is found in
  41    locale.h, but some systems have them in xlocale.h.  */
  42
  43 #include <locale.h>
  44
  45 #ifdef HAVE_XLOCALE_H
  46 #include <xlocale.h>
  47 #endif
  48
  49
  50 /* Forward declarations.  */
  51 struct st_parameter_dt;
  52 typedef struct stream stream;
  53 struct fbuf;
  54 struct format_data;
  55 typedef struct fnode fnode;
  56 struct gfc_unit;
  57
  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);
  66 #else
  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);
  73 #endif
  74
  75
  76 /* Macros for testing what kinds of I/O we are doing.  */
  77
  78 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
  79
  80 #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
  81
  82 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
  83
  84 #define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4)
  85
  86 /* The array_loop_spec contains the variables for the loops over index ranges
  87    that are encountered.  */
  88
  89 typedef struct array_loop_spec
  90 {
  91   /* Index counter for this dimension.  */
  92   index_type idx;
  93
  94   /* Start for the index counter.  */
  95   index_type start;
  96
  97   /* End for the index counter.  */
  98   index_type end;
  99
 100   /* Step for the index counter.  */
 101   index_type step;
 102 }
 103 array_loop_spec;
 104
 105 /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
 106                               iomsg, (_iotype), (_iomsg))  */
 107 typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *,
 108                                gfc_full_array_i4 *,
 109                                GFC_INTEGER_4 *, char *,
 110                                gfc_charlen_type, gfc_charlen_type);
 111
 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);
 115
 116 /* The dtio calls for namelist require a CLASS object to be built.  */
 117 typedef struct gfc_class
 118 {
 119   void *data;
 120   void *vptr;
 121   index_type len;
 122 }
 123 gfc_class;
 124
 125
 126 /* A structure to build a hash table for format data.  */
 127
 128 #define FORMAT_HASH_SIZE 16
 129
 130 typedef struct format_hash_entry
 131 {
 132   char *key;
 133   gfc_charlen_type key_len;
 134   struct format_data *hashed_fmt;
 135 }
 136 format_hash_entry;
 137
 138 /* Format tokens.  Only about half of these can be stored in the
 139    format nodes.  */
 140
 141 typedef enum
 142 {
 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
 149 }
 150 format_token;
 151
 152 /* Representation of a namelist object in libgfortran
 153
 154    Namelist Records
 155       &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]].../
 156      or
 157       &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]]...&END
 158
 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.
 164
 165    These requirements are met by the following data structures.
 166
 167    namelist_info type contains all the scalar information about the
 168    object and arrays of descriptor_dimension and array_loop_spec types for
 169    arrays.  */
 170
 171 typedef struct namelist_type
 172 {
 173   /* Object type.  */
 174   bt type;
 175
 176   /* Object name.  */
 177   char * var_name;
 178
 179   /* Address for the start of the object's data.  */
 180   void * mem_pos;
 181
 182   /* Address of specific DTIO subroutine.  */
 183   void * dtio_sub;
 184
 185   /* Address of vtable if dtio_sub non-null.  */
 186   void * vtable;
 187
 188   /* Flag to show that a read is to be attempted for this node.  */
 189   int touched;
 190
 191   /* Length of intrinsic type in bytes.  */
 192   int len;
 193
 194   /* Rank of the object.  */
 195   int var_rank;
 196
 197   /* Overall size of the object in bytes.  */
 198   index_type size;
 199
 200   /* Length of character string.  */
 201   index_type string_length;
 202
 203   descriptor_dimension * dim;
 204   array_loop_spec * ls;
 205   struct namelist_type * next;
 206 }
 207 namelist_info;
 208
 209 /* Options for the OPEN statement.  */
 210
 211 typedef enum
 212 { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM,
 213   ACCESS_UNSPECIFIED
 214 }
 215 unit_access;
 216
 217 typedef enum
 218 { ACTION_READ, ACTION_WRITE, ACTION_READWRITE,
 219   ACTION_UNSPECIFIED
 220 }
 221 unit_action;
 222
 223 typedef enum
 224 { BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED }
 225 unit_blank;
 226
 227 typedef enum
 228 { DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE,
 229   DELIM_UNSPECIFIED
 230 }
 231 unit_delim;
 232
 233 typedef enum
 234 { FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED }
 235 unit_form;
 236
 237 typedef enum
 238 { POSITION_ASIS, POSITION_REWIND, POSITION_APPEND,
 239   POSITION_UNSPECIFIED
 240 }
 241 unit_position;
 242
 243 typedef enum
 244 { STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH,
 245   STATUS_REPLACE, STATUS_UNSPECIFIED
 246 }
 247 unit_status;
 248
 249 typedef enum
 250 { PAD_YES, PAD_NO, PAD_UNSPECIFIED }
 251 unit_pad;
 252
 253 typedef enum
 254 { DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
 255 unit_decimal;
 256
 257 typedef enum
 258 { ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
 259 unit_encoding;
 260
 261 typedef enum
 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. */
 269 }
 270 unit_round;
 271
 272 /* NOTE: unit_sign must correspond with the sign_status enumerator in
 273    st_parameter_dt to not break the ABI.  */
 274 typedef enum
 275 { SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
 276 unit_sign;
 277
 278 typedef enum
 279 { ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
 280 unit_advance;
 281
 282 typedef enum
 283 {READING, WRITING, LIST_READING, LIST_WRITING}
 284 unit_mode;
 285
 286 typedef enum
 287 { ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
 288 unit_async;
 289
 290 typedef enum
 291 { SHARE_DENYRW, SHARE_DENYNONE,
 292   SHARE_UNSPECIFIED
 293 }
 294 unit_share;
 295
 296 typedef enum
 297 { CC_LIST, CC_FORTRAN, CC_NONE,
 298   CC_UNSPECIFIED
 299 }
 300 unit_cc;
 301
 302 /* End-of-record types for CC_FORTRAN.  */
 303 typedef enum
 304 { CCF_DEFAULT=0x0,
 305   CCF_OVERPRINT=0x1,
 306   CCF_ONE_LF=0x2,
 307   CCF_TWO_LF=0x4,
 308   CCF_PAGE_FEED=0x8,
 309   CCF_PROMPT=0x10,
 310   CCF_OVERPRINT_NOA=0x20,
 311 } /* 6 bits */
 312 cc_fortran;
 313
 314 typedef enum
 315 { SIGN_S, SIGN_SS, SIGN_SP }
 316 unit_sign_s;
 317
 318 /* Make sure to keep st_parameter_* in sync with gcc/fortran/ioparm.def.  */
 319
 320 #define CHARACTER1(name) \
 321               char * name; \
 322               gfc_charlen_type name ## _len
 323 #define CHARACTER2(name) \
 324               gfc_charlen_type name ## _len; \
 325               char * name
 326
 327 typedef struct
 328 {
 329   st_parameter_common common;
 330   GFC_IO_INT recl_in;
 331   CHARACTER2 (file);
 332   CHARACTER1 (status);
 333   CHARACTER2 (access);
 334   CHARACTER1 (form);
 335   CHARACTER2 (blank);
 336   CHARACTER1 (position);
 337   CHARACTER2 (action);
 338   CHARACTER1 (delim);
 339   CHARACTER2 (pad);
 340   CHARACTER1 (convert);
 341   CHARACTER2 (decimal);
 342   CHARACTER1 (encoding);
 343   CHARACTER2 (round);
 344   CHARACTER1 (sign);
 345   CHARACTER2 (asynchronous);
 346   GFC_INTEGER_4 *newunit;
 347   GFC_INTEGER_4 readonly;
 348   CHARACTER2 (cc);
 349   CHARACTER1 (share);
 350 }
 351 st_parameter_open;
 352
 353 #define IOPARM_CLOSE_HAS_STATUS         (1 << 7)
 354
 355 typedef struct
 356 {
 357   st_parameter_common common;
 358   CHARACTER1 (status);
 359 }
 360 st_parameter_close;
 361
 362 typedef struct
 363 {
 364   st_parameter_common common;
 365 }
 366 st_parameter_filepos;
 367
 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)
 393
 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)
 405
 406 typedef struct
 407 {
 408   st_parameter_common common;
 409   GFC_INTEGER_4 *exist, *opened, *number, *named;
 410   GFC_IO_INT *nextrec, *recl_out, *strm_pos_out;
 411   CHARACTER1 (file);
 412   CHARACTER2 (access);
 413   CHARACTER1 (form);
 414   CHARACTER2 (blank);
 415   CHARACTER1 (position);
 416   CHARACTER2 (action);
 417   CHARACTER1 (delim);
 418   CHARACTER2 (pad);
 419   CHARACTER1 (name);
 420   CHARACTER2 (sequential);
 421   CHARACTER1 (direct);
 422   CHARACTER2 (formatted);
 423   CHARACTER1 (unformatted);
 424   CHARACTER2 (read);
 425   CHARACTER1 (write);
 426   CHARACTER2 (readwrite);
 427   CHARACTER1 (convert);
 428   GFC_INTEGER_4 flags2;
 429   CHARACTER1 (asynchronous);
 430   CHARACTER2 (decimal);
 431   CHARACTER1 (encoding);
 432   CHARACTER2 (round);
 433   CHARACTER1 (sign);
 434   GFC_INTEGER_4 *pending;
 435   GFC_IO_INT *size;
 436   GFC_INTEGER_4 *id;
 437   CHARACTER1 (iqstream);
 438   CHARACTER2 (share);
 439   CHARACTER1 (cc);
 440 }
 441 st_parameter_inquire;
 442
 443
 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)
 467
 468
 469 typedef struct st_parameter_dt
 470 {
 471   st_parameter_common common;
 472   GFC_IO_INT rec;
 473   GFC_IO_INT *size, *iolength;
 474   gfc_array_char *internal_unit_desc;
 475   CHARACTER1 (format);
 476   CHARACTER2 (advance);
 477   CHARACTER1 (internal_unit);
 478   CHARACTER2 (namelist_name);
 479   GFC_INTEGER_4 *id;
 480   GFC_IO_INT pos;
 481   CHARACTER1 (asynchronous);
 482   CHARACTER2 (blank);
 483   CHARACTER1 (decimal);
 484   CHARACTER2 (delim);
 485   CHARACTER1 (pad);
 486   CHARACTER2 (round);
 487   CHARACTER1 (sign);
 488   /* Private part of the structure.  The compiler just needs
 489      to reserve enough space.  */
 490   union
 491     {
 492       struct
 493         {
 494           void (*transfer) (struct st_parameter_dt *, bt, void *, int,
 495                             size_t, size_t);
 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.  */
 499           int item_count;
 500           unit_mode mode;
 501           unit_blank blank_status;
 502           unit_sign sign_status;
 503           int scale_factor;
 504           /* Maximum righthand column written to.  */
 505           int max_pos;
 506           /* Number of skips + spaces to be done for T and X-editing.  */
 507           int skips;
 508           /* Number of spaces to be done for T and X-editing.  */
 509           int pending_spaces;
 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) */
 514           int sf_seen_eor;
 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;
 523           unsigned at_eol : 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
 541              unit is internal.  */
 542           unsigned unit_is_internal : 1;
 543           /* An internal unit specific flag to signify an EOF condition for list
 544              directed read.  */
 545           unsigned at_eof : 1;
 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
 551              has occurred.  */
 552           unsigned expanded_read : 1;
 553           /* Flag to indicate if the statement has async="YES". */
 554           unsigned async : 1;
 555           /* 12 unused bits.  */
 556
 557           int child_saved_iostat;
 558           int nml_delim;
 559           int repeat_count;
 560           int saved_length;
 561           int saved_used;
 562           bt saved_type;
 563           char *saved_string;
 564           char *scratch;
 565           char *line_buffer;
 566           struct format_data *fmt;
 567           namelist_info *ionml;
 568 #ifdef HAVE_POSIX_2008_LOCALE
 569           locale_t old_locale;
 570 #endif
 571           /* Current position within the look-ahead line buffer.  */
 572           int line_buffer_pos;
 573           /* Storage area for values except for strings.  Must be
 574              large enough to hold a complex value (two reals) of the
 575              largest kind.  */
 576           char value[32];
 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
 583              next_record_w.  */
 584           struct
 585             {
 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.  */
 589               union
 590                 {
 591                   char start; /* Output character for start of record.  */
 592                   char end;   /* Output character for end of record.  */
 593                 } u;
 594             } cc;
 595         } p;
 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)];
 600     } u;
 601 }
 602 st_parameter_dt;
 603
 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)
 607                                   ? 1 : -1];
 608
 609 #define IOPARM_WAIT_HAS_ID              (1 << 7)
 610
 611 typedef struct
 612 {
 613   st_parameter_common common;
 614   GFC_INTEGER_4 *id;
 615 }
 616 st_parameter_wait;
 617
 618
 619 #undef CHARACTER1
 620 #undef CHARACTER2
 621
 622 typedef struct
 623 {
 624   unit_access access;
 625   unit_action action;
 626   unit_blank blank;
 627   unit_delim delim;
 628   unit_form form;
 629   int is_notpadded;
 630   unit_position position;
 631   unit_status status;
 632   unit_pad pad;
 633   unit_convert convert;
 634   int has_recl;
 635   unit_decimal decimal;
 636   unit_encoding encoding;
 637   unit_round round;
 638   unit_sign sign;
 639   unit_async async;
 640   unit_share share;
 641   unit_cc cc;
 642   int readonly;
 643 }
 644 unit_flags;
 645
 646
 647 typedef struct gfc_unit
 648 {
 649   int unit_number;
 650   stream *s;
 651
 652   /* Treap links.  */
 653   struct gfc_unit *left, *right;
 654   int priority;
 655
 656   int read_bad, current_record, saved_pos, previous_nonadvancing_write;
 657
 658   enum
 659   { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
 660   endfile;
 661
 662   unit_mode mode;
 663   unit_flags flags;
 664   unit_pad pad_status;
 665   unit_decimal decimal_status;
 666   unit_delim delim_status;
 667   unit_round round_status;
 668
 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;
 678
 679   /* Set to 1 if we have read a subrecord.  */
 680
 681   int continued;
 682
 683   /* Contains the pointer to the async unit.  */
 684   struct async_unit *au;
 685
 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.  */
 693   int waiting;
 694   /* Flag set by close_unit if the unit as been closed.
 695      Must be manipulated under unit's lock.  */
 696   int closed;
 697
 698   /* For traversing arrays */
 699   array_loop_spec *ls;
 700   int rank;
 701
 702   /* Name of the file at the time OPEN was executed, as a
 703      null-terminated C string.  */
 704   char *filename;
 705
 706   /* The format hash table.  */
 707   struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
 708
 709   /* Formatting buffer.  */
 710   struct fbuf *fbuf;
 711
 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);
 715
 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;
 721
 722   /* DTIO Parent/Child procedure, 0 = parent, >0 = child level.  */
 723   int child_dtio;
 724
 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.  */
 728   int last_char;
 729   bool has_size;
 730   GFC_IO_INT size_used;
 731 }
 732 gfc_unit;
 733
 734 typedef struct gfc_saved_unit
 735 {
 736   GFC_INTEGER_4 unit_number;
 737   gfc_unit *unit;
 738 }
 739 gfc_saved_unit;
 740
 741 /* TEMP_FAILURE_RETRY macro from glibc.  */
 742
 743 #ifndef TEMP_FAILURE_RETRY
 744 /* Evaluate EXPRESSION, and repeat as long as it returns -1 with `errno'
 745    set to EINTR.  */
 746
 747 # define TEMP_FAILURE_RETRY(expression) \
 748   (__extension__                                                              \
 749     ({ long int __result;                                                     \
 750        do __result = (long int) (expression);                                 \
 751        while (__result == -1L && errno == EINTR);                             \
 752        __result; }))
 753 #endif
 754
 755
 756 /* unit.c */
 757
 758 /* Maximum file offset, computed at library initialization time.  */
 759 extern gfc_offset max_offset;
 760 internal_proto(max_offset);
 761
 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);
 766
 767 /* Unit tree root.  */
 768 extern gfc_unit *unit_root;
 769 internal_proto(unit_root);
 770
 771 #ifdef __GTHREAD_RWLOCK_INIT
 772 extern __gthread_rwlock_t unit_rwlock;
 773 internal_proto(unit_rwlock);
 774 #else
 775 extern __gthread_mutex_t unit_rwlock;
 776 internal_proto(unit_rwlock);
 777 #endif
 778
 779 extern int close_unit (gfc_unit *);
 780 internal_proto(close_unit);
 781
 782 extern gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int);
 783 internal_proto(set_internal_unit);
 784
 785 extern void stash_internal_unit (st_parameter_dt *);
 786 internal_proto(stash_internal_unit);
 787
 788 extern gfc_unit *find_unit (int);
 789 internal_proto(find_unit);
 790
 791 extern gfc_unit *find_or_create_unit (int);
 792 internal_proto(find_or_create_unit);
 793
 794 extern gfc_unit *get_unit (st_parameter_dt *, int);
 795 internal_proto(get_unit);
 796
 797 extern void unlock_unit(gfc_unit *);
 798 internal_proto(unlock_unit);
 799
 800 extern void finish_last_advance_record (gfc_unit *u);
 801 internal_proto(finish_last_advance_record);
 802
 803 extern int unit_truncate(gfc_unit *, gfc_offset, st_parameter_common *);
 804 internal_proto(unit_truncate);
 805
 806 extern int newunit_alloc (void);
 807 internal_proto(newunit_alloc);
 808
 809 extern void newunit_free (int);
 810 internal_proto(newunit_free);
 811
 812
 813 /* open.c */
 814
 815 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
 816 internal_proto(new_unit);
 817
 818
 819 /* transfer.c */
 820
 821 #define SCRATCH_SIZE 300
 822
 823 extern const char *type_name (bt);
 824 internal_proto(type_name);
 825
 826 extern void * read_block_form (st_parameter_dt *, size_t *);
 827 internal_proto(read_block_form);
 828
 829 extern void * read_block_form4 (st_parameter_dt *, size_t *);
 830 internal_proto(read_block_form4);
 831
 832 extern void *write_block (st_parameter_dt *, size_t);
 833 internal_proto(write_block);
 834
 835 extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *,
 836                                      int*);
 837 internal_proto(next_array_record);
 838
 839 extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *,
 840                                   gfc_offset *);
 841 internal_proto(init_loop_spec);
 842
 843 extern void next_record (st_parameter_dt *, int);
 844 internal_proto(next_record);
 845
 846 extern void st_wait (st_parameter_wait *);
 847 export_proto (st_wait);
 848
 849 extern void st_wait_async (st_parameter_wait *);
 850 export_proto (st_wait_async);
 851
 852 extern void hit_eof (st_parameter_dt *);
 853 internal_proto(hit_eof);
 854
 855 extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int,
 856                                   gfc_charlen_type);
 857 internal_proto (transfer_array_inner);
 858
 859 /* read.c */
 860
 861 extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
 862 internal_proto(set_integer);
 863
 864 extern GFC_UINTEGER_LARGEST si_max (int);
 865 internal_proto(si_max);
 866
 867 extern int convert_real (st_parameter_dt *, void *, const char *, int);
 868 internal_proto(convert_real);
 869
 870 extern int convert_infnan (st_parameter_dt *, void *, const char *, int);
 871 internal_proto(convert_infnan);
 872
 873 extern void read_a (st_parameter_dt *, const fnode *, char *, size_t);
 874 internal_proto(read_a);
 875
 876 extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, size_t);
 877 internal_proto(read_a);
 878
 879 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
 880 internal_proto(read_f);
 881
 882 extern void read_l (st_parameter_dt *, const fnode *, char *, int);
 883 internal_proto(read_l);
 884
 885 extern void read_x (st_parameter_dt *, size_t);
 886 internal_proto(read_x);
 887
 888 extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
 889 internal_proto(read_radix);
 890
 891 extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
 892 internal_proto(read_decimal);
 893
 894 extern void read_user_defined (st_parameter_dt *, void *);
 895 internal_proto(read_user_defined);
 896
 897 extern void read_user_defined (st_parameter_dt *, void *);
 898 internal_proto(read_user_defined);
 899
 900 /* list_read.c */
 901
 902 extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
 903                                  size_t);
 904 internal_proto(list_formatted_read);
 905
 906 extern void finish_list_read (st_parameter_dt *);
 907 internal_proto(finish_list_read);
 908
 909 extern void namelist_read (st_parameter_dt *);
 910 internal_proto(namelist_read);
 911
 912 extern void namelist_write (st_parameter_dt *);
 913 internal_proto(namelist_write);
 914
 915 /* write.c */
 916
 917 extern void write_a (st_parameter_dt *, const fnode *, const char *, size_t);
 918 internal_proto(write_a);
 919
 920 extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, size_t);
 921 internal_proto(write_a_char4);
 922
 923 extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
 924 internal_proto(write_b);
 925
 926 extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
 927 internal_proto(write_d);
 928
 929 extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
 930 internal_proto(write_e);
 931
 932 extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
 933 internal_proto(write_en);
 934
 935 extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
 936 internal_proto(write_es);
 937
 938 extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
 939 internal_proto(write_f);
 940
 941 extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
 942 internal_proto(write_i);
 943
 944 extern void write_l (st_parameter_dt *, const fnode *, char *, int);
 945 internal_proto(write_l);
 946
 947 extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
 948 internal_proto(write_o);
 949
 950 extern void write_real (st_parameter_dt *, const char *, int);
 951 internal_proto(write_real);
 952
 953 extern void write_real_w0 (st_parameter_dt *, const char *, int, const fnode*);
 954 internal_proto(write_real_w0);
 955
 956 extern void write_x (st_parameter_dt *, int, int);
 957 internal_proto(write_x);
 958
 959 extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
 960 internal_proto(write_z);
 961
 962 extern void write_user_defined (st_parameter_dt *, void *);
 963 internal_proto(write_user_defined);
 964
 965 extern void write_user_defined (st_parameter_dt *, void *);
 966 internal_proto(write_user_defined);
 967
 968 extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
 969                                   size_t);
 970 internal_proto(list_formatted_write);
 971
 972 /* size_from_kind.c */
 973 extern size_t size_from_real_kind (int);
 974 internal_proto(size_from_real_kind);
 975
 976 extern size_t size_from_complex_kind (int);
 977 internal_proto(size_from_complex_kind);
 978
 979
 980 /* lock.c */
 981 extern void free_ionml (st_parameter_dt *);
 982 internal_proto(free_ionml);
 983
 984 static inline void
 985 inc_waiting_locked (gfc_unit *u)
 986 {
 987 #ifdef HAVE_ATOMIC_FETCH_ADD
 988   (void) __atomic_fetch_add (&u->waiting, 1, __ATOMIC_RELAXED);
 989 #else
 990   u->waiting++;
 991 #endif
 992 }
 993
 994 static inline int
 995 predec_waiting_locked (gfc_unit *u)
 996 {
 997 #ifdef HAVE_ATOMIC_FETCH_ADD
 998   /* Note that the pattern
 999
1000      if (predec_waiting_locked (u) == 0)
1001          // destroy u
1002
1003      could be further optimized by making this be an __ATOMIC_RELEASE,
1004      and then inserting a
1005
1006      __atomic_thread_fence (__ATOMIC_ACQUIRE);
1007
1008      inside the branch before destroying.  But for now, lets keep it
1009      simple.  */
1010   return __atomic_add_fetch (&u->waiting, -1, __ATOMIC_ACQ_REL);
1011 #else
1012   return --u->waiting;
1013 #endif
1014 }
1015
1016 static inline void
1017 dec_waiting_unlocked (gfc_unit *u)
1018 {
1019 #ifdef HAVE_ATOMIC_FETCH_ADD
1020   (void) __atomic_fetch_add (&u->waiting, -1, __ATOMIC_RELAXED);
1021 #else
1022 #ifdef __GTHREAD_RWLOCK_INIT
1023   __gthread_rwlock_wrlock (&unit_rwlock);
1024   u->waiting--;
1025   __gthread_rwlock_unlock (&unit_rwlock);
1026 #else
1027   __gthread_mutex_lock (&unit_rwlock);
1028   u->waiting--;
1029   __gthread_mutex_unlock (&unit_rwlock);
1030 #endif
1031 #endif
1032 }
1033
1034
1035 static inline void
1036 memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
1037 {
1038   int j;
1039   for (j = 0; j < k; j++)
1040     *p++ = c;
1041 }
1042
1043 /* Used in width fields to indicate that the default should be used */
1044 #define DEFAULT_WIDTH -1
1045
1046 /* Defaults for certain format field descriptors. These are decided based on
1047  * the type of the value being formatted.
1048  *
1049  * The behaviour here is modelled on the Oracle Fortran compiler. At the time
1050  * of writing, the details were available at this URL:
1051  *
1052  *   https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d
1053  */
1054
1055 static inline int
1056 default_width_for_integer (int kind)
1057 {
1058   switch (kind)
1059     {
1060     case 1:
1061     case 2:  return  7;
1062     case 4:  return 12;
1063     case 8:  return 23;
1064     case 16: return 44;
1065     default: return  0;
1066     }
1067 }
1068
1069 static inline int
1070 default_width_for_float (int kind)
1071 {
1072   switch (kind)
1073     {
1074     case 4:  return 15;
1075     case 8:  return 25;
1076     case 16:
1077     case 17: return 42;
1078     default: return  0;
1079     }
1080 }
1081
1082 static inline int
1083 default_precision_for_float (int kind)
1084 {
1085   switch (kind)
1086     {
1087     case 4:  return 7;
1088     case 8:  return 16;
1089     case 16:
1090     case 17: return 33;
1091     default: return 0;
1092     }
1093 }
1094
1095 #endif
1096
1097 extern void
1098 st_write_done_worker (st_parameter_dt *, bool);
1099 internal_proto (st_write_done_worker);
1100
1101 extern void
1102 st_read_done_worker (st_parameter_dt *, bool);
1103 internal_proto (st_read_done_worker);
1104
1105 extern void
1106 data_transfer_init_worker (st_parameter_dt *, int);
1107 internal_proto (data_transfer_init_worker);