1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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 3, or (at your option)
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.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
30 /* IO library include. */
32 #include "libgfortran.h"
37 /* Basic types used in data transfers. */
40 { BT_NULL, BT_INTEGER, BT_LOGICAL, BT_CHARACTER, BT_REAL,
45 /* Forward declarations. */
46 struct st_parameter_dt;
47 typedef struct stream stream;
50 typedef struct fnode fnode;
54 /* Macros for testing what kinds of I/O we are doing. */
56 #define is_array_io(dtp) ((dtp)->internal_unit_desc)
58 #define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal)
60 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
62 #define is_char4_unit(dtp) ((dtp)->u.p.unit_is_internal && (dtp)->common.unit)
64 /* The array_loop_spec contains the variables for the loops over index ranges
65 that are encountered. Since the variables can be negative, ssize_t
68 typedef struct array_loop_spec
70 /* Index counter for this dimension. */
73 /* Start for the index counter. */
76 /* End for the index counter. */
79 /* Step for the index counter. */
84 /* A stucture to build a hash table for format data. */
86 #define FORMAT_HASH_SIZE 16
88 typedef struct format_hash_entry
91 gfc_charlen_type key_len;
92 struct format_data *hashed_fmt;
96 /* Representation of a namelist object in libgfortran
99 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]].../
101 &GROUPNAME OBJECT=value[s] [,OBJECT=value[s]]...&END
103 The object can be a fully qualified, compound name for an intrinsic
104 type, derived types or derived type components. So, a substring
105 a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
106 read. Hence full information about the structure of the object has
107 to be available to list_read.c and write.
109 These requirements are met by the following data structures.
111 namelist_info type contains all the scalar information about the
112 object and arrays of descriptor_dimension and array_loop_spec types for
115 typedef struct namelist_type
117 /* Object type, stored as GFC_DTYPE_xxxx. */
123 /* Address for the start of the object's data. */
126 /* Flag to show that a read is to be attempted for this node. */
129 /* Length of intrinsic type in bytes. */
132 /* Rank of the object. */
135 /* Overall size of the object in bytes. */
138 /* Length of character string. */
139 index_type string_length;
141 descriptor_dimension * dim;
142 array_loop_spec * ls;
143 struct namelist_type * next;
147 /* Options for the OPEN statement. */
150 { ACCESS_SEQUENTIAL, ACCESS_DIRECT, ACCESS_APPEND, ACCESS_STREAM,
156 { ACTION_READ, ACTION_WRITE, ACTION_READWRITE,
162 { BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED }
166 { DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE,
172 { FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED }
176 { POSITION_ASIS, POSITION_REWIND, POSITION_APPEND,
182 { STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH,
183 STATUS_REPLACE, STATUS_UNSPECIFIED
188 { PAD_YES, PAD_NO, PAD_UNSPECIFIED }
192 { DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
196 { ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
200 { ROUND_UP, ROUND_DOWN, ROUND_ZERO, ROUND_NEAREST, ROUND_COMPATIBLE,
201 ROUND_PROCDEFINED, ROUND_UNSPECIFIED }
204 /* NOTE: unit_sign must correspond with the sign_status enumerator in
205 st_parameter_dt to not break the ABI. */
207 { SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
211 { ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
219 { ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
223 { SIGN_S, SIGN_SS, SIGN_SP }
226 #define CHARACTER1(name) \
228 gfc_charlen_type name ## _len
229 #define CHARACTER2(name) \
230 gfc_charlen_type name ## _len; \
235 st_parameter_common common;
236 GFC_INTEGER_4 recl_in;
242 CHARACTER1 (position);
246 CHARACTER1 (convert);
247 CHARACTER2 (decimal);
248 CHARACTER1 (encoding);
251 CHARACTER2 (asynchronous);
252 GFC_INTEGER_4 *newunit;
256 #define IOPARM_CLOSE_HAS_STATUS (1 << 7)
260 st_parameter_common common;
267 st_parameter_common common;
269 st_parameter_filepos;
271 #define IOPARM_INQUIRE_HAS_EXIST (1 << 7)
272 #define IOPARM_INQUIRE_HAS_OPENED (1 << 8)
273 #define IOPARM_INQUIRE_HAS_NUMBER (1 << 9)
274 #define IOPARM_INQUIRE_HAS_NAMED (1 << 10)
275 #define IOPARM_INQUIRE_HAS_NEXTREC (1 << 11)
276 #define IOPARM_INQUIRE_HAS_RECL_OUT (1 << 12)
277 #define IOPARM_INQUIRE_HAS_STRM_POS_OUT (1 << 13)
278 #define IOPARM_INQUIRE_HAS_FILE (1 << 14)
279 #define IOPARM_INQUIRE_HAS_ACCESS (1 << 15)
280 #define IOPARM_INQUIRE_HAS_FORM (1 << 16)
281 #define IOPARM_INQUIRE_HAS_BLANK (1 << 17)
282 #define IOPARM_INQUIRE_HAS_POSITION (1 << 18)
283 #define IOPARM_INQUIRE_HAS_ACTION (1 << 19)
284 #define IOPARM_INQUIRE_HAS_DELIM (1 << 20)
285 #define IOPARM_INQUIRE_HAS_PAD (1 << 21)
286 #define IOPARM_INQUIRE_HAS_NAME (1 << 22)
287 #define IOPARM_INQUIRE_HAS_SEQUENTIAL (1 << 23)
288 #define IOPARM_INQUIRE_HAS_DIRECT (1 << 24)
289 #define IOPARM_INQUIRE_HAS_FORMATTED (1 << 25)
290 #define IOPARM_INQUIRE_HAS_UNFORMATTED (1 << 26)
291 #define IOPARM_INQUIRE_HAS_READ (1 << 27)
292 #define IOPARM_INQUIRE_HAS_WRITE (1 << 28)
293 #define IOPARM_INQUIRE_HAS_READWRITE (1 << 29)
294 #define IOPARM_INQUIRE_HAS_CONVERT (1 << 30)
295 #define IOPARM_INQUIRE_HAS_FLAGS2 (1 << 31)
297 #define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0)
298 #define IOPARM_INQUIRE_HAS_DECIMAL (1 << 1)
299 #define IOPARM_INQUIRE_HAS_ENCODING (1 << 2)
300 #define IOPARM_INQUIRE_HAS_ROUND (1 << 3)
301 #define IOPARM_INQUIRE_HAS_SIGN (1 << 4)
302 #define IOPARM_INQUIRE_HAS_PENDING (1 << 5)
303 #define IOPARM_INQUIRE_HAS_SIZE (1 << 6)
304 #define IOPARM_INQUIRE_HAS_ID (1 << 7)
308 st_parameter_common common;
309 GFC_INTEGER_4 *exist, *opened, *number, *named;
310 GFC_INTEGER_4 *nextrec, *recl_out;
311 GFC_IO_INT *strm_pos_out;
316 CHARACTER1 (position);
321 CHARACTER2 (sequential);
323 CHARACTER2 (formatted);
324 CHARACTER1 (unformatted);
327 CHARACTER2 (readwrite);
328 CHARACTER1 (convert);
329 GFC_INTEGER_4 flags2;
330 CHARACTER1 (asynchronous);
331 CHARACTER2 (decimal);
332 CHARACTER1 (encoding);
335 GFC_INTEGER_4 *pending;
339 st_parameter_inquire;
342 #define IOPARM_DT_LIST_FORMAT (1 << 7)
343 #define IOPARM_DT_NAMELIST_READ_MODE (1 << 8)
344 #define IOPARM_DT_HAS_REC (1 << 9)
345 #define IOPARM_DT_HAS_SIZE (1 << 10)
346 #define IOPARM_DT_HAS_IOLENGTH (1 << 11)
347 #define IOPARM_DT_HAS_FORMAT (1 << 12)
348 #define IOPARM_DT_HAS_ADVANCE (1 << 13)
349 #define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14)
350 #define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15)
351 #define IOPARM_DT_HAS_ID (1 << 16)
352 #define IOPARM_DT_HAS_POS (1 << 17)
353 #define IOPARM_DT_HAS_ASYNCHRONOUS (1 << 18)
354 #define IOPARM_DT_HAS_BLANK (1 << 19)
355 #define IOPARM_DT_HAS_DECIMAL (1 << 20)
356 #define IOPARM_DT_HAS_DELIM (1 << 21)
357 #define IOPARM_DT_HAS_PAD (1 << 22)
358 #define IOPARM_DT_HAS_ROUND (1 << 23)
359 #define IOPARM_DT_HAS_SIGN (1 << 24)
360 #define IOPARM_DT_HAS_F2003 (1 << 25)
361 /* Internal use bit. */
362 #define IOPARM_DT_IONML_SET (1 << 31)
365 typedef struct st_parameter_dt
367 st_parameter_common common;
369 GFC_IO_INT *size, *iolength;
370 gfc_array_char *internal_unit_desc;
372 CHARACTER2 (advance);
373 CHARACTER1 (internal_unit);
374 CHARACTER2 (namelist_name);
375 /* Private part of the structure. The compiler just needs
376 to reserve enough space. */
381 void (*transfer) (struct st_parameter_dt *, bt, void *, int,
383 struct gfc_unit *current_unit;
384 /* Item number in a formatted data transfer. Also used in namelist
385 read_logical as an index into line_buffer. */
388 unit_blank blank_status;
389 unit_sign sign_status;
391 int max_pos; /* Maximum righthand column written to. */
392 /* Number of skips + spaces to be done for T and X-editing. */
394 /* Number of spaces to be done for T and X-editing. */
396 /* Whether an EOR condition was encountered. Value is:
397 0 if no EOR was encountered
398 1 if an EOR was encountered due to a 1-byte marker (LF)
399 2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
401 unit_advance advance_status;
402 unsigned reversion_flag : 1; /* Format reversion has occurred. */
403 unsigned first_item : 1;
404 unsigned seen_dollar : 1;
405 unsigned eor_condition : 1;
406 unsigned no_leading_blank : 1;
407 unsigned char_flag : 1;
408 unsigned input_complete : 1;
410 unsigned comma_flag : 1;
411 /* A namelist specific flag used in the list directed library
412 to flag that calls are being made from namelist read (eg. to
413 ignore comments or to treat '/' as a terminator) */
414 unsigned namelist_mode : 1;
415 /* A namelist specific flag used in the list directed library
416 to flag read errors and return, so that an attempt can be
417 made to read a new object name. */
418 unsigned nml_read_error : 1;
419 /* A sequential formatted read specific flag used to signal that a
420 character string is being read so don't use commas to shorten a
421 formatted field width. */
422 unsigned sf_read_comma : 1;
423 /* A namelist specific flag used to enable reading input from
424 line_buffer for logical reads. */
425 unsigned line_buffer_enabled : 1;
426 /* An internal unit specific flag used to identify that the associated
428 unsigned unit_is_internal : 1;
429 /* An internal unit specific flag to signify an EOF condition for list
432 /* Used for g0 floating point output. */
433 unsigned g0_no_blanks : 1;
434 /* Used to signal use of free_format_data. */
435 unsigned format_not_saved : 1;
436 /* 14 unused bits. */
448 struct format_data *fmt;
450 namelist_info *ionml;
451 /* A flag used to identify when a non-standard expanded namelist read
454 /* Storage area for values except for strings. Must be
455 large enough to hold a complex value (two reals) of the
458 GFC_IO_INT size_used;
460 /* This pad size must be equal to the pad_size declared in
461 trans-io.c (gfc_build_io_library_fndecls). The above structure
462 must be smaller or equal to this array. */
463 char pad[16 * sizeof (char *) + 32 * sizeof (int)];
467 CHARACTER1 (asynchronous);
469 CHARACTER1 (decimal);
477 /* Ensure st_parameter_dt's u.pad is bigger or equal to u.p. */
478 extern char check_st_parameter_dt[sizeof (((st_parameter_dt *) 0)->u.pad)
479 >= sizeof (((st_parameter_dt *) 0)->u.p)
482 #define IOPARM_WAIT_HAS_ID (1 << 7)
486 st_parameter_common common;
503 unit_position position;
506 unit_convert convert;
508 unit_decimal decimal;
509 unit_encoding encoding;
517 typedef struct gfc_unit
523 struct gfc_unit *left, *right;
526 int read_bad, current_record, saved_pos, previous_nonadvancing_write;
529 { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
535 unit_decimal decimal_status;
536 unit_delim delim_status;
537 unit_round round_status;
539 /* recl -- Record length of the file.
540 last_record -- Last record number read or written
541 maxrec -- Maximum record number in a direct access file
542 bytes_left -- Bytes left in current record.
543 strm_pos -- Current position in file for STREAM I/O.
544 recl_subrecord -- Maximum length for subrecord.
545 bytes_left_subrecord -- Bytes left in current subrecord. */
546 gfc_offset recl, last_record, maxrec, bytes_left, strm_pos,
547 recl_subrecord, bytes_left_subrecord;
549 /* Set to 1 if we have read a subrecord. */
553 __gthread_mutex_t lock;
554 /* Number of threads waiting to acquire this unit's lock.
555 When non-zero, close_unit doesn't only removes the unit
556 from the UNIT_ROOT tree, but doesn't free it and the
557 last of the waiting threads will do that.
558 This must be either atomically increased/decreased, or
559 always guarded by UNIT_LOCK. */
561 /* Flag set by close_unit if the unit as been closed.
562 Must be manipulated under unit's lock. */
565 /* For traversing arrays */
572 /* The format hash table. */
573 struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
575 /* Formatting buffer. */
583 /* Maximum file offset, computed at library initialization time. */
584 extern gfc_offset max_offset;
585 internal_proto(max_offset);
587 /* Unit number to be assigned when NEWUNIT is used in an OPEN statement. */
588 extern GFC_INTEGER_4 next_available_newunit;
589 internal_proto(next_available_newunit);
591 /* Unit tree root. */
592 extern gfc_unit *unit_root;
593 internal_proto(unit_root);
595 extern __gthread_mutex_t unit_lock;
596 internal_proto(unit_lock);
598 extern int close_unit (gfc_unit *);
599 internal_proto(close_unit);
601 extern gfc_unit *get_internal_unit (st_parameter_dt *);
602 internal_proto(get_internal_unit);
604 extern void free_internal_unit (st_parameter_dt *);
605 internal_proto(free_internal_unit);
607 extern gfc_unit *find_unit (int);
608 internal_proto(find_unit);
610 extern gfc_unit *find_or_create_unit (int);
611 internal_proto(find_or_create_unit);
613 extern gfc_unit *get_unit (st_parameter_dt *, int);
614 internal_proto(get_unit);
616 extern void unlock_unit (gfc_unit *);
617 internal_proto(unlock_unit);
619 extern void update_position (gfc_unit *);
620 internal_proto(update_position);
622 extern void finish_last_advance_record (gfc_unit *u);
623 internal_proto (finish_last_advance_record);
625 extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *);
626 internal_proto (unit_truncate);
628 extern GFC_INTEGER_4 get_unique_unit_number (st_parameter_open *);
629 internal_proto(get_unique_unit_number);
633 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
634 internal_proto(new_unit);
639 #define SCRATCH_SIZE 300
641 extern const char *type_name (bt);
642 internal_proto(type_name);
644 extern void * read_block_form (st_parameter_dt *, int *);
645 internal_proto(read_block_form);
647 extern void *write_block (st_parameter_dt *, int);
648 internal_proto(write_block);
650 extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *,
652 internal_proto(next_array_record);
654 extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *,
656 internal_proto(init_loop_spec);
658 extern void next_record (st_parameter_dt *, int);
659 internal_proto(next_record);
661 extern void reverse_memcpy (void *, const void *, size_t);
662 internal_proto (reverse_memcpy);
664 extern void st_wait (st_parameter_wait *);
665 export_proto(st_wait);
667 extern void hit_eof (st_parameter_dt *);
668 internal_proto(hit_eof);
672 extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
673 internal_proto(set_integer);
675 extern GFC_UINTEGER_LARGEST max_value (int, int);
676 internal_proto(max_value);
678 extern int convert_real (st_parameter_dt *, void *, const char *, int);
679 internal_proto(convert_real);
681 extern void read_a (st_parameter_dt *, const fnode *, char *, int);
682 internal_proto(read_a);
684 extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, int);
685 internal_proto(read_a);
687 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
688 internal_proto(read_f);
690 extern void read_l (st_parameter_dt *, const fnode *, char *, int);
691 internal_proto(read_l);
693 extern void read_x (st_parameter_dt *, int);
694 internal_proto(read_x);
696 extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
697 internal_proto(read_radix);
699 extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
700 internal_proto(read_decimal);
704 extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
706 internal_proto(list_formatted_read);
708 extern void finish_list_read (st_parameter_dt *);
709 internal_proto(finish_list_read);
711 extern void namelist_read (st_parameter_dt *);
712 internal_proto(namelist_read);
714 extern void namelist_write (st_parameter_dt *);
715 internal_proto(namelist_write);
719 extern void write_a (st_parameter_dt *, const fnode *, const char *, int);
720 internal_proto(write_a);
722 extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, int);
723 internal_proto(write_a_char4);
725 extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
726 internal_proto(write_b);
728 extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
729 internal_proto(write_d);
731 extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
732 internal_proto(write_e);
734 extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
735 internal_proto(write_en);
737 extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
738 internal_proto(write_es);
740 extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
741 internal_proto(write_f);
743 extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
744 internal_proto(write_i);
746 extern void write_l (st_parameter_dt *, const fnode *, char *, int);
747 internal_proto(write_l);
749 extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
750 internal_proto(write_o);
752 extern void write_real (st_parameter_dt *, const char *, int);
753 internal_proto(write_real);
755 extern void write_real_g0 (st_parameter_dt *, const char *, int, int);
756 internal_proto(write_real_g0);
758 extern void write_x (st_parameter_dt *, int, int);
759 internal_proto(write_x);
761 extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
762 internal_proto(write_z);
764 extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
766 internal_proto(list_formatted_write);
768 /* size_from_kind.c */
769 extern size_t size_from_real_kind (int);
770 internal_proto(size_from_real_kind);
772 extern size_t size_from_complex_kind (int);
773 internal_proto(size_from_complex_kind);
777 extern void free_ionml (st_parameter_dt *);
778 internal_proto(free_ionml);
781 inc_waiting_locked (gfc_unit *u)
783 #ifdef HAVE_SYNC_FETCH_AND_ADD
784 (void) __sync_fetch_and_add (&u->waiting, 1);
791 predec_waiting_locked (gfc_unit *u)
793 #ifdef HAVE_SYNC_FETCH_AND_ADD
794 return __sync_add_and_fetch (&u->waiting, -1);
801 dec_waiting_unlocked (gfc_unit *u)
803 #ifdef HAVE_SYNC_FETCH_AND_ADD
804 (void) __sync_fetch_and_add (&u->waiting, -1);
806 __gthread_mutex_lock (&unit_lock);
808 __gthread_mutex_unlock (&unit_lock);