libgfortran/io/io.h

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
   2    Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4    F2003 I/O support contributed by Jerry DeLisle
   5
   6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 Libgfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with Libgfortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  21 Boston, MA 02110-1301, USA.  */
  22
  23 /* As a special exception, if you link this library with other files,
  24    some of which are compiled with GCC, to produce an executable,
  25    this library does not by itself cause the resulting executable
  26    to be covered by the GNU General Public License.
  27    This exception does not however invalidate any other reasons why
  28    the executable file might be covered by the GNU General Public License.  */
  29
  30 #ifndef GFOR_IO_H
  31 #define GFOR_IO_H
  32
  33 /* IO library include.  */
  34
  35 #include "libgfortran.h"
  36
  37 #include <setjmp.h>
  38 #include <gthr.h>
  39
  40 /* Basic types used in data transfers.  */
  41
  42 typedef enum
  43 { BT_NULL, BT_INTEGER, BT_LOGICAL, BT_CHARACTER, BT_REAL,
  44   BT_COMPLEX
  45 }
  46 bt;
  47
  48 struct st_parameter_dt;
  49
  50 typedef struct stream
  51 {
  52   char *(*alloc_w_at) (struct stream *, int *);
  53   try (*sfree) (struct stream *);
  54   try (*close) (struct stream *);
  55   try (*seek) (struct stream *, gfc_offset);
  56   try (*trunc) (struct stream *);
  57   int (*read) (struct stream *, void *, size_t *);
  58   int (*write) (struct stream *, const void *, size_t *);
  59   try (*set) (struct stream *, int, size_t);
  60 }
  61 stream;
  62
  63 typedef enum
  64 { SYNC_BUFFERED, SYNC_UNBUFFERED, ASYNC }
  65 io_mode;
  66
  67 /* Macros for doing file I/O given a stream.  */
  68
  69 #define sfree(s) ((s)->sfree)(s)
  70 #define sclose(s) ((s)->close)(s)
  71
  72 #define salloc_w(s, len) ((s)->alloc_w_at)(s, len)
  73
  74 #define sseek(s, pos) ((s)->seek)(s, pos)
  75 #define struncate(s) ((s)->trunc)(s)
  76 #define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
  77 #define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
  78
  79 #define sset(s, c, n) ((s)->set)(s, c, n)
  80
  81 /* Macros for testing what kinds of I/O we are doing.  */
  82
  83 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
  84
  85 #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
  86
  87 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
  88
  89 /* The array_loop_spec contains the variables for the loops over index ranges
  90    that are encountered.  Since the variables can be negative, ssize_t
  91    is used.  */
  92
  93 typedef struct array_loop_spec
  94 {
  95   /* Index counter for this dimension.  */
  96   ssize_t idx;
  97
  98   /* Start for the index counter.  */
  99   ssize_t start;
 100
 101   /* End for the index counter.  */
 102   ssize_t end;
 103
 104   /* Step for the index counter.  */
 105   ssize_t step;
 106 }
 107 array_loop_spec;
 108
 109 /* Representation of a namelist object in libgfortran
 110
 111    Namelist Records
 112       &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]].../
 113      or
 114       &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]]...&END
 115
 116    The object can be a fully qualified, compound name for an intrinsic
 117    type, derived types or derived type components.  So, a substring
 118    a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
 119    read. Hence full information about the structure of the object has
 120    to be available to list_read.c and write.
 121
 122    These requirements are met by the following data structures.
 123
 124    namelist_info type contains all the scalar information about the
 125    object and arrays of descriptor_dimension and array_loop_spec types for
 126    arrays.  */
 127
 128 typedef struct namelist_type
 129 {
 130
 131   /* Object type, stored as GFC_DTYPE_xxxx.  */
 132   bt type;
 133
 134   /* Object name.  */
 135   char * var_name;
 136
 137   /* Address for the start of the object's data.  */
 138   void * mem_pos;
 139
 140   /* Flag to show that a read is to be attempted for this node.  */
 141   int touched;
 142
 143   /* Length of intrinsic type in bytes.  */
 144   int len;
 145
 146   /* Rank of the object.  */
 147   int var_rank;
 148
 149   /* Overall size of the object in bytes.  */
 150   index_type size;
 151
 152   /* Length of character string.  */
 153   index_type string_length;
 154
 155   descriptor_dimension * dim;
 156   array_loop_spec * ls;
 157   struct namelist_type * next;
 158 }
 159 namelist_info;
 160
 161 /* Options for the OPEN statement.  */
 162
 163 typedef enum
 164 { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM,
 165   ACCESS_UNSPECIFIED
 166 }
 167 unit_access;
 168
 169 typedef enum
 170 { ACTION_READ, ACTION_WRITE, ACTION_READWRITE,
 171   ACTION_UNSPECIFIED
 172 }
 173 unit_action;
 174
 175 typedef enum
 176 { BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED }
 177 unit_blank;
 178
 179 typedef enum
 180 { DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE,
 181   DELIM_UNSPECIFIED
 182 }
 183 unit_delim;
 184
 185 typedef enum
 186 { FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED }
 187 unit_form;
 188
 189 typedef enum
 190 { POSITION_ASIS, POSITION_REWIND, POSITION_APPEND,
 191   POSITION_UNSPECIFIED
 192 }
 193 unit_position;
 194
 195 typedef enum
 196 { STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH,
 197   STATUS_REPLACE, STATUS_UNSPECIFIED
 198 }
 199 unit_status;
 200
 201 typedef enum
 202 { PAD_YES, PAD_NO, PAD_UNSPECIFIED }
 203 unit_pad;
 204
 205 typedef enum
 206 { DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
 207 unit_decimal;
 208
 209 typedef enum
 210 { ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
 211 unit_encoding;
 212
 213 typedef enum
 214 { ROUND_UP, ROUND_DOWN, ROUND_ZERO, ROUND_NEAREST, ROUND_COMPATIBLE,
 215   ROUND_PROCDEFINED, ROUND_UNSPECIFIED }
 216 unit_round;
 217
 218 /* NOTE: unit_sign must correspond with the sign_status enumerator in
 219    st_parameter_dt to not break the ABI.  */
 220 typedef enum
 221 { SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
 222 unit_sign;
 223
 224 typedef enum
 225 { ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
 226 unit_advance;
 227
 228 typedef enum
 229 {READING, WRITING}
 230 unit_mode;
 231
 232 typedef enum
 233 { ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
 234 unit_async;
 235
 236 typedef enum
 237 { SIGN_S, SIGN_SS, SIGN_SP }
 238 unit_sign_s;
 239
 240 #define CHARACTER1(name) \
 241               char * name; \
 242               gfc_charlen_type name ## _len
 243 #define CHARACTER2(name) \
 244               gfc_charlen_type name ## _len; \
 245               char * name
 246
 247 typedef struct
 248 {
 249   st_parameter_common common;
 250   GFC_INTEGER_4 recl_in;
 251   CHARACTER2 (file);
 252   CHARACTER1 (status);
 253   CHARACTER2 (access);
 254   CHARACTER1 (form);
 255   CHARACTER2 (blank);
 256   CHARACTER1 (position);
 257   CHARACTER2 (action);
 258   CHARACTER1 (delim);
 259   CHARACTER2 (pad);
 260   CHARACTER1 (convert);
 261   CHARACTER2 (decimal);
 262   CHARACTER1 (encoding);
 263   CHARACTER2 (round);
 264   CHARACTER1 (sign);
 265   CHARACTER2 (asynchronous);
 266 }
 267 st_parameter_open;
 268
 269 #define IOPARM_CLOSE_HAS_STATUS         (1 << 7)
 270
 271 typedef struct
 272 {
 273   st_parameter_common common;
 274   CHARACTER1 (status);
 275 }
 276 st_parameter_close;
 277
 278 typedef struct
 279 {
 280   st_parameter_common common;
 281 }
 282 st_parameter_filepos;
 283
 284 #define IOPARM_INQUIRE_HAS_EXIST        (1 << 7)
 285 #define IOPARM_INQUIRE_HAS_OPENED       (1 << 8)
 286 #define IOPARM_INQUIRE_HAS_NUMBER       (1 << 9)
 287 #define IOPARM_INQUIRE_HAS_NAMED        (1 << 10)
 288 #define IOPARM_INQUIRE_HAS_NEXTREC      (1 << 11)
 289 #define IOPARM_INQUIRE_HAS_RECL_OUT     (1 << 12)
 290 #define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 13)
 291 #define IOPARM_INQUIRE_HAS_FILE         (1 << 14)
 292 #define IOPARM_INQUIRE_HAS_ACCESS       (1 << 15)
 293 #define IOPARM_INQUIRE_HAS_FORM         (1 << 16)
 294 #define IOPARM_INQUIRE_HAS_BLANK        (1 << 17)
 295 #define IOPARM_INQUIRE_HAS_POSITION     (1 << 18)
 296 #define IOPARM_INQUIRE_HAS_ACTION       (1 << 19)
 297 #define IOPARM_INQUIRE_HAS_DELIM        (1 << 20)
 298 #define IOPARM_INQUIRE_HAS_PAD          (1 << 21)
 299 #define IOPARM_INQUIRE_HAS_NAME         (1 << 22)
 300 #define IOPARM_INQUIRE_HAS_SEQUENTIAL   (1 << 23)
 301 #define IOPARM_INQUIRE_HAS_DIRECT       (1 << 24)
 302 #define IOPARM_INQUIRE_HAS_FORMATTED    (1 << 25)
 303 #define IOPARM_INQUIRE_HAS_UNFORMATTED  (1 << 26)
 304 #define IOPARM_INQUIRE_HAS_READ         (1 << 27)
 305 #define IOPARM_INQUIRE_HAS_WRITE        (1 << 28)
 306 #define IOPARM_INQUIRE_HAS_READWRITE    (1 << 29)
 307 #define IOPARM_INQUIRE_HAS_CONVERT      (1 << 30)
 308 #define IOPARM_INQUIRE_HAS_FLAGS2       (1 << 31)
 309
 310 #define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0)
 311 #define IOPARM_INQUIRE_HAS_DECIMAL      (1 << 1)
 312 #define IOPARM_INQUIRE_HAS_ENCODING     (1 << 2)
 313 #define IOPARM_INQUIRE_HAS_PENDING      (1 << 3)
 314 #define IOPARM_INQUIRE_HAS_ROUND        (1 << 4)
 315 #define IOPARM_INQUIRE_HAS_SIGN         (1 << 5)
 316 #define IOPARM_INQUIRE_HAS_SIZE         (1 << 6)
 317 #define IOPARM_INQUIRE_HAS_ID           (1 << 7)
 318
 319 typedef struct
 320 {
 321   st_parameter_common common;
 322   GFC_INTEGER_4 *exist, *opened, *number, *named;
 323   GFC_INTEGER_4 *nextrec, *recl_out;
 324   GFC_IO_INT *strm_pos_out;
 325   CHARACTER1 (file);
 326   CHARACTER2 (access);
 327   CHARACTER1 (form);
 328   CHARACTER2 (blank);
 329   CHARACTER1 (position);
 330   CHARACTER2 (action);
 331   CHARACTER1 (delim);
 332   CHARACTER2 (pad);
 333   CHARACTER1 (name);
 334   CHARACTER2 (sequential);
 335   CHARACTER1 (direct);
 336   CHARACTER2 (formatted);
 337   CHARACTER1 (unformatted);
 338   CHARACTER2 (read);
 339   CHARACTER1 (write);
 340   CHARACTER2 (readwrite);
 341   CHARACTER1 (convert);
 342   GFC_INTEGER_4 flags2;
 343   CHARACTER1 (asynchronous);
 344   CHARACTER2 (decimal);
 345   CHARACTER1 (encoding);
 346   CHARACTER2 (pending);
 347   CHARACTER1 (round);
 348   CHARACTER2 (sign);
 349   GFC_INTEGER_4 *size;
 350   GFC_INTEGER_4 *id;
 351 }
 352 st_parameter_inquire;
 353
 354 struct gfc_unit;
 355 struct format_data;
 356
 357 #define IOPARM_DT_LIST_FORMAT                   (1 << 7)
 358 #define IOPARM_DT_NAMELIST_READ_MODE            (1 << 8)
 359 #define IOPARM_DT_HAS_REC                       (1 << 9)
 360 #define IOPARM_DT_HAS_SIZE                      (1 << 10)
 361 #define IOPARM_DT_HAS_IOLENGTH                  (1 << 11)
 362 #define IOPARM_DT_HAS_FORMAT                    (1 << 12)
 363 #define IOPARM_DT_HAS_ADVANCE                   (1 << 13)
 364 #define IOPARM_DT_HAS_INTERNAL_UNIT             (1 << 14)
 365 #define IOPARM_DT_HAS_NAMELIST_NAME             (1 << 15)
 366 #define IOPARM_DT_HAS_ID                        (1 << 16)
 367 #define IOPARM_DT_HAS_POS                       (1 << 17)
 368 #define IOPARM_DT_HAS_ASYNCHRONOUS              (1 << 18)
 369 #define IOPARM_DT_HAS_BLANK                     (1 << 19)
 370 #define IOPARM_DT_HAS_DECIMAL                   (1 << 20)
 371 #define IOPARM_DT_HAS_DELIM                     (1 << 21)
 372 #define IOPARM_DT_HAS_PAD                       (1 << 22)
 373 #define IOPARM_DT_HAS_ROUND                     (1 << 23)
 374 #define IOPARM_DT_HAS_SIGN                      (1 << 24)
 375 #define IOPARM_DT_HAS_F2003                     (1 << 25)
 376 /* Internal use bit.  */
 377 #define IOPARM_DT_IONML_SET                     (1 << 31)
 378
 379
 380 typedef struct st_parameter_43
 381 {
 382   void (*transfer) (struct st_parameter_dt *, bt, void *, int,
 383                     size_t, size_t);
 384   struct gfc_unit *current_unit;
 385   /* Item number in a formatted data transfer.  Also used in namelist
 386      read_logical as an index into line_buffer.  */
 387   int item_count;
 388   unit_mode mode;
 389   unit_blank blank_status;
 390   unit_sign sign_status;
 391   int scale_factor;
 392   int max_pos; /* Maximum righthand column written to.  */
 393   /* Number of skips + spaces to be done for T and X-editing.  */
 394   int skips;
 395   /* Number of spaces to be done for T and X-editing.  */
 396   int pending_spaces;
 397   /* Whether an EOR condition was encountered. Value is:
 398        0 if no EOR was encountered
 399        1 if an EOR was encountered due to a 1-byte marker (LF)
 400        2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
 401   int sf_seen_eor;
 402   unit_advance advance_status;
 403   unsigned reversion_flag : 1; /* Format reversion has occurred.  */
 404   unsigned first_item : 1;
 405   unsigned seen_dollar : 1;
 406   unsigned eor_condition : 1;
 407   unsigned no_leading_blank : 1;
 408   unsigned char_flag : 1;
 409   unsigned input_complete : 1;
 410   unsigned at_eol : 1;
 411   unsigned comma_flag : 1;
 412   /* A namelist specific flag used in the list directed library
 413      to flag that calls are being made from namelist read (eg. to
 414      ignore comments or to treat '/' as a terminator)  */
 415   unsigned namelist_mode : 1;
 416   /* A namelist specific flag used in the list directed library
 417      to flag read errors and return, so that an attempt can be
 418      made to read a new object name.  */
 419   unsigned nml_read_error : 1;
 420   /* A sequential formatted read specific flag used to signal that a
 421      character string is being read so don't use commas to shorten a
 422      formatted field width.  */
 423   unsigned sf_read_comma : 1;
 424   /* A namelist specific flag used to enable reading input from
 425      line_buffer for logical reads.  */
 426   unsigned line_buffer_enabled : 1;
 427   /* An internal unit specific flag used to identify that the associated
 428      unit is internal.  */
 429   unsigned unit_is_internal : 1;
 430   /* An internal unit specific flag to signify an EOF condition for list
 431      directed read.  */
 432   unsigned at_eof : 1;
 433   /* 16 unused bits.  */
 434
 435   char last_char;
 436   char nml_delim;
 437
 438   int repeat_count;
 439   int saved_length;
 440   int saved_used;
 441   bt saved_type;
 442   char *saved_string;
 443   char *scratch;
 444   char *line_buffer;
 445   struct format_data *fmt;
 446   jmp_buf *eof_jump;
 447   namelist_info *ionml;
 448   /* A flag used to identify when a non-standard expanded namelist read
 449      has occurred.  */
 450   int expanded_read;
 451   /* Storage area for values except for strings.  Must be large
 452      enough to hold a complex value (two reals) of the largest
 453      kind.  */
 454   char value[32];
 455   gfc_offset size_used;
 456 } st_parameter_43;
 457
 458
 459 typedef struct st_parameter_44
 460 {
 461   GFC_IO_INT *id;
 462   GFC_IO_INT pos;
 463   CHARACTER1 (asynchronous);
 464   CHARACTER2 (blank);
 465   CHARACTER1 (decimal);
 466   CHARACTER2 (delim);
 467   CHARACTER1 (pad);
 468   CHARACTER2 (round);
 469   CHARACTER1 (sign);
 470   void (*transfer) (struct st_parameter_dt *, bt, void *, int,
 471                     size_t, size_t);
 472   struct gfc_unit *current_unit;
 473   /* Item number in a formatted data transfer.  Also used in namelist
 474      read_logical as an index into line_buffer.  */
 475   int item_count;
 476   unit_mode mode;
 477   unit_blank blank_status;
 478   unit_sign sign_status;
 479   int scale_factor;
 480   int max_pos; /* Maximum righthand column written to.  */
 481   /* Number of skips + spaces to be done for T and X-editing.  */
 482   int skips;
 483   /* Number of spaces to be done for T and X-editing.  */
 484   int pending_spaces;
 485   /* Whether an EOR condition was encountered. Value is:
 486        0 if no EOR was encountered
 487        1 if an EOR was encountered due to a 1-byte marker (LF)
 488        2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
 489   int sf_seen_eor;
 490   unit_advance advance_status;
 491   unsigned reversion_flag : 1; /* Format reversion has occurred.  */
 492   unsigned first_item : 1;
 493   unsigned seen_dollar : 1;
 494   unsigned eor_condition : 1;
 495   unsigned no_leading_blank : 1;
 496   unsigned char_flag : 1;
 497   unsigned input_complete : 1;
 498   unsigned at_eol : 1;
 499   unsigned comma_flag : 1;
 500   /* A namelist specific flag used in the list directed library
 501      to flag that calls are being made from namelist read (eg. to
 502      ignore comments or to treat '/' as a terminator)  */
 503   unsigned namelist_mode : 1;
 504   /* A namelist specific flag used in the list directed library
 505      to flag read errors and return, so that an attempt can be
 506      made to read a new object name.  */
 507   unsigned nml_read_error : 1;
 508   /* A sequential formatted read specific flag used to signal that a
 509      character string is being read so don't use commas to shorten a
 510      formatted field width.  */
 511   unsigned sf_read_comma : 1;
 512   /* A namelist specific flag used to enable reading input from
 513      line_buffer for logical reads.  */
 514   unsigned line_buffer_enabled : 1;
 515   /* An internal unit specific flag used to identify that the associated
 516      unit is internal.  */
 517   unsigned unit_is_internal : 1;
 518   /* An internal unit specific flag to signify an EOF condition for list
 519      directed read.  */
 520   unsigned at_eof : 1;
 521   /* 16 unused bits.  */
 522
 523   char last_char;
 524   char nml_delim;
 525
 526   int repeat_count;
 527   int saved_length;
 528   int saved_used;
 529   bt saved_type;
 530   char *saved_string;
 531   char *scratch;
 532   char *line_buffer;
 533   struct format_data *fmt;
 534   jmp_buf *eof_jump;
 535   namelist_info *ionml;
 536   /* A flag used to identify when a non-standard expanded namelist read
 537      has occurred.  */
 538   int expanded_read;
 539   /* Storage area for values except for strings.  Must be large
 540      enough to hold a complex value (two reals) of the largest
 541      kind.  */
 542   char value[32];
 543   gfc_offset size_used;
 544   unit_pad pad_status;
 545   unit_decimal decimal_status;
 546   unit_delim delim_status;
 547 } st_parameter_44;
 548
 549 typedef struct st_parameter_dt
 550 {
 551   st_parameter_common common;
 552   GFC_IO_INT rec;
 553   GFC_IO_INT *size, *iolength;
 554   gfc_array_char *internal_unit_desc;
 555   CHARACTER1 (format);
 556   CHARACTER2 (advance);
 557   CHARACTER1 (internal_unit);
 558   CHARACTER2 (namelist_name);
 559   /* Private part of the structure.  The compiler just needs
 560      to reserve enough space.  */
 561   union
 562     {
 563       st_parameter_43 q;
 564       st_parameter_44 p;
 565       /* This pad size must be equal to the pad_size declared in
 566          trans-io.c (gfc_build_io_library_fndecls).  The above structure
 567          must be smaller or equal to this array.  */
 568       char pad[32 * sizeof (char *) + 32 * sizeof (int)];
 569     } u;
 570 }
 571 st_parameter_dt;
 572
 573 /* Ensure st_parameter_dt's u.pad is bigger or equal to u.p.  */
 574 extern char check_st_parameter_dt[sizeof (((st_parameter_dt *) 0)->u.pad)
 575                                   >= sizeof (((st_parameter_dt *) 0)->u.p)
 576                                   ? 1 : -1];
 577
 578 #define IOPARM_WAIT_HAS_ID              (1 << 7)
 579
 580 typedef struct
 581 {
 582   st_parameter_common common;
 583   CHARACTER1 (id);
 584 }
 585 st_parameter_wait;
 586
 587
 588 #undef CHARACTER1
 589 #undef CHARACTER2
 590
 591 typedef struct
 592 {
 593   unit_access access;
 594   unit_action action;
 595   unit_blank blank;
 596   unit_delim delim;
 597   unit_form form;
 598   int is_notpadded;
 599   unit_position position;
 600   unit_status status;
 601   unit_pad pad;
 602   unit_convert convert;
 603   int has_recl;
 604   unit_decimal decimal;
 605   unit_encoding encoding;
 606   unit_round round;
 607   unit_sign sign;
 608   unit_async async;
 609 }
 610 unit_flags;
 611
 612
 613 /* Formatting buffer. This is a temporary scratch buffer. Currently used only
 614    by formatted writes. After every
 615    formatted write statement, this buffer is flushed. This buffer is needed since
 616    not all devices are seekable, and T or TL edit descriptors require
 617    moving backwards in the record.  However, advance='no' complicates the
 618    situation, so the buffer must only be partially flushed from the end of the
 619    last flush until the current position in the record. */
 620
 621 typedef struct fbuf
 622 {
 623   char *buf;                    /* Start of buffer.  */
 624   size_t len;                   /* Length of buffer.  */
 625   size_t act;                   /* Active bytes in buffer.  */
 626   size_t flushed;               /* Flushed bytes from beginning of buffer.  */
 627   size_t pos;                   /* Current position in buffer.  */
 628 }
 629 fbuf;
 630
 631
 632 typedef struct gfc_unit
 633 {
 634   int unit_number;
 635   stream *s;
 636
 637   /* Treap links.  */
 638   struct gfc_unit *left, *right;
 639   int priority;
 640
 641   int read_bad, current_record, saved_pos, previous_nonadvancing_write;
 642
 643   enum
 644   { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
 645   endfile;
 646
 647   unit_mode mode;
 648   unit_flags flags;
 649
 650   /* recl                 -- Record length of the file.
 651      last_record          -- Last record number read or written
 652      maxrec               -- Maximum record number in a direct access file
 653      bytes_left           -- Bytes left in current record.
 654      strm_pos             -- Current position in file for STREAM I/O.
 655      recl_subrecord       -- Maximum length for subrecord.
 656      bytes_left_subrecord -- Bytes left in current subrecord.  */
 657   gfc_offset recl, last_record, maxrec, bytes_left, strm_pos,
 658     recl_subrecord, bytes_left_subrecord;
 659
 660   /* Set to 1 if we have read a subrecord.  */
 661
 662   int continued;
 663
 664   __gthread_mutex_t lock;
 665   /* Number of threads waiting to acquire this unit's lock.
 666      When non-zero, close_unit doesn't only removes the unit
 667      from the UNIT_ROOT tree, but doesn't free it and the
 668      last of the waiting threads will do that.
 669      This must be either atomically increased/decreased, or
 670      always guarded by UNIT_LOCK.  */
 671   int waiting;
 672   /* Flag set by close_unit if the unit as been closed.
 673      Must be manipulated under unit's lock.  */
 674   int closed;
 675
 676   /* For traversing arrays */
 677   array_loop_spec *ls;
 678   int rank;
 679
 680   int file_len;
 681   char *file;
 682
 683   /* Formatting buffer.  */
 684   struct fbuf *fbuf;
 685 }
 686 gfc_unit;
 687
 688 /* Format tokens.  Only about half of these can be stored in the
 689    format nodes.  */
 690
 691 typedef enum
 692 {
 693   FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
 694   FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
 695   FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
 696   FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
 697   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
 698   FMT_DP
 699 }
 700 format_token;
 701
 702
 703 /* Format nodes.  A format string is converted into a tree of these
 704    structures, which is traversed as part of a data transfer statement.  */
 705
 706 typedef struct fnode
 707 {
 708   format_token format;
 709   int repeat;
 710   struct fnode *next;
 711   char *source;
 712
 713   union
 714   {
 715     struct
 716     {
 717       int w, d, e;
 718     }
 719     real;
 720
 721     struct
 722     {
 723       int length;
 724       char *p;
 725     }
 726     string;
 727
 728     struct
 729     {
 730       int w, m;
 731     }
 732     integer;
 733
 734     int w;
 735     int k;
 736     int r;
 737     int n;
 738
 739     struct fnode *child;
 740   }
 741   u;
 742
 743   /* Members for traversing the tree during data transfer.  */
 744
 745   int count;
 746   struct fnode *current;
 747
 748 }
 749 fnode;
 750
 751
 752 /* unix.c */
 753
 754 extern int move_pos_offset (stream *, int);
 755 internal_proto(move_pos_offset);
 756
 757 extern int compare_files (stream *, stream *);
 758 internal_proto(compare_files);
 759
 760 extern stream *open_external (st_parameter_open *, unit_flags *);
 761 internal_proto(open_external);
 762
 763 extern stream *open_internal (char *, int, gfc_offset);
 764 internal_proto(open_internal);
 765
 766 extern stream *input_stream (void);
 767 internal_proto(input_stream);
 768
 769 extern stream *output_stream (void);
 770 internal_proto(output_stream);
 771
 772 extern stream *error_stream (void);
 773 internal_proto(error_stream);
 774
 775 extern int compare_file_filename (gfc_unit *, const char *, int);
 776 internal_proto(compare_file_filename);
 777
 778 extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
 779 internal_proto(find_file);
 780
 781 extern int stream_at_bof (stream *);
 782 internal_proto(stream_at_bof);
 783
 784 extern int stream_at_eof (stream *);
 785 internal_proto(stream_at_eof);
 786
 787 extern int delete_file (gfc_unit *);
 788 internal_proto(delete_file);
 789
 790 extern int file_exists (const char *file, gfc_charlen_type file_len);
 791 internal_proto(file_exists);
 792
 793 extern const char *inquire_sequential (const char *, int);
 794 internal_proto(inquire_sequential);
 795
 796 extern const char *inquire_direct (const char *, int);
 797 internal_proto(inquire_direct);
 798
 799 extern const char *inquire_formatted (const char *, int);
 800 internal_proto(inquire_formatted);
 801
 802 extern const char *inquire_unformatted (const char *, int);
 803 internal_proto(inquire_unformatted);
 804
 805 extern const char *inquire_read (const char *, int);
 806 internal_proto(inquire_read);
 807
 808 extern const char *inquire_write (const char *, int);
 809 internal_proto(inquire_write);
 810
 811 extern const char *inquire_readwrite (const char *, int);
 812 internal_proto(inquire_readwrite);
 813
 814 extern gfc_offset file_length (stream *);
 815 internal_proto(file_length);
 816
 817 extern gfc_offset file_position (stream *);
 818 internal_proto(file_position);
 819
 820 extern int is_seekable (stream *);
 821 internal_proto(is_seekable);
 822
 823 extern int is_special (stream *);
 824 internal_proto(is_special);
 825
 826 extern int is_preconnected (stream *);
 827 internal_proto(is_preconnected);
 828
 829 extern void flush_if_preconnected (stream *);
 830 internal_proto(flush_if_preconnected);
 831
 832 extern void empty_internal_buffer(stream *);
 833 internal_proto(empty_internal_buffer);
 834
 835 extern try flush (stream *);
 836 internal_proto(flush);
 837
 838 extern int stream_isatty (stream *);
 839 internal_proto(stream_isatty);
 840
 841 extern char * stream_ttyname (stream *);
 842 internal_proto(stream_ttyname);
 843
 844 extern gfc_offset stream_offset (stream *s);
 845 internal_proto(stream_offset);
 846
 847 extern int unpack_filename (char *, const char *, int);
 848 internal_proto(unpack_filename);
 849
 850 /* unit.c */
 851
 852 /* Maximum file offset, computed at library initialization time.  */
 853 extern gfc_offset max_offset;
 854 internal_proto(max_offset);
 855
 856 /* Unit tree root.  */
 857 extern gfc_unit *unit_root;
 858 internal_proto(unit_root);
 859
 860 extern __gthread_mutex_t unit_lock;
 861 internal_proto(unit_lock);
 862
 863 extern int close_unit (gfc_unit *);
 864 internal_proto(close_unit);
 865
 866 extern gfc_unit *get_internal_unit (st_parameter_dt *);
 867 internal_proto(get_internal_unit);
 868
 869 extern void free_internal_unit (st_parameter_dt *);
 870 internal_proto(free_internal_unit);
 871
 872 extern gfc_unit *find_unit (int);
 873 internal_proto(find_unit);
 874
 875 extern gfc_unit *find_or_create_unit (int);
 876 internal_proto(find_or_create_unit);
 877
 878 extern gfc_unit *get_unit (st_parameter_dt *, int);
 879 internal_proto(get_unit);
 880
 881 extern void unlock_unit (gfc_unit *);
 882 internal_proto(unlock_unit);
 883
 884 extern void update_position (gfc_unit *);
 885 internal_proto(update_position);
 886
 887 extern void finish_last_advance_record (gfc_unit *u);
 888 internal_proto (finish_last_advance_record);
 889
 890 /* open.c */
 891
 892 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
 893 internal_proto(new_unit);
 894
 895 /* format.c */
 896
 897 extern void parse_format (st_parameter_dt *);
 898 internal_proto(parse_format);
 899
 900 extern const fnode *next_format (st_parameter_dt *);
 901 internal_proto(next_format);
 902
 903 extern void unget_format (st_parameter_dt *, const fnode *);
 904 internal_proto(unget_format);
 905
 906 extern void format_error (st_parameter_dt *, const fnode *, const char *);
 907 internal_proto(format_error);
 908
 909 extern void free_format_data (st_parameter_dt *);
 910 internal_proto(free_format_data);
 911
 912 /* transfer.c */
 913
 914 #define SCRATCH_SIZE 300
 915
 916 extern const char *type_name (bt);
 917 internal_proto(type_name);
 918
 919 extern try read_block_form (st_parameter_dt *, void *, size_t *);
 920 internal_proto(read_block_form);
 921
 922 extern char *read_sf (st_parameter_dt *, int *, int);
 923 internal_proto(read_sf);
 924
 925 extern void *write_block (st_parameter_dt *, int);
 926 internal_proto(write_block);
 927
 928 extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *,
 929                                      int*);
 930 internal_proto(next_array_record);
 931
 932 extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *,
 933                                   gfc_offset *);
 934 internal_proto(init_loop_spec);
 935
 936 extern void next_record (st_parameter_dt *, int);
 937 internal_proto(next_record);
 938
 939 extern void reverse_memcpy (void *, const void *, size_t);
 940 internal_proto (reverse_memcpy);
 941
 942 extern void st_wait (st_parameter_wait *);
 943 export_proto(st_wait);
 944
 945 /* read.c */
 946
 947 extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
 948 internal_proto(set_integer);
 949
 950 extern GFC_UINTEGER_LARGEST max_value (int, int);
 951 internal_proto(max_value);
 952
 953 extern int convert_real (st_parameter_dt *, void *, const char *, int);
 954 internal_proto(convert_real);
 955
 956 extern void read_a (st_parameter_dt *, const fnode *, char *, int);
 957 internal_proto(read_a);
 958
 959 extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, int);
 960 internal_proto(read_a);
 961
 962 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
 963 internal_proto(read_f);
 964
 965 extern void read_l (st_parameter_dt *, const fnode *, char *, int);
 966 internal_proto(read_l);
 967
 968 extern void read_x (st_parameter_dt *, int);
 969 internal_proto(read_x);
 970
 971 extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
 972 internal_proto(read_radix);
 973
 974 extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
 975 internal_proto(read_decimal);
 976
 977 /* list_read.c */
 978
 979 extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
 980                                  size_t);
 981 internal_proto(list_formatted_read);
 982
 983 extern void finish_list_read (st_parameter_dt *);
 984 internal_proto(finish_list_read);
 985
 986 extern void namelist_read (st_parameter_dt *);
 987 internal_proto(namelist_read);
 988
 989 extern void namelist_write (st_parameter_dt *);
 990 internal_proto(namelist_write);
 991
 992 /* write.c */
 993
 994 extern void write_a (st_parameter_dt *, const fnode *, const char *, int);
 995 internal_proto(write_a);
 996
 997 extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, int);
 998 internal_proto(write_a_char4);
 999
1000 extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
1001 internal_proto(write_b);
1002
1003 extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
1004 internal_proto(write_d);
1005
1006 extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
1007 internal_proto(write_e);
1008
1009 extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
1010 internal_proto(write_en);
1011
1012 extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
1013 internal_proto(write_es);
1014
1015 extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
1016 internal_proto(write_f);
1017
1018 extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
1019 internal_proto(write_i);
1020
1021 extern void write_l (st_parameter_dt *, const fnode *, char *, int);
1022 internal_proto(write_l);
1023
1024 extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
1025 internal_proto(write_o);
1026
1027 extern void write_real (st_parameter_dt *, const char *, int);
1028 internal_proto(write_real);
1029
1030 extern void write_real_g0 (st_parameter_dt *, const char *, int, int);
1031 internal_proto(write_real_g0);
1032
1033 extern void write_x (st_parameter_dt *, int, int);
1034 internal_proto(write_x);
1035
1036 extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
1037 internal_proto(write_z);
1038
1039 extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
1040                                   size_t);
1041 internal_proto(list_formatted_write);
1042
1043 /* size_from_kind.c */
1044 extern size_t size_from_real_kind (int);
1045 internal_proto(size_from_real_kind);
1046
1047 extern size_t size_from_complex_kind (int);
1048 internal_proto(size_from_complex_kind);
1049
1050 /* fbuf.c */
1051 extern void fbuf_init (gfc_unit *, size_t);
1052 internal_proto(fbuf_init);
1053
1054 extern void fbuf_destroy (gfc_unit *);
1055 internal_proto(fbuf_destroy);
1056
1057 extern void fbuf_reset (gfc_unit *);
1058 internal_proto(fbuf_reset);
1059
1060 extern char * fbuf_alloc (gfc_unit *, size_t);
1061 internal_proto(fbuf_alloc);
1062
1063 extern int fbuf_flush (gfc_unit *, int);
1064 internal_proto(fbuf_flush);
1065
1066 extern int fbuf_seek (gfc_unit *, gfc_offset);
1067 internal_proto(fbuf_seek);
1068
1069 /* lock.c */
1070 extern void free_ionml (st_parameter_dt *);
1071 internal_proto(free_ionml);
1072
1073 static inline void
1074 inc_waiting_locked (gfc_unit *u)
1075 {
1076 #ifdef HAVE_SYNC_FETCH_AND_ADD
1077   (void) __sync_fetch_and_add (&u->waiting, 1);
1078 #else
1079   u->waiting++;
1080 #endif
1081 }
1082
1083 static inline int
1084 predec_waiting_locked (gfc_unit *u)
1085 {
1086 #ifdef HAVE_SYNC_FETCH_AND_ADD
1087   return __sync_add_and_fetch (&u->waiting, -1);
1088 #else
1089   return --u->waiting;
1090 #endif
1091 }
1092
1093 static inline void
1094 dec_waiting_unlocked (gfc_unit *u)
1095 {
1096 #ifdef HAVE_SYNC_FETCH_AND_ADD
1097   (void) __sync_fetch_and_add (&u->waiting, -1);
1098 #else
1099   __gthread_mutex_lock (&unit_lock);
1100   u->waiting--;
1101   __gthread_mutex_unlock (&unit_lock);
1102 #endif
1103 }
1104
1105 #endif
1106