libgfortran/io/io.h

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