libgfortran/io/io.h

   1 /* Copyright (C) 2002-2019 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 #ifdef HAVE_NEWLOCALE
  56 /* We have POSIX 2008 extended locale stuff.  */
  57 extern locale_t c_locale;
  58 internal_proto(c_locale);
  59 #else
  60 extern char* old_locale;
  61 internal_proto(old_locale);
  62 extern int old_locale_ctr;
  63 internal_proto(old_locale_ctr);
  64 extern __gthread_mutex_t old_locale_lock;
  65 internal_proto(old_locale_lock);
  66 #endif
  67
  68
  69 /* Macros for testing what kinds of I/O we are doing.  */
  70
  71 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
  72
  73 #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
  74
  75 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
  76
  77 #define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4)
  78
  79 /* The array_loop_spec contains the variables for the loops over index ranges
  80    that are encountered.  */
  81
  82 typedef struct array_loop_spec
  83 {
  84   /* Index counter for this dimension.  */
  85   index_type idx;
  86
  87   /* Start for the index counter.  */
  88   index_type start;
  89
  90   /* End for the index counter.  */
  91   index_type end;
  92
  93   /* Step for the index counter.  */
  94   index_type step;
  95 }
  96 array_loop_spec;
  97
  98 /* User defined input/output iomsg length. */
  99
 100 #define IOMSG_LEN 256
 101
 102 /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
 103                               iomsg, (_iotype), (_iomsg))  */
 104 typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *,
 105                                gfc_full_array_i4 *,
 106                                GFC_INTEGER_4 *, char *,
 107                                gfc_charlen_type, gfc_charlen_type);
 108
 109 /* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg))  */
 110 typedef void (*unformatted_dtio)(void *, GFC_INTEGER_4 *, GFC_INTEGER_4 *,
 111                                  char *, gfc_charlen_type);
 112
 113 /* The dtio calls for namelist require a CLASS object to be built.  */
 114 typedef struct gfc_class
 115 {
 116   void *data;
 117   void *vptr;
 118   index_type len;
 119 }
 120 gfc_class;
 121
 122
 123 /* A structure to build a hash table for format data.  */
 124
 125 #define FORMAT_HASH_SIZE 16
 126
 127 typedef struct format_hash_entry
 128 {
 129   char *key;
 130   gfc_charlen_type key_len;
 131   struct format_data *hashed_fmt;
 132 }
 133 format_hash_entry;
 134
 135 /* Format tokens.  Only about half of these can be stored in the
 136    format nodes.  */
 137
 138 typedef enum
 139 {
 140   FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
 141   FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
 142   FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
 143   FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
 144   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
 145   FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
 146 }
 147 format_token;
 148
 149 /* Representation of a namelist object in libgfortran
 150
 151    Namelist Records
 152       &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]].../
 153      or
 154       &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]]...&END
 155
 156    The object can be a fully qualified, compound name for an intrinsic
 157    type, derived types or derived type components.  So, a substring
 158    a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
 159    read. Hence full information about the structure of the object has
 160    to be available to list_read.c and write.
 161
 162    These requirements are met by the following data structures.
 163
 164    namelist_info type contains all the scalar information about the
 165    object and arrays of descriptor_dimension and array_loop_spec types for
 166    arrays.  */
 167
 168 typedef struct namelist_type
 169 {
 170   /* Object type.  */
 171   bt type;
 172
 173   /* Object name.  */
 174   char * var_name;
 175
 176   /* Address for the start of the object's data.  */
 177   void * mem_pos;
 178
 179   /* Address of specific DTIO subroutine.  */
 180   void * dtio_sub;
 181
 182   /* Address of vtable if dtio_sub non-null.  */
 183   void * vtable;
 184
 185   /* Flag to show that a read is to be attempted for this node.  */
 186   int touched;
 187
 188   /* Length of intrinsic type in bytes.  */
 189   int len;
 190
 191   /* Rank of the object.  */
 192   int var_rank;
 193
 194   /* Overall size of the object in bytes.  */
 195   index_type size;
 196
 197   /* Length of character string.  */
 198   index_type string_length;
 199
 200   descriptor_dimension * dim;
 201   array_loop_spec * ls;
 202   struct namelist_type * next;
 203 }
 204 namelist_info;
 205
 206 /* Options for the OPEN statement.  */
 207
 208 typedef enum
 209 { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM,
 210   ACCESS_UNSPECIFIED
 211 }
 212 unit_access;
 213
 214 typedef enum
 215 { ACTION_READ, ACTION_WRITE, ACTION_READWRITE,
 216   ACTION_UNSPECIFIED
 217 }
 218 unit_action;
 219
 220 typedef enum
 221 { BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED }
 222 unit_blank;
 223
 224 typedef enum
 225 { DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE,
 226   DELIM_UNSPECIFIED
 227 }
 228 unit_delim;
 229
 230 typedef enum
 231 { FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED }
 232 unit_form;
 233
 234 typedef enum
 235 { POSITION_ASIS, POSITION_REWIND, POSITION_APPEND,
 236   POSITION_UNSPECIFIED
 237 }
 238 unit_position;
 239
 240 typedef enum
 241 { STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH,
 242   STATUS_REPLACE, STATUS_UNSPECIFIED
 243 }
 244 unit_status;
 245
 246 typedef enum
 247 { PAD_YES, PAD_NO, PAD_UNSPECIFIED }
 248 unit_pad;
 249
 250 typedef enum
 251 { DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
 252 unit_decimal;
 253
 254 typedef enum
 255 { ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
 256 unit_encoding;
 257
 258 typedef enum
 259 { ROUND_UP = GFC_FPE_UPWARD,
 260   ROUND_DOWN = GFC_FPE_DOWNWARD,
 261   ROUND_ZERO = GFC_FPE_TOWARDZERO,
 262   ROUND_NEAREST = GFC_FPE_TONEAREST,
 263   ROUND_COMPATIBLE = 10, /* round away from zero.  */
 264   ROUND_PROCDEFINED, /* Here as ROUND_NEAREST. */
 265   ROUND_UNSPECIFIED /* Should never occur. */
 266 }
 267 unit_round;
 268
 269 /* NOTE: unit_sign must correspond with the sign_status enumerator in
 270    st_parameter_dt to not break the ABI.  */
 271 typedef enum
 272 { SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
 273 unit_sign;
 274
 275 typedef enum
 276 { ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
 277 unit_advance;
 278
 279 typedef enum
 280 {READING, WRITING, LIST_READING, LIST_WRITING}
 281 unit_mode;
 282
 283 typedef enum
 284 { ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
 285 unit_async;
 286
 287 typedef enum
 288 { SHARE_DENYRW, SHARE_DENYNONE,
 289   SHARE_UNSPECIFIED
 290 }
 291 unit_share;
 292
 293 typedef enum
 294 { CC_LIST, CC_FORTRAN, CC_NONE,
 295   CC_UNSPECIFIED
 296 }
 297 unit_cc;
 298
 299 /* End-of-record types for CC_FORTRAN.  */
 300 typedef enum
 301 { CCF_DEFAULT=0x0,
 302   CCF_OVERPRINT=0x1,
 303   CCF_ONE_LF=0x2,
 304   CCF_TWO_LF=0x4,
 305   CCF_PAGE_FEED=0x8,
 306   CCF_PROMPT=0x10,
 307   CCF_OVERPRINT_NOA=0x20,
 308 } /* 6 bits */
 309 cc_fortran;
 310
 311 typedef enum
 312 { SIGN_S, SIGN_SS, SIGN_SP }
 313 unit_sign_s;
 314
 315 /* Make sure to keep st_parameter_* in sync with gcc/fortran/ioparm.def.  */
 316
 317 #define CHARACTER1(name) \
 318               char * name; \
 319               gfc_charlen_type name ## _len
 320 #define CHARACTER2(name) \
 321               gfc_charlen_type name ## _len; \
 322               char * name
 323
 324 typedef struct
 325 {
 326   st_parameter_common common;
 327   GFC_IO_INT recl_in;
 328   CHARACTER2 (file);
 329   CHARACTER1 (status);
 330   CHARACTER2 (access);
 331   CHARACTER1 (form);
 332   CHARACTER2 (blank);
 333   CHARACTER1 (position);
 334   CHARACTER2 (action);
 335   CHARACTER1 (delim);
 336   CHARACTER2 (pad);
 337   CHARACTER1 (convert);
 338   CHARACTER2 (decimal);
 339   CHARACTER1 (encoding);
 340   CHARACTER2 (round);
 341   CHARACTER1 (sign);
 342   CHARACTER2 (asynchronous);
 343   GFC_INTEGER_4 *newunit;
 344   GFC_INTEGER_4 readonly;
 345   CHARACTER2 (cc);
 346   CHARACTER1 (share);
 347 }
 348 st_parameter_open;
 349
 350 #define IOPARM_CLOSE_HAS_STATUS         (1 << 7)
 351
 352 typedef struct
 353 {
 354   st_parameter_common common;
 355   CHARACTER1 (status);
 356 }
 357 st_parameter_close;
 358
 359 typedef struct
 360 {
 361   st_parameter_common common;
 362 }
 363 st_parameter_filepos;
 364
 365 #define IOPARM_INQUIRE_HAS_EXIST        (1 << 7)
 366 #define IOPARM_INQUIRE_HAS_OPENED       (1 << 8)
 367 #define IOPARM_INQUIRE_HAS_NUMBER       (1 << 9)
 368 #define IOPARM_INQUIRE_HAS_NAMED        (1 << 10)
 369 #define IOPARM_INQUIRE_HAS_NEXTREC      (1 << 11)
 370 #define IOPARM_INQUIRE_HAS_RECL_OUT     (1 << 12)
 371 #define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 13)
 372 #define IOPARM_INQUIRE_HAS_FILE         (1 << 14)
 373 #define IOPARM_INQUIRE_HAS_ACCESS       (1 << 15)
 374 #define IOPARM_INQUIRE_HAS_FORM         (1 << 16)
 375 #define IOPARM_INQUIRE_HAS_BLANK        (1 << 17)
 376 #define IOPARM_INQUIRE_HAS_POSITION     (1 << 18)
 377 #define IOPARM_INQUIRE_HAS_ACTION       (1 << 19)
 378 #define IOPARM_INQUIRE_HAS_DELIM        (1 << 20)
 379 #define IOPARM_INQUIRE_HAS_PAD          (1 << 21)
 380 #define IOPARM_INQUIRE_HAS_NAME         (1 << 22)
 381 #define IOPARM_INQUIRE_HAS_SEQUENTIAL   (1 << 23)
 382 #define IOPARM_INQUIRE_HAS_DIRECT       (1 << 24)
 383 #define IOPARM_INQUIRE_HAS_FORMATTED    (1 << 25)
 384 #define IOPARM_INQUIRE_HAS_UNFORMATTED  (1 << 26)
 385 #define IOPARM_INQUIRE_HAS_READ         (1 << 27)
 386 #define IOPARM_INQUIRE_HAS_WRITE        (1 << 28)
 387 #define IOPARM_INQUIRE_HAS_READWRITE    (1 << 29)
 388 #define IOPARM_INQUIRE_HAS_CONVERT      (1 << 30)
 389 #define IOPARM_INQUIRE_HAS_FLAGS2       (1u << 31)
 390
 391 #define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0)
 392 #define IOPARM_INQUIRE_HAS_DECIMAL      (1 << 1)
 393 #define IOPARM_INQUIRE_HAS_ENCODING     (1 << 2)
 394 #define IOPARM_INQUIRE_HAS_ROUND        (1 << 3)
 395 #define IOPARM_INQUIRE_HAS_SIGN         (1 << 4)
 396 #define IOPARM_INQUIRE_HAS_PENDING      (1 << 5)
 397 #define IOPARM_INQUIRE_HAS_SIZE         (1 << 6)
 398 #define IOPARM_INQUIRE_HAS_ID           (1 << 7)
 399 #define IOPARM_INQUIRE_HAS_IQSTREAM     (1 << 8)
 400 #define IOPARM_INQUIRE_HAS_SHARE        (1 << 9)
 401 #define IOPARM_INQUIRE_HAS_CC           (1 << 10)
 402
 403 typedef struct
 404 {
 405   st_parameter_common common;
 406   GFC_INTEGER_4 *exist, *opened, *number, *named;
 407   GFC_IO_INT *nextrec, *recl_out, *strm_pos_out;
 408   CHARACTER1 (file);
 409   CHARACTER2 (access);
 410   CHARACTER1 (form);
 411   CHARACTER2 (blank);
 412   CHARACTER1 (position);
 413   CHARACTER2 (action);
 414   CHARACTER1 (delim);
 415   CHARACTER2 (pad);
 416   CHARACTER1 (name);
 417   CHARACTER2 (sequential);
 418   CHARACTER1 (direct);
 419   CHARACTER2 (formatted);
 420   CHARACTER1 (unformatted);
 421   CHARACTER2 (read);
 422   CHARACTER1 (write);
 423   CHARACTER2 (readwrite);
 424   CHARACTER1 (convert);
 425   GFC_INTEGER_4 flags2;
 426   CHARACTER1 (asynchronous);
 427   CHARACTER2 (decimal);
 428   CHARACTER1 (encoding);
 429   CHARACTER2 (round);
 430   CHARACTER1 (sign);
 431   GFC_INTEGER_4 *pending;
 432   GFC_IO_INT *size;
 433   GFC_INTEGER_4 *id;
 434   CHARACTER1 (iqstream);
 435   CHARACTER2 (share);
 436   CHARACTER1 (cc);
 437 }
 438 st_parameter_inquire;
 439
 440
 441 #define IOPARM_DT_LIST_FORMAT                   (1 << 7)
 442 #define IOPARM_DT_NAMELIST_READ_MODE            (1 << 8)
 443 #define IOPARM_DT_HAS_REC                       (1 << 9)
 444 #define IOPARM_DT_HAS_SIZE                      (1 << 10)
 445 #define IOPARM_DT_HAS_IOLENGTH                  (1 << 11)
 446 #define IOPARM_DT_HAS_FORMAT                    (1 << 12)
 447 #define IOPARM_DT_HAS_ADVANCE                   (1 << 13)
 448 #define IOPARM_DT_HAS_INTERNAL_UNIT             (1 << 14)
 449 #define IOPARM_DT_HAS_NAMELIST_NAME             (1 << 15)
 450 #define IOPARM_DT_HAS_ID                        (1 << 16)
 451 #define IOPARM_DT_HAS_POS                       (1 << 17)
 452 #define IOPARM_DT_HAS_ASYNCHRONOUS              (1 << 18)
 453 #define IOPARM_DT_HAS_BLANK                     (1 << 19)
 454 #define IOPARM_DT_HAS_DECIMAL                   (1 << 20)
 455 #define IOPARM_DT_HAS_DELIM                     (1 << 21)
 456 #define IOPARM_DT_HAS_PAD                       (1 << 22)
 457 #define IOPARM_DT_HAS_ROUND                     (1 << 23)
 458 #define IOPARM_DT_HAS_SIGN                      (1 << 24)
 459 #define IOPARM_DT_HAS_F2003                     (1 << 25)
 460 #define IOPARM_DT_HAS_UDTIO                     (1 << 26)
 461 #define IOPARM_DT_DEC_EXT                       (1 << 27)
 462 /* Internal use bit.  */
 463 #define IOPARM_DT_IONML_SET                     (1u << 31)
 464
 465
 466 typedef struct st_parameter_dt
 467 {
 468   st_parameter_common common;
 469   GFC_IO_INT rec;
 470   GFC_IO_INT *size, *iolength;
 471   gfc_array_char *internal_unit_desc;
 472   CHARACTER1 (format);
 473   CHARACTER2 (advance);
 474   CHARACTER1 (internal_unit);
 475   CHARACTER2 (namelist_name);
 476   GFC_INTEGER_4 *id;
 477   GFC_IO_INT pos;
 478   CHARACTER1 (asynchronous);
 479   CHARACTER2 (blank);
 480   CHARACTER1 (decimal);
 481   CHARACTER2 (delim);
 482   CHARACTER1 (pad);
 483   CHARACTER2 (round);
 484   CHARACTER1 (sign);
 485   /* Private part of the structure.  The compiler just needs
 486      to reserve enough space.  */
 487   union
 488     {
 489       struct
 490         {
 491           void (*transfer) (struct st_parameter_dt *, bt, void *, int,
 492                             size_t, size_t);
 493           struct gfc_unit *current_unit;
 494           /* Item number in a formatted data transfer.  Also used in namelist
 495              read_logical as an index into line_buffer.  */
 496           int item_count;
 497           unit_mode mode;
 498           unit_blank blank_status;
 499           unit_sign sign_status;
 500           int scale_factor;
 501           /* Maximum righthand column written to.  */
 502           int max_pos;
 503           /* Number of skips + spaces to be done for T and X-editing.  */
 504           int skips;
 505           /* Number of spaces to be done for T and X-editing.  */
 506           int pending_spaces;
 507           /* Whether an EOR condition was encountered. Value is:
 508                0 if no EOR was encountered
 509                1 if an EOR was encountered due to a 1-byte marker (LF)
 510                2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
 511           int sf_seen_eor;
 512           unit_advance advance_status;
 513           unsigned reversion_flag : 1; /* Format reversion has occurred.  */
 514           unsigned first_item : 1;
 515           unsigned seen_dollar : 1;
 516           unsigned eor_condition : 1;
 517           unsigned no_leading_blank : 1;
 518           unsigned char_flag : 1;
 519           unsigned input_complete : 1;
 520           unsigned at_eol : 1;
 521           unsigned comma_flag : 1;
 522           /* A namelist specific flag used in the list directed library
 523              to flag that calls are being made from namelist read (e.g. to
 524              ignore comments or to treat '/' as a terminator)  */
 525           unsigned namelist_mode : 1;
 526           /* A namelist specific flag used in the list directed library
 527              to flag read errors and return, so that an attempt can be
 528              made to read a new object name.  */
 529           unsigned nml_read_error : 1;
 530           /* A sequential formatted read specific flag used to signal that a
 531              character string is being read so don't use commas to shorten a
 532              formatted field width.  */
 533           unsigned sf_read_comma : 1;
 534           /* A namelist specific flag used to enable reading input from
 535              line_buffer for logical reads.  */
 536           unsigned line_buffer_enabled : 1;
 537           /* An internal unit specific flag used to identify that the associated
 538              unit is internal.  */
 539           unsigned unit_is_internal : 1;
 540           /* An internal unit specific flag to signify an EOF condition for list
 541              directed read.  */
 542           unsigned at_eof : 1;
 543           /* Used for g0 floating point output.  */
 544           unsigned g0_no_blanks : 1;
 545           /* Used to signal use of free_format_data.  */
 546           unsigned format_not_saved : 1;
 547           /* A flag used to identify when a non-standard expanded namelist read
 548              has occurred.  */
 549           unsigned expanded_read : 1;
 550           /* Flag to indicate if the statement has async="YES". */
 551           unsigned async : 1;
 552           /* 12 unused bits.  */
 553
 554           int child_saved_iostat;
 555           int nml_delim;
 556           int repeat_count;
 557           int saved_length;
 558           int saved_used;
 559           bt saved_type;
 560           char *saved_string;
 561           char *scratch;
 562           char *line_buffer;
 563           struct format_data *fmt;
 564           namelist_info *ionml;
 565 #ifdef HAVE_NEWLOCALE
 566           locale_t old_locale;
 567 #endif
 568           /* Current position within the look-ahead line buffer.  */
 569           int line_buffer_pos;
 570           /* Storage area for values except for strings.  Must be
 571              large enough to hold a complex value (two reals) of the
 572              largest kind.  */
 573           char value[32];
 574           GFC_IO_INT not_used; /* Needed for alignment. */
 575           formatted_dtio fdtio_ptr;
 576           unformatted_dtio ufdtio_ptr;
 577           /* With CC_FORTRAN, the first character of a record determines the
 578              style of record end (and start) to use. We must mark down the type
 579              when we write first in write_a so we remember the end type later in
 580              next_record_w.  */
 581           struct
 582             {
 583               unsigned type : 6; /* See enum cc_fortran.  */
 584               unsigned len  : 2; /* Always 0, 1, or 2.  */
 585               /* The union is updated after start-of-record is written.  */
 586               union
 587                 {
 588                   char start; /* Output character for start of record.  */
 589                   char end;   /* Output character for end of record.  */
 590                 } u;
 591             } cc;
 592         } p;
 593       /* This pad size must be equal to the pad_size declared in
 594          trans-io.c (gfc_build_io_library_fndecls).  The above structure
 595          must be smaller or equal to this array.  */
 596       char pad[16 * sizeof (char *) + 32 * sizeof (int)];
 597     } u;
 598 }
 599 st_parameter_dt;
 600
 601 /* Ensure st_parameter_dt's u.pad is bigger or equal to u.p.  */
 602 extern char check_st_parameter_dt[sizeof (((st_parameter_dt *) 0)->u.pad)
 603                                   >= sizeof (((st_parameter_dt *) 0)->u.p)
 604                                   ? 1 : -1];
 605
 606 #define IOPARM_WAIT_HAS_ID              (1 << 7)
 607
 608 typedef struct
 609 {
 610   st_parameter_common common;
 611   GFC_INTEGER_4 *id;
 612 }
 613 st_parameter_wait;
 614
 615
 616 #undef CHARACTER1
 617 #undef CHARACTER2
 618
 619 typedef struct
 620 {
 621   unit_access access;
 622   unit_action action;
 623   unit_blank blank;
 624   unit_delim delim;
 625   unit_form form;
 626   int is_notpadded;
 627   unit_position position;
 628   unit_status status;
 629   unit_pad pad;
 630   unit_convert convert;
 631   int has_recl;
 632   unit_decimal decimal;
 633   unit_encoding encoding;
 634   unit_round round;
 635   unit_sign sign;
 636   unit_async async;
 637   unit_share share;
 638   unit_cc cc;
 639   int readonly;
 640 }
 641 unit_flags;
 642
 643
 644 typedef struct gfc_unit
 645 {
 646   int unit_number;
 647   stream *s;
 648
 649   /* Treap links.  */
 650   struct gfc_unit *left, *right;
 651   int priority;
 652
 653   int read_bad, current_record, saved_pos, previous_nonadvancing_write;
 654
 655   enum
 656   { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
 657   endfile;
 658
 659   unit_mode mode;
 660   unit_flags flags;
 661   unit_pad pad_status;
 662   unit_decimal decimal_status;
 663   unit_delim delim_status;
 664   unit_round round_status;
 665
 666   /* recl                 -- Record length of the file.
 667      last_record          -- Last record number read or written
 668      maxrec               -- Maximum record number in a direct access file
 669      bytes_left           -- Bytes left in current record.
 670      strm_pos             -- Current position in file for STREAM I/O.
 671      recl_subrecord       -- Maximum length for subrecord.
 672      bytes_left_subrecord -- Bytes left in current subrecord.  */
 673   gfc_offset recl, last_record, maxrec, bytes_left, strm_pos,
 674     recl_subrecord, bytes_left_subrecord;
 675
 676   /* Set to 1 if we have read a subrecord.  */
 677
 678   int continued;
 679
 680   /* Contains the pointer to the async unit.  */
 681   struct async_unit *au;
 682
 683   __gthread_mutex_t lock;
 684   /* Number of threads waiting to acquire this unit's lock.
 685      When non-zero, close_unit doesn't only removes the unit
 686      from the UNIT_ROOT tree, but doesn't free it and the
 687      last of the waiting threads will do that.
 688      This must be either atomically increased/decreased, or
 689      always guarded by UNIT_LOCK.  */
 690   int waiting;
 691   /* Flag set by close_unit if the unit as been closed.
 692      Must be manipulated under unit's lock.  */
 693   int closed;
 694
 695   /* For traversing arrays */
 696   array_loop_spec *ls;
 697   int rank;
 698
 699   /* Name of the file at the time OPEN was executed, as a
 700      null-terminated C string.  */
 701   char *filename;
 702
 703   /* The format hash table.  */
 704   struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
 705
 706   /* Formatting buffer.  */
 707   struct fbuf *fbuf;
 708
 709   /* Function pointer, points to list_read worker functions.  */
 710   int (*next_char_fn_ptr) (st_parameter_dt *);
 711   void (*push_char_fn_ptr) (st_parameter_dt *, int);
 712
 713   /* Internal unit char string data.  */
 714   char * internal_unit;
 715   gfc_charlen_type internal_unit_len;
 716   gfc_array_char *string_unit_desc;
 717   int internal_unit_kind;
 718
 719   /* DTIO Parent/Child procedure, 0 = parent, >0 = child level.  */
 720   int child_dtio;
 721
 722   /* Used for ungetc() style functionality. Possible values
 723      are an unsigned char, EOF, or EOF - 1 used to mark the
 724      field as not valid.  */
 725   int last_char;
 726   bool has_size;
 727   GFC_IO_INT size_used;
 728 }
 729 gfc_unit;
 730
 731 typedef struct gfc_saved_unit
 732 {
 733   GFC_INTEGER_4 unit_number;
 734   gfc_unit *unit;
 735 }
 736 gfc_saved_unit;
 737
 738 /* TEMP_FAILURE_RETRY macro from glibc.  */
 739
 740 #ifndef TEMP_FAILURE_RETRY
 741 /* Evaluate EXPRESSION, and repeat as long as it returns -1 with `errno'
 742    set to EINTR.  */
 743
 744 # define TEMP_FAILURE_RETRY(expression) \
 745   (__extension__                                                              \
 746     ({ long int __result;                                                     \
 747        do __result = (long int) (expression);                                 \
 748        while (__result == -1L && errno == EINTR);                             \
 749        __result; }))
 750 #endif
 751
 752
 753 /* unit.c */
 754
 755 /* Maximum file offset, computed at library initialization time.  */
 756 extern gfc_offset max_offset;
 757 internal_proto(max_offset);
 758
 759 /* Default RECL for sequential access if not given in OPEN statement,
 760    computed at library initialization time.  */
 761 extern gfc_offset default_recl;
 762 internal_proto(default_recl);
 763
 764 /* Unit tree root.  */
 765 extern gfc_unit *unit_root;
 766 internal_proto(unit_root);
 767
 768 extern __gthread_mutex_t unit_lock;
 769 internal_proto(unit_lock);
 770
 771 extern int close_unit (gfc_unit *);
 772 internal_proto(close_unit);
 773
 774 extern gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int);
 775 internal_proto(set_internal_unit);
 776
 777 extern void stash_internal_unit (st_parameter_dt *);
 778 internal_proto(stash_internal_unit);
 779
 780 extern gfc_unit *find_unit (int);
 781 internal_proto(find_unit);
 782
 783 extern gfc_unit *find_or_create_unit (int);
 784 internal_proto(find_or_create_unit);
 785
 786 extern gfc_unit *get_unit (st_parameter_dt *, int);
 787 internal_proto(get_unit);
 788
 789 extern void unlock_unit(gfc_unit *);
 790 internal_proto(unlock_unit);
 791
 792 extern void finish_last_advance_record (gfc_unit *u);
 793 internal_proto(finish_last_advance_record);
 794
 795 extern int unit_truncate(gfc_unit *, gfc_offset, st_parameter_common *);
 796 internal_proto(unit_truncate);
 797
 798 extern int newunit_alloc (void);
 799 internal_proto(newunit_alloc);
 800
 801 extern void newunit_free (int);
 802 internal_proto(newunit_free);
 803
 804
 805 /* open.c */
 806
 807 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
 808 internal_proto(new_unit);
 809
 810
 811 /* transfer.c */
 812
 813 #define SCRATCH_SIZE 300
 814
 815 extern const char *type_name (bt);
 816 internal_proto(type_name);
 817
 818 extern void * read_block_form (st_parameter_dt *, size_t *);
 819 internal_proto(read_block_form);
 820
 821 extern void * read_block_form4 (st_parameter_dt *, size_t *);
 822 internal_proto(read_block_form4);
 823
 824 extern void *write_block (st_parameter_dt *, size_t);
 825 internal_proto(write_block);
 826
 827 extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *,
 828                                      int*);
 829 internal_proto(next_array_record);
 830
 831 extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *,
 832                                   gfc_offset *);
 833 internal_proto(init_loop_spec);
 834
 835 extern void next_record (st_parameter_dt *, int);
 836 internal_proto(next_record);
 837
 838 extern void st_wait (st_parameter_wait *);
 839 export_proto (st_wait);
 840
 841 extern void st_wait_async (st_parameter_wait *);
 842 export_proto (st_wait_async);
 843
 844 extern void hit_eof (st_parameter_dt *);
 845 internal_proto(hit_eof);
 846
 847 extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int,
 848                                   gfc_charlen_type);
 849 internal_proto (transfer_array_inner);
 850
 851 /* read.c */
 852
 853 extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
 854 internal_proto(set_integer);
 855
 856 extern GFC_UINTEGER_LARGEST si_max (int);
 857 internal_proto(si_max);
 858
 859 extern int convert_real (st_parameter_dt *, void *, const char *, int);
 860 internal_proto(convert_real);
 861
 862 extern int convert_infnan (st_parameter_dt *, void *, const char *, int);
 863 internal_proto(convert_infnan);
 864
 865 extern void read_a (st_parameter_dt *, const fnode *, char *, size_t);
 866 internal_proto(read_a);
 867
 868 extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, size_t);
 869 internal_proto(read_a);
 870
 871 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
 872 internal_proto(read_f);
 873
 874 extern void read_l (st_parameter_dt *, const fnode *, char *, int);
 875 internal_proto(read_l);
 876
 877 extern void read_x (st_parameter_dt *, size_t);
 878 internal_proto(read_x);
 879
 880 extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
 881 internal_proto(read_radix);
 882
 883 extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
 884 internal_proto(read_decimal);
 885
 886 extern void read_user_defined (st_parameter_dt *, void *);
 887 internal_proto(read_user_defined);
 888
 889 extern void read_user_defined (st_parameter_dt *, void *);
 890 internal_proto(read_user_defined);
 891
 892 /* list_read.c */
 893
 894 extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
 895                                  size_t);
 896 internal_proto(list_formatted_read);
 897
 898 extern void finish_list_read (st_parameter_dt *);
 899 internal_proto(finish_list_read);
 900
 901 extern void namelist_read (st_parameter_dt *);
 902 internal_proto(namelist_read);
 903
 904 extern void namelist_write (st_parameter_dt *);
 905 internal_proto(namelist_write);
 906
 907 /* write.c */
 908
 909 extern void write_a (st_parameter_dt *, const fnode *, const char *, size_t);
 910 internal_proto(write_a);
 911
 912 extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, size_t);
 913 internal_proto(write_a_char4);
 914
 915 extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
 916 internal_proto(write_b);
 917
 918 extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
 919 internal_proto(write_d);
 920
 921 extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
 922 internal_proto(write_e);
 923
 924 extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
 925 internal_proto(write_en);
 926
 927 extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
 928 internal_proto(write_es);
 929
 930 extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
 931 internal_proto(write_f);
 932
 933 extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
 934 internal_proto(write_i);
 935
 936 extern void write_l (st_parameter_dt *, const fnode *, char *, int);
 937 internal_proto(write_l);
 938
 939 extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
 940 internal_proto(write_o);
 941
 942 extern void write_real (st_parameter_dt *, const char *, int);
 943 internal_proto(write_real);
 944
 945 extern void write_real_w0 (st_parameter_dt *, const char *, int, format_token, int);
 946 internal_proto(write_real_w0);
 947
 948 extern void write_x (st_parameter_dt *, int, int);
 949 internal_proto(write_x);
 950
 951 extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
 952 internal_proto(write_z);
 953
 954 extern void write_user_defined (st_parameter_dt *, void *);
 955 internal_proto(write_user_defined);
 956
 957 extern void write_user_defined (st_parameter_dt *, void *);
 958 internal_proto(write_user_defined);
 959
 960 extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
 961                                   size_t);
 962 internal_proto(list_formatted_write);
 963
 964 /* size_from_kind.c */
 965 extern size_t size_from_real_kind (int);
 966 internal_proto(size_from_real_kind);
 967
 968 extern size_t size_from_complex_kind (int);
 969 internal_proto(size_from_complex_kind);
 970
 971
 972 /* lock.c */
 973 extern void free_ionml (st_parameter_dt *);
 974 internal_proto(free_ionml);
 975
 976 static inline void
 977 inc_waiting_locked (gfc_unit *u)
 978 {
 979 #ifdef HAVE_ATOMIC_FETCH_ADD
 980   (void) __atomic_fetch_add (&u->waiting, 1, __ATOMIC_RELAXED);
 981 #else
 982   u->waiting++;
 983 #endif
 984 }
 985
 986 static inline int
 987 predec_waiting_locked (gfc_unit *u)
 988 {
 989 #ifdef HAVE_ATOMIC_FETCH_ADD
 990   /* Note that the pattern
 991
 992      if (predec_waiting_locked (u) == 0)
 993          // destroy u
 994
 995      could be further optimized by making this be an __ATOMIC_RELEASE,
 996      and then inserting a
 997
 998      __atomic_thread_fence (__ATOMIC_ACQUIRE);
 999
1000      inside the branch before destroying.  But for now, lets keep it
1001      simple.  */
1002   return __atomic_add_fetch (&u->waiting, -1, __ATOMIC_ACQ_REL);
1003 #else
1004   return --u->waiting;
1005 #endif
1006 }
1007
1008 static inline void
1009 dec_waiting_unlocked (gfc_unit *u)
1010 {
1011 #ifdef HAVE_ATOMIC_FETCH_ADD
1012   (void) __atomic_fetch_add (&u->waiting, -1, __ATOMIC_RELAXED);
1013 #else
1014   __gthread_mutex_lock (&unit_lock);
1015   u->waiting--;
1016   __gthread_mutex_unlock (&unit_lock);
1017 #endif
1018 }
1019
1020
1021 static inline void
1022 memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
1023 {
1024   int j;
1025   for (j = 0; j < k; j++)
1026     *p++ = c;
1027 }
1028
1029 /* Used in width fields to indicate that the default should be used */
1030 #define DEFAULT_WIDTH -1
1031
1032 /* Defaults for certain format field descriptors. These are decided based on
1033  * the type of the value being formatted.
1034  *
1035  * The behaviour here is modelled on the Oracle Fortran compiler. At the time
1036  * of writing, the details were available at this URL:
1037  *
1038  *   https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d
1039  */
1040
1041 static inline int
1042 default_width_for_integer (int kind)
1043 {
1044   switch (kind)
1045     {
1046     case 1:
1047     case 2:  return  7;
1048     case 4:  return 12;
1049     case 8:  return 23;
1050     case 16: return 44;
1051     default: return  0;
1052     }
1053 }
1054
1055 static inline int
1056 default_width_for_float (int kind)
1057 {
1058   switch (kind)
1059     {
1060     case 4:  return 15;
1061     case 8:  return 25;
1062     case 16: return 42;
1063     default: return  0;
1064     }
1065 }
1066
1067 static inline int
1068 default_precision_for_float (int kind)
1069 {
1070   switch (kind)
1071     {
1072     case 4:  return 7;
1073     case 8:  return 16;
1074     case 16: return 33;
1075     default: return 0;
1076     }
1077 }
1078
1079 #endif
1080
1081 extern void
1082 st_write_done_worker (st_parameter_dt *);
1083 internal_proto (st_write_done_worker);
1084
1085 extern void
1086 st_read_done_worker (st_parameter_dt *);
1087 internal_proto (st_read_done_worker);
1088
1089 extern void
1090 data_transfer_init_worker (st_parameter_dt *, int);
1091 internal_proto (data_transfer_init_worker);