+2005-11-21 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/14943
+ PR fortran/21647
+ * Make-lang.in (fortran/trans-io.o): Depend on fortran/ioparm.def.
+ * dump-parse-tree.c (gfc_show_code_node): Dump c->block for
+ EXEC_{READ,WRITE,IOLENGTH} nodes.
+ * io.c (terminate_io, match_io, gfc_match_inquire): Put data
+ transfer commands into EXEC_{READ,WRITE,IOLENGTH}'s code->block.
+ * resolve.c (resolve_blocks): Handle EXEC_{READ,WRITE,IOLENGTH}.
+ * trans-io.c (ioparm_unit, ioparm_err, ioparm_end, ioparm_eor,
+ ioparm_list_format, ioparm_library_return, ioparm_iostat,
+ ioparm_exist, ioparm_opened, ioparm_number, ioparm_named,
+ ioparm_rec, ioparm_nextrec, ioparm_size, ioparm_recl_in,
+ ioparm_recl_out, ioparm_iolength, ioparm_file, ioparm_file_len,
+ ioparm_status, ioparm_status_len, ioparm_access, ioparm_access_len,
+ ioparm_form, ioparm_form_len, ioparm_blank, ioparm_blank_len,
+ ioparm_position, ioparm_position_len, ioparm_action,
+ ioparm_action_len, ioparm_delim, ioparm_delim_len, ioparm_pad,
+ ioparm_pad_len, ioparm_format, ioparm_format_len, ioparm_advance,
+ ioparm_advance_len, ioparm_name, ioparm_name_len,
+ ioparm_internal_unit, ioparm_internal_unit_len,
+ ioparm_internal_unit_desc, ioparm_sequential, ioparm_sequential_len,
+ ioparm_direct, ioparm_direct_len, ioparm_formatted,
+ ioparm_formatted_len, ioparm_unformatted, ioparm_unformatted_len,
+ ioparm_read, ioparm_read_len, ioparm_write, ioparm_write_len,
+ ioparm_readwrite, ioparm_readwrite_len, ioparm_namelist_name,
+ ioparm_namelist_name_len, ioparm_namelist_read_mode, ioparm_iomsg,
+ ioparm_iomsg_len, ioparm_var): Remove.
+ (enum ioparam_type, enum iofield_type, enum iofield,
+ enum iocall): New enums.
+ (gfc_st_parameter_field, gfc_st_parameter): New typedefs.
+ (st_parameter, st_parameter_field, iocall): New variables.
+ (ADD_FIELD, ADD_STRING): Remove.
+ (dt_parm, dt_post_end_block): New variables.
+ (gfc_build_st_parameter): New function.
+ (gfc_build_io_library_fndecls): Use it. Initialize iocall
+ array rather than ioparm_*, add extra first arguments to
+ the function types.
+ (set_parameter_const): New function.
+ (set_parameter_value): Add type argument, return a bitmask.
+ Changed to set a field in automatic structure variable rather
+ than set a field in a global _gfortran_ioparm variable.
+ (set_parameter_ref): Likewise. If requested var has different
+ size than what field should point to, call with a temporary and
+ then copy into the user variable. Add postblock argument.
+ (set_string): Remove var_len argument, add type argument, return
+ a bitmask. Changed to set fields in automatic structure variable
+ rather than set a field in a global _gfortran_ioparm variable.
+ (set_internal_unit): Remove iunit, iunit_len, iunit_desc arguments,
+ add var argument. Return a bitmask. Changed to set fields in
+ automatic structure variable rather than set a field in a global
+ _gfortran_ioparm variable.
+ (set_flag): Removed.
+ (io_result): Add var argument. Changed to read common.flags field
+ from automatic structure variable and bitwise AND it with 3.
+ (set_error_locus): Add var argument. Changed to set fields in
+ automatic structure variable rather than set a field in a global
+ _gfortran_{filename,line} variables.
+ (gfc_trans_open): Use gfc_start_block rather than gfc_init_block.
+ Create a temporary st_parameter_* structure. Adjust callers of
+ all above mentioned functions. Pass address of the temporary
+ variable as first argument to the generated function call.
+ Use iocall array rather than ioparm_* separate variables.
+ (gfc_trans_close, build_filepos, gfc_trans_inquire): Likewise.
+ (build_dt): Likewise. Change first argument to tree from tree *.
+ Don't dereference code->ext.dt if last_dt == INQUIRE. Emit
+ IOLENGTH argument setup here. Set dt_parm/dt_post_end_block
+ variables and gfc_trans_code the nested data transfer commands
+ in code->block.
+ (gfc_trans_iolength): Just set last_dt and call build_dt immediately.
+ (transfer_namelist_element): Pass address of dt_parm variable
+ to generated functions. Use iocall array rather than ioparm_*
+ separate variables.
+ (gfc_trans_backspace, gfc_trans_endfile, gfc_trans_rewind,
+ gfc_trans_flush, gfc_trans_read, gfc_trans_write): Use iocall array
+ rather than ioparm_* separate variables.
+ (gfc_trans_dt_end): Likewise. Pass address of dt_parm variable
+ as first argument to generated function. Adjust io_result caller.
+ Prepend dt_post_end_block before io_result code.
+ (transfer_expr): Use iocall array rather than ioparm_* separate
+ variables. Pass address of dt_parm variables as first argument
+ to generated functions.
+ * ioparm.def: New file.
+
2005-11-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/24223
fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
-fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h
+fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h \
+ fortran/ioparm.def
fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
gt-fortran-trans-intrinsic.h
case EXEC_IOLENGTH:
gfc_status ("IOLENGTH ");
gfc_show_expr (c->expr);
+ goto show_dt_code;
break;
case EXEC_READ:
gfc_show_expr (dt->advance);
}
- break;
+ show_dt_code:
+ gfc_status_char ('\n');
+ for (c = c->block->next; c; c = c->next)
+ gfc_show_code_node (level + (c->next != NULL), c);
+ return;
case EXEC_TRANSFER:
gfc_status ("TRANSFER ");
gfc_code *c;
if (io_code == NULL)
- io_code = &new_st;
+ io_code = new_st.block;
c = gfc_get_code ();
c->op = EXEC_DT_END;
new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
new_st.ext.dt = dt;
- new_st.next = io_code;
+ new_st.block = gfc_get_code ();
+ new_st.block->op = new_st.op;
+ new_st.block->next = io_code;
terminate_io (io_code);
if (m == MATCH_NO)
goto syntax;
- terminate_io (code);
-
new_st.op = EXEC_IOLENGTH;
new_st.expr = inquire->iolength;
new_st.ext.inquire = inquire;
return MATCH_ERROR;
}
- new_st.next = code;
+ new_st.block = gfc_get_code ();
+ new_st.block->op = EXEC_IOLENGTH;
+ terminate_io (code);
+ new_st.block->next = code;
return MATCH_YES;
}
--- /dev/null
+#ifndef IOPARM_common_libreturn_mask
+#define IOPARM_common_libreturn_mask 3
+#define IOPARM_common_libreturn_ok 0
+#define IOPARM_common_libreturn_error 1
+#define IOPARM_common_libreturn_end 2
+#define IOPARM_common_libreturn_eor 3
+#define IOPARM_common_err (1 << 2)
+#define IOPARM_common_end (1 << 3)
+#define IOPARM_common_eor (1 << 4)
+#endif
+IOPARM (common, flags, 0, int4)
+IOPARM (common, unit, 0, int4)
+IOPARM (common, filename, 0, pchar)
+IOPARM (common, line, 0, int4)
+IOPARM (common, iomsg, 1 << 6, char2)
+IOPARM (common, iostat, 1 << 5, pint4)
+IOPARM (open, common, 0, common)
+IOPARM (open, recl_in, 1 << 7, int4)
+IOPARM (open, file, 1 << 8, char2)
+IOPARM (open, status, 1 << 9, char1)
+IOPARM (open, access, 1 << 10, char2)
+IOPARM (open, form, 1 << 11, char1)
+IOPARM (open, blank, 1 << 12, char2)
+IOPARM (open, position, 1 << 13, char1)
+IOPARM (open, action, 1 << 14, char2)
+IOPARM (open, delim, 1 << 15, char1)
+IOPARM (open, pad, 1 << 16, char2)
+IOPARM (close, common, 0, common)
+IOPARM (close, status, 1 << 7, char1)
+IOPARM (filepos, common, 0, common)
+IOPARM (inquire, common, 0, common)
+IOPARM (inquire, exist, 1 << 7, pint4)
+IOPARM (inquire, opened, 1 << 8, pint4)
+IOPARM (inquire, number, 1 << 9, pint4)
+IOPARM (inquire, named, 1 << 10, pint4)
+IOPARM (inquire, nextrec, 1 << 11, pint4)
+IOPARM (inquire, recl_out, 1 << 12, pint4)
+IOPARM (inquire, file, 1 << 13, char1)
+IOPARM (inquire, access, 1 << 14, char2)
+IOPARM (inquire, form, 1 << 15, char1)
+IOPARM (inquire, blank, 1 << 16, char2)
+IOPARM (inquire, position, 1 << 17, char1)
+IOPARM (inquire, action, 1 << 18, char2)
+IOPARM (inquire, delim, 1 << 19, char1)
+IOPARM (inquire, pad, 1 << 20, char2)
+IOPARM (inquire, name, 1 << 21, char1)
+IOPARM (inquire, sequential, 1 << 22, char2)
+IOPARM (inquire, direct, 1 << 23, char1)
+IOPARM (inquire, formatted, 1 << 24, char2)
+IOPARM (inquire, unformatted, 1 << 25, char1)
+IOPARM (inquire, read, 1 << 26, char2)
+IOPARM (inquire, write, 1 << 27, char1)
+IOPARM (inquire, readwrite, 1 << 28, char2)
+#ifndef IOPARM_dt_list_format
+#define IOPARM_dt_list_format (1 << 7)
+#define IOPARM_dt_namelist_read_mode (1 << 8)
+#endif
+IOPARM (dt, common, 0, common)
+IOPARM (dt, rec, 1 << 9, int4)
+IOPARM (dt, size, 1 << 10, pint4)
+IOPARM (dt, iolength, 1 << 11, pint4)
+IOPARM (dt, internal_unit_desc, 0, parray)
+IOPARM (dt, format, 1 << 12, char1)
+IOPARM (dt, advance, 1 << 13, char2)
+IOPARM (dt, internal_unit, 1 << 14, char1)
+IOPARM (dt, namelist_name, 1 << 15, char2)
+IOPARM (dt, u, 0, pad)
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_READ:
+ case EXEC_WRITE:
+ case EXEC_IOLENGTH:
break;
default:
/* Members of the ioparm structure. */
-static GTY(()) tree ioparm_unit;
-static GTY(()) tree ioparm_err;
-static GTY(()) tree ioparm_end;
-static GTY(()) tree ioparm_eor;
-static GTY(()) tree ioparm_list_format;
-static GTY(()) tree ioparm_library_return;
-static GTY(()) tree ioparm_iostat;
-static GTY(()) tree ioparm_exist;
-static GTY(()) tree ioparm_opened;
-static GTY(()) tree ioparm_number;
-static GTY(()) tree ioparm_named;
-static GTY(()) tree ioparm_rec;
-static GTY(()) tree ioparm_nextrec;
-static GTY(()) tree ioparm_size;
-static GTY(()) tree ioparm_recl_in;
-static GTY(()) tree ioparm_recl_out;
-static GTY(()) tree ioparm_iolength;
-static GTY(()) tree ioparm_file;
-static GTY(()) tree ioparm_file_len;
-static GTY(()) tree ioparm_status;
-static GTY(()) tree ioparm_status_len;
-static GTY(()) tree ioparm_access;
-static GTY(()) tree ioparm_access_len;
-static GTY(()) tree ioparm_form;
-static GTY(()) tree ioparm_form_len;
-static GTY(()) tree ioparm_blank;
-static GTY(()) tree ioparm_blank_len;
-static GTY(()) tree ioparm_position;
-static GTY(()) tree ioparm_position_len;
-static GTY(()) tree ioparm_action;
-static GTY(()) tree ioparm_action_len;
-static GTY(()) tree ioparm_delim;
-static GTY(()) tree ioparm_delim_len;
-static GTY(()) tree ioparm_pad;
-static GTY(()) tree ioparm_pad_len;
-static GTY(()) tree ioparm_format;
-static GTY(()) tree ioparm_format_len;
-static GTY(()) tree ioparm_advance;
-static GTY(()) tree ioparm_advance_len;
-static GTY(()) tree ioparm_name;
-static GTY(()) tree ioparm_name_len;
-static GTY(()) tree ioparm_internal_unit;
-static GTY(()) tree ioparm_internal_unit_len;
-static GTY(()) tree ioparm_internal_unit_desc;
-static GTY(()) tree ioparm_sequential;
-static GTY(()) tree ioparm_sequential_len;
-static GTY(()) tree ioparm_direct;
-static GTY(()) tree ioparm_direct_len;
-static GTY(()) tree ioparm_formatted;
-static GTY(()) tree ioparm_formatted_len;
-static GTY(()) tree ioparm_unformatted;
-static GTY(()) tree ioparm_unformatted_len;
-static GTY(()) tree ioparm_read;
-static GTY(()) tree ioparm_read_len;
-static GTY(()) tree ioparm_write;
-static GTY(()) tree ioparm_write_len;
-static GTY(()) tree ioparm_readwrite;
-static GTY(()) tree ioparm_readwrite_len;
-static GTY(()) tree ioparm_namelist_name;
-static GTY(()) tree ioparm_namelist_name_len;
-static GTY(()) tree ioparm_namelist_read_mode;
-static GTY(()) tree ioparm_iomsg;
-static GTY(()) tree ioparm_iomsg_len;
-
-/* The global I/O variables */
-
-static GTY(()) tree ioparm_var;
-static GTY(()) tree locus_file;
-static GTY(()) tree locus_line;
+enum ioparam_type
+{
+ IOPARM_ptype_common,
+ IOPARM_ptype_open,
+ IOPARM_ptype_close,
+ IOPARM_ptype_filepos,
+ IOPARM_ptype_inquire,
+ IOPARM_ptype_dt,
+ IOPARM_ptype_num
+};
+
+enum iofield_type
+{
+ IOPARM_type_int4,
+ IOPARM_type_pint4,
+ IOPARM_type_pchar,
+ IOPARM_type_parray,
+ IOPARM_type_pad,
+ IOPARM_type_char1,
+ IOPARM_type_char2,
+ IOPARM_type_common,
+ IOPARM_type_num
+};
+
+typedef struct gfc_st_parameter_field GTY(())
+{
+ const char *name;
+ unsigned int mask;
+ enum ioparam_type param_type;
+ enum iofield_type type;
+ tree field;
+ tree field_len;
+}
+gfc_st_parameter_field;
+typedef struct gfc_st_parameter GTY(())
+{
+ const char *name;
+ tree type;
+}
+gfc_st_parameter;
+
+enum iofield
+{
+#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
+#include "ioparm.def"
+#undef IOPARM
+ IOPARM_field_num
+};
+
+static GTY(()) gfc_st_parameter st_parameter[] =
+{
+ { "common", NULL },
+ { "open", NULL },
+ { "close", NULL },
+ { "filepos", NULL },
+ { "inquire", NULL },
+ { "dt", NULL }
+};
+
+static GTY(()) gfc_st_parameter_field st_parameter_field[] =
+{
+#define IOPARM(param_type, name, mask, type) \
+ { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
+#include "ioparm.def"
+#undef IOPARM
+ { NULL, 0, 0, 0, NULL, NULL }
+};
/* Library I/O subroutines */
-static GTY(()) tree iocall_read;
-static GTY(()) tree iocall_read_done;
-static GTY(()) tree iocall_write;
-static GTY(()) tree iocall_write_done;
-static GTY(()) tree iocall_x_integer;
-static GTY(()) tree iocall_x_logical;
-static GTY(()) tree iocall_x_character;
-static GTY(()) tree iocall_x_real;
-static GTY(()) tree iocall_x_complex;
-static GTY(()) tree iocall_x_array;
-static GTY(()) tree iocall_open;
-static GTY(()) tree iocall_close;
-static GTY(()) tree iocall_inquire;
-static GTY(()) tree iocall_iolength;
-static GTY(()) tree iocall_iolength_done;
-static GTY(()) tree iocall_rewind;
-static GTY(()) tree iocall_backspace;
-static GTY(()) tree iocall_endfile;
-static GTY(()) tree iocall_flush;
-static GTY(()) tree iocall_set_nml_val;
-static GTY(()) tree iocall_set_nml_val_dim;
+enum iocall
+{
+ IOCALL_READ,
+ IOCALL_READ_DONE,
+ IOCALL_WRITE,
+ IOCALL_WRITE_DONE,
+ IOCALL_X_INTEGER,
+ IOCALL_X_LOGICAL,
+ IOCALL_X_CHARACTER,
+ IOCALL_X_REAL,
+ IOCALL_X_COMPLEX,
+ IOCALL_X_ARRAY,
+ IOCALL_OPEN,
+ IOCALL_CLOSE,
+ IOCALL_INQUIRE,
+ IOCALL_IOLENGTH,
+ IOCALL_IOLENGTH_DONE,
+ IOCALL_REWIND,
+ IOCALL_BACKSPACE,
+ IOCALL_ENDFILE,
+ IOCALL_FLUSH,
+ IOCALL_SET_NML_VAL,
+ IOCALL_SET_NML_VAL_DIM,
+ IOCALL_NUM
+};
+
+static GTY(()) tree iocall[IOCALL_NUM];
/* Variable for keeping track of what the last data transfer statement
was. Used for deciding which subroutine to call when the data
transfer is complete. */
static enum { READ, WRITE, IOLENGTH } last_dt;
-#define ADD_FIELD(name, type) \
- ioparm_ ## name = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name)), type)
+/* The data transfer parameter block that should be shared by all
+ data transfer calls belonging to the same read/write/iolength. */
+static GTY(()) tree dt_parm;
+static stmtblock_t *dt_post_end_block;
-#define ADD_STRING(name) \
- ioparm_ ## name = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name)), pchar_type_node); \
- ioparm_ ## name ## _len = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
+static void
+gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
+{
+ enum iofield type;
+ gfc_st_parameter_field *p;
+ char name[64];
+ size_t len;
+ tree t = make_node (RECORD_TYPE);
+
+ len = strlen (st_parameter[ptype].name);
+ gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
+ memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
+ memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
+ len);
+ TYPE_NAME (t) = get_identifier (name);
+
+ for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
+ if (p->param_type == ptype)
+ switch (p->type)
+ {
+ case IOPARM_type_int4:
+ case IOPARM_type_pint4:
+ case IOPARM_type_parray:
+ case IOPARM_type_pchar:
+ case IOPARM_type_pad:
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ types[p->type]);
+ break;
+ case IOPARM_type_char1:
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ pchar_type_node);
+ /* FALLTHROUGH */
+ case IOPARM_type_char2:
+ len = strlen (p->name);
+ gcc_assert (len <= sizeof (name) - sizeof ("_len"));
+ memcpy (name, p->name, len);
+ memcpy (name + len, "_len", sizeof ("_len"));
+ p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (name),
+ gfc_charlen_type_node);
+ if (p->type == IOPARM_type_char2)
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ pchar_type_node);
+ break;
+ case IOPARM_type_common:
+ p->field
+ = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ st_parameter[IOPARM_ptype_common].type);
+ break;
+ case IOPARM_type_num:
+ gcc_unreachable ();
+ }
+ gfc_finish_type (t);
+ st_parameter[ptype].type = t;
+}
/* Create function decls for IO library functions. */
void
gfc_build_io_library_fndecls (void)
{
- tree gfc_int4_type_node;
- tree gfc_pint4_type_node;
+ tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
+ tree parm_type, dt_parm_type;
tree gfc_c_int_type_node;
- tree ioparm_type;
-
- gfc_int4_type_node = gfc_get_int_type (4);
- gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
+ HOST_WIDE_INT pad_size;
+ enum ioparam_type ptype;
+
+ types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
+ types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
+ types[IOPARM_type_parray] = pchar_type_node;
+ types[IOPARM_type_pchar] = pchar_type_node;
+ pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
+ pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
+ pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
+ types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
- /* Build the st_parameter structure. Information associated with I/O
- calls are transferred here. This must match the one defined in the
- library exactly. */
-
- ioparm_type = make_node (RECORD_TYPE);
- TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
-
- ADD_FIELD (unit, gfc_int4_type_node);
- ADD_FIELD (err, gfc_int4_type_node);
- ADD_FIELD (end, gfc_int4_type_node);
- ADD_FIELD (eor, gfc_int4_type_node);
- ADD_FIELD (list_format, gfc_int4_type_node);
- ADD_FIELD (library_return, gfc_int4_type_node);
-
- ADD_FIELD (iostat, gfc_pint4_type_node);
- ADD_FIELD (exist, gfc_pint4_type_node);
- ADD_FIELD (opened, gfc_pint4_type_node);
- ADD_FIELD (number, gfc_pint4_type_node);
- ADD_FIELD (named, gfc_pint4_type_node);
- ADD_FIELD (rec, gfc_int4_type_node);
- ADD_FIELD (nextrec, gfc_pint4_type_node);
- ADD_FIELD (size, gfc_pint4_type_node);
-
- ADD_FIELD (recl_in, gfc_int4_type_node);
- ADD_FIELD (recl_out, gfc_pint4_type_node);
-
- ADD_FIELD (iolength, gfc_pint4_type_node);
-
- ADD_STRING (file);
- ADD_STRING (status);
-
- ADD_STRING (access);
- ADD_STRING (form);
- ADD_STRING (blank);
- ADD_STRING (position);
- ADD_STRING (action);
- ADD_STRING (delim);
- ADD_STRING (pad);
- ADD_STRING (format);
- ADD_STRING (advance);
- ADD_STRING (name);
- ADD_STRING (internal_unit);
- ADD_FIELD (internal_unit_desc, pchar_type_node);
- ADD_STRING (sequential);
-
- ADD_STRING (direct);
- ADD_STRING (formatted);
- ADD_STRING (unformatted);
- ADD_STRING (read);
- ADD_STRING (write);
- ADD_STRING (readwrite);
-
- ADD_STRING (namelist_name);
- ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
- ADD_STRING (iomsg);
-
- gfc_finish_type (ioparm_type);
-
- ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
- ioparm_type);
- DECL_EXTERNAL (ioparm_var) = 1;
- TREE_PUBLIC (ioparm_var) = 1;
-
- locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
- gfc_int4_type_node);
- DECL_EXTERNAL (locus_line) = 1;
- TREE_PUBLIC (locus_line) = 1;
-
- locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
- pchar_type_node);
- DECL_EXTERNAL (locus_file) = 1;
- TREE_PUBLIC (locus_file) = 1;
+ for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
+ gfc_build_st_parameter (ptype, types);
/* Define the transfer functions. */
- iocall_x_integer =
+ dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
+
+ iocall[IOCALL_X_INTEGER] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_integer")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_logical =
+ iocall[IOCALL_X_LOGICAL] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_logical")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_character =
+ iocall[IOCALL_X_CHARACTER] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_character")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_real =
+ iocall[IOCALL_X_REAL] =
gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
- void_type_node, 2,
+ void_type_node, 3, dt_parm_type,
pvoid_type_node, gfc_int4_type_node);
- iocall_x_complex =
+ iocall[IOCALL_X_COMPLEX] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_complex")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_array =
+ iocall[IOCALL_X_ARRAY] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_array")),
- void_type_node, 3, pvoid_type_node,
- gfc_c_int_type_node,
+ void_type_node, 4, dt_parm_type,
+ pvoid_type_node, gfc_c_int_type_node,
gfc_charlen_type_node);
/* Library entry points */
- iocall_read =
+ iocall[IOCALL_READ] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
- void_type_node, 0);
+ void_type_node, 1, dt_parm_type);
- iocall_write =
+ iocall[IOCALL_WRITE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
- void_type_node, 0);
- iocall_open =
+ void_type_node, 1, dt_parm_type);
+
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
+ iocall[IOCALL_OPEN] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
- void_type_node, 0);
+ void_type_node, 1, parm_type);
+
- iocall_close =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
+ iocall[IOCALL_CLOSE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
- void_type_node, 0);
+ void_type_node, 1, parm_type);
- iocall_inquire =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
+ iocall[IOCALL_INQUIRE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_iolength =
+ iocall[IOCALL_IOLENGTH] =
gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
- void_type_node, 0);
+ void_type_node, 1, dt_parm_type);
- iocall_rewind =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
+ iocall[IOCALL_REWIND] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_backspace =
+ iocall[IOCALL_BACKSPACE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_endfile =
+ iocall[IOCALL_ENDFILE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_flush =
+ iocall[IOCALL_FLUSH] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
/* Library helpers */
- iocall_read_done =
+ iocall[IOCALL_READ_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_write_done =
+ iocall[IOCALL_WRITE_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_iolength_done =
+ iocall[IOCALL_IOLENGTH_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_set_nml_val =
+ iocall[IOCALL_SET_NML_VAL] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
- void_type_node, 5,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node, gfc_charlen_type_node,
+ void_type_node, 6, dt_parm_type,
+ pvoid_type_node, pvoid_type_node,
+ gfc_int4_type_node, gfc_charlen_type_node,
gfc_int4_type_node);
- iocall_set_nml_val_dim =
+ iocall[IOCALL_SET_NML_VAL_DIM] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
- void_type_node, 4,
+ void_type_node, 5, dt_parm_type,
gfc_int4_type_node, gfc_int4_type_node,
gfc_int4_type_node, gfc_int4_type_node);
}
+/* Generate code to store an integer constant into the
+ st_parameter_XXX structure. */
+
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+ unsigned int val)
+{
+ tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+ return p->mask;
+}
+
+
/* Generate code to store a non-string I/O parameter into the
- ioparm structure. This is a pass by value. */
+ st_parameter_XXX structure. This is a pass by value. */
-static void
-set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
+ gfc_expr *e)
{
gfc_se se;
tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, e, TREE_TYPE (var));
+ gfc_conv_expr_type (&se, e, TREE_TYPE (p->field));
gfc_add_block_to_block (block, &se.pre);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
gfc_add_modify_expr (block, tmp, se.expr);
+ return p->mask;
}
/* Generate code to store a non-string I/O parameter into the
- ioparm structure. This is pass by reference. */
+ st_parameter_XXX structure. This is pass by reference. */
-static void
-set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
+ tree var, enum iofield type, gfc_expr *e)
{
gfc_se se;
- tree tmp;
+ tree tmp, addr;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+ gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
gfc_init_se (&se, NULL);
- se.want_pointer = 1;
+ gfc_conv_expr_lhs (&se, e);
- gfc_conv_expr_type (&se, e, TREE_TYPE (var));
gfc_add_block_to_block (block, &se.pre);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
- gfc_add_modify_expr (block, tmp, se.expr);
+ if (TYPE_MODE (TREE_TYPE (se.expr))
+ == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
+ addr = convert (TREE_TYPE (p->field),
+ gfc_build_addr_expr (NULL, se.expr));
+ else
+ {
+ /* The type used by the library has different size
+ from the type of the variable supplied by the user.
+ Need to use a temporary. */
+ tree tmpvar
+ = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
+ st_parameter_field[type].name);
+ addr = gfc_build_addr_expr (NULL, tmpvar);
+ tmp = convert (TREE_TYPE (se.expr), tmpvar);
+ gfc_add_modify_expr (postblock, se.expr, tmp);
+ }
+
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ gfc_add_modify_expr (block, tmp, addr);
+ return p->mask;
}
/* Given an array expr, find its address and length to get a string. If the
/* Generate code to store a string and its length into the
- ioparm structure. */
+ st_parameter_XXX structure. */
-static void
+static unsigned int
set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
- tree var_len, gfc_expr * e)
+ enum iofield type, gfc_expr * e)
{
gfc_se se;
tree tmp;
tree msg;
tree io;
tree len;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
gfc_init_se (&se, NULL);
- io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
- len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
+ if (p->param_type == IOPARM_ptype_common)
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
NULL_TREE);
/* Integer variable assigned a format label. */
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
+ return p->mask;
}
/* Generate code to store the character (array) and the character length
for an internal unit. */
-static void
-set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len,
- tree iunit_desc, gfc_expr * e)
+static unsigned int
+set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
{
gfc_se se;
tree io;
tree len;
tree desc;
tree tmp;
+ gfc_st_parameter_field *p;
+ unsigned int mask;
gfc_init_se (&se, NULL);
- io = build3 (COMPONENT_REF, TREE_TYPE (iunit), ioparm_var, iunit, NULL_TREE);
- len = build3 (COMPONENT_REF, TREE_TYPE (iunit_len), ioparm_var, iunit_len,
+ p = &st_parameter_field[IOPARM_dt_internal_unit];
+ mask = p->mask;
+ io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
NULL_TREE);
- desc = build3 (COMPONENT_REF, TREE_TYPE (iunit_desc), ioparm_var, iunit_desc,
+ p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
+ desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
NULL_TREE);
gcc_assert (e->ts.type == BT_CHARACTER);
gfc_add_modify_expr (&se.pre, desc, se.expr);
gfc_add_block_to_block (block, &se.pre);
+ return mask;
}
-/* Set a member of the ioparm structure to one. */
-static void
-set_flag (stmtblock_t *block, tree var)
-{
- tree tmp, type = TREE_TYPE (var);
-
- tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
- gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
-}
-
-
/* Add a case to a IO-result switch. */
static void
be created anyway. */
static void
-io_result (stmtblock_t * block, gfc_st_label * err_label,
+io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
gfc_st_label * end_label, gfc_st_label * eor_label)
{
stmtblock_t body;
tree tmp, rc;
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
/* If no labels are specified, ignore the result instead
of building an empty switch. */
tmp = gfc_finish_block (&body);
- rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
- ioparm_library_return, NULL_TREE);
+ var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
+ build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));
tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
library call goes awry, we can tell the user where the problem is. */
static void
-set_error_locus (stmtblock_t * block, locus * where)
+set_error_locus (stmtblock_t * block, tree var, locus * where)
{
gfc_file *f;
- tree tmp;
+ tree str, locus_file;
int line;
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
+ locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
+ p->field, NULL_TREE);
f = where->lb->file;
- tmp = gfc_build_cstring_const (f->filename);
+ str = gfc_build_cstring_const (f->filename);
- tmp = gfc_build_addr_expr (pchar_type_node, tmp);
- gfc_add_modify_expr (block, locus_file, tmp);
+ str = gfc_build_addr_expr (pchar_type_node, str);
+ gfc_add_modify_expr (block, locus_file, str);
#ifdef USE_MAPPED_LOCATION
line = LOCATION_LINE (where->lb->location);
#else
line = where->lb->linenum;
#endif
- gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
+ set_parameter_const (block, var, IOPARM_common_line, line);
}
{
stmtblock_t block, post_block;
gfc_open *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
+
+ set_error_locus (&block, var, &code->loc);
p = code->ext.open;
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->file)
- set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
if (p->status)
- set_string (&block, &post_block, ioparm_status,
- ioparm_status_len, p->status);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_status,
+ p->status);
if (p->access)
- set_string (&block, &post_block, ioparm_access,
- ioparm_access_len, p->access);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_access,
+ p->access);
if (p->form)
- set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
if (p->recl)
- set_parameter_value (&block, ioparm_recl_in, p->recl);
+ mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
if (p->blank)
- set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
- p->blank);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
+ p->blank);
if (p->position)
- set_string (&block, &post_block, ioparm_position,
- ioparm_position_len, p->position);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_position,
+ p->position);
if (p->action)
- set_string (&block, &post_block, ioparm_action,
- ioparm_action_len, p->action);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_action,
+ p->action);
if (p->delim)
- set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
- p->delim);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
+ p->delim);
if (p->pad)
- set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_function_call (iocall_open, NULL_TREE);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (iocall[IOCALL_OPEN], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
{
stmtblock_t block, post_block;
gfc_close *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
+
+ set_error_locus (&block, var, &code->loc);
p = code->ext.close;
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->status)
- set_string (&block, &post_block, ioparm_status,
- ioparm_status_len, p->status);
+ mask |= set_string (&block, &post_block, var, IOPARM_close_status,
+ p->status);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
- tmp = gfc_build_function_call (iocall_close, NULL_TREE);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (iocall[IOCALL_CLOSE], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
{
stmtblock_t block, post_block;
gfc_filepos *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
p = code->ext.filepos;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
+ "filepos_parm");
+
+ set_error_locus (&block, var, &code->loc);
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
- tmp = gfc_build_function_call (function, NULL);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (function, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
tree
gfc_trans_backspace (gfc_code * code)
{
-
- return build_filepos (iocall_backspace, code);
+ return build_filepos (iocall[IOCALL_BACKSPACE], code);
}
tree
gfc_trans_endfile (gfc_code * code)
{
-
- return build_filepos (iocall_endfile, code);
+ return build_filepos (iocall[IOCALL_ENDFILE], code);
}
tree
gfc_trans_rewind (gfc_code * code)
{
-
- return build_filepos (iocall_rewind, code);
+ return build_filepos (iocall[IOCALL_REWIND], code);
}
tree
gfc_trans_flush (gfc_code * code)
{
-
- return build_filepos (iocall_flush, code);
+ return build_filepos (iocall[IOCALL_FLUSH], code);
}
{
stmtblock_t block, post_block;
gfc_inquire *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
+ "inquire_parm");
+
+ set_error_locus (&block, var, &code->loc);
p = code->ext.inquire;
/* Sanity check. */
gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code->loc);
if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
if (p->file)
- set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
+ p->file);
if (p->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- p->iomsg);
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->exist)
- set_parameter_ref (&block, ioparm_exist, p->exist);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
+ p->exist);
if (p->opened)
- set_parameter_ref (&block, ioparm_opened, p->opened);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
+ p->opened);
if (p->number)
- set_parameter_ref (&block, ioparm_number, p->number);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
+ p->number);
if (p->named)
- set_parameter_ref (&block, ioparm_named, p->named);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
+ p->named);
if (p->name)
- set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
+ p->name);
if (p->access)
- set_string (&block, &post_block, ioparm_access,
- ioparm_access_len, p->access);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
+ p->access);
if (p->sequential)
- set_string (&block, &post_block, ioparm_sequential,
- ioparm_sequential_len, p->sequential);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
+ p->sequential);
if (p->direct)
- set_string (&block, &post_block, ioparm_direct,
- ioparm_direct_len, p->direct);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
+ p->direct);
if (p->form)
- set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
+ p->form);
if (p->formatted)
- set_string (&block, &post_block, ioparm_formatted,
- ioparm_formatted_len, p->formatted);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
+ p->formatted);
if (p->unformatted)
- set_string (&block, &post_block, ioparm_unformatted,
- ioparm_unformatted_len, p->unformatted);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
+ p->unformatted);
if (p->recl)
- set_parameter_ref (&block, ioparm_recl_out, p->recl);
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_recl_out, p->recl);
if (p->nextrec)
- set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_nextrec, p->nextrec);
if (p->blank)
- set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
- p->blank);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
+ p->blank);
if (p->position)
- set_string (&block, &post_block, ioparm_position,
- ioparm_position_len, p->position);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
+ p->position);
if (p->action)
- set_string (&block, &post_block, ioparm_action,
- ioparm_action_len, p->action);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
+ p->action);
if (p->read)
- set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
+ p->read);
if (p->write)
- set_string (&block, &post_block, ioparm_write,
- ioparm_write_len, p->write);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
+ p->write);
if (p->readwrite)
- set_string (&block, &post_block, ioparm_readwrite,
- ioparm_readwrite_len, p->readwrite);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
+ p->readwrite);
if (p->delim)
- set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
- p->delim);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
+ p->delim);
if (p->pad)
- set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
- p->pad);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
+ p->pad);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
- tmp = gfc_build_function_call (iocall_inquire, NULL);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (iocall[IOCALL_INQUIRE], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
}
/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
- call to iocall_set_nml_val. For derived type variable, recursively
- generate calls to iocall_set_nml_val for each component. */
+ call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
+ generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
#define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
#define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
tree tmp;
tree args;
tree dtype;
+ tree dt_parm_addr;
int n_dim;
int itype;
int rank = 0;
The call for the scalar part transfers:
(address, name, type, kind or string_length, dtype) */
- NML_FIRST_ARG (addr_expr);
+ dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ NML_FIRST_ARG (dt_parm_addr);
+ NML_ADD_ARG (addr_expr);
NML_ADD_ARG (string);
NML_ADD_ARG (IARG (ts->kind));
NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
NML_ADD_ARG (dtype);
- tmp = gfc_build_function_call (iocall_set_nml_val, args);
+ tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL], args);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
{
- NML_FIRST_ARG (IARG (n_dim));
+ NML_FIRST_ARG (dt_parm_addr);
+ NML_ADD_ARG (IARG (n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
- tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
+ tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL_DIM], args);
gfc_add_expr_to_block (block, tmp);
}
out by now. */
static tree
-build_dt (tree * function, gfc_code * code)
+build_dt (tree function, gfc_code * code)
{
- stmtblock_t block, post_block;
+ stmtblock_t block, post_block, post_end_block;
gfc_dt *dt;
- tree tmp;
+ tree tmp, var;
gfc_expr *nmlname;
gfc_namelist *nml;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
+ gfc_init_block (&post_end_block);
+
+ var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
+
+ set_error_locus (&block, var, &code->loc);
+
+ if (last_dt == IOLENGTH)
+ {
+ gfc_inquire *inq;
+
+ inq = code->ext.inquire;
- set_error_locus (&block, &code->loc);
- dt = code->ext.dt;
+ /* First check that preconditions are met. */
+ gcc_assert (inq != NULL);
+ gcc_assert (inq->iolength != NULL);
- gcc_assert (dt != NULL);
+ /* Connect to the iolength variable. */
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_iolength, inq->iolength);
+ dt = NULL;
+ }
+ else
+ {
+ dt = code->ext.dt;
+ gcc_assert (dt != NULL);
+ }
- if (dt->io_unit)
+ if (dt && dt->io_unit)
{
if (dt->io_unit->ts.type == BT_CHARACTER)
{
- set_internal_unit (&block,
- ioparm_internal_unit,
- ioparm_internal_unit_len,
- ioparm_internal_unit_desc,
- dt->io_unit);
+ mask |= set_internal_unit (&block, var, dt->io_unit);
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
}
else
- set_parameter_value (&block, ioparm_unit, dt->io_unit);
+ set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
}
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
- if (dt->rec)
- set_parameter_value (&block, ioparm_rec, dt->rec);
+ if (dt)
+ {
+ if (dt->rec)
+ mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
- if (dt->advance)
- set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
- dt->advance);
+ if (dt->advance)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
+ dt->advance);
- if (dt->format_expr)
- set_string (&block, &post_block, ioparm_format, ioparm_format_len,
- dt->format_expr);
+ if (dt->format_expr)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+ dt->format_expr);
- if (dt->format_label)
- {
- if (dt->format_label == &format_asterisk)
- set_flag (&block, ioparm_list_format);
- else
- set_string (&block, &post_block, ioparm_format,
- ioparm_format_len, dt->format_label->format);
- }
+ if (dt->format_label)
+ {
+ if (dt->format_label == &format_asterisk)
+ mask |= IOPARM_dt_list_format;
+ else
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+ dt->format_label->format);
+ }
- if (dt->iomsg)
- set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
- dt->iomsg);
+ if (dt->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ dt->iomsg);
- if (dt->iostat)
- set_parameter_ref (&block, ioparm_iostat, dt->iostat);
+ if (dt->iostat)
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_common_iostat, dt->iostat);
- if (dt->size)
- set_parameter_ref (&block, ioparm_size, dt->size);
+ if (dt->size)
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_size, dt->size);
- if (dt->err)
- set_flag (&block, ioparm_err);
+ if (dt->err)
+ mask |= IOPARM_common_err;
- if (dt->eor)
- set_flag(&block, ioparm_eor);
+ if (dt->eor)
+ mask |= IOPARM_common_eor;
- if (dt->end)
- set_flag(&block, ioparm_end);
+ if (dt->end)
+ mask |= IOPARM_common_end;
- if (dt->namelist)
- {
- if (dt->format_expr || dt->format_label)
- gfc_internal_error ("build_dt: format with namelist");
+ if (dt->namelist)
+ {
+ if (dt->format_expr || dt->format_label)
+ gfc_internal_error ("build_dt: format with namelist");
+
+ nmlname = gfc_new_nml_name_expr (dt->namelist->name);
- nmlname = gfc_new_nml_name_expr(dt->namelist->name);
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
+ nmlname);
- set_string (&block, &post_block, ioparm_namelist_name,
- ioparm_namelist_name_len, nmlname);
+ if (last_dt == READ)
+ mask |= IOPARM_dt_namelist_read_mode;
- if (last_dt == READ)
- set_flag (&block, ioparm_namelist_read_mode);
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- for (nml = dt->namelist->namelist; nml; nml = nml->next)
- transfer_namelist_element (&block, nml->sym->name, nml->sym,
- NULL, NULL);
+ dt_parm = var;
+
+ for (nml = dt->namelist->namelist; nml; nml = nml->next)
+ transfer_namelist_element (&block, nml->sym->name, nml->sym,
+ NULL, NULL);
+ }
+ else
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
}
+ else
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_function_call (*function, NULL_TREE);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (function, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
+ dt_parm = var;
+ dt_post_end_block = &post_end_block;
+
+ gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
+
+ dt_parm = NULL;
+ dt_post_end_block = NULL;
+
return gfc_finish_block (&block);
}
tree
gfc_trans_iolength (gfc_code * code)
{
- stmtblock_t block;
- gfc_inquire *inq;
- tree dt;
-
- gfc_init_block (&block);
-
- set_error_locus (&block, &code->loc);
-
- inq = code->ext.inquire;
-
- /* First check that preconditions are met. */
- gcc_assert (inq != NULL);
- gcc_assert (inq->iolength != NULL);
-
- /* Connect to the iolength variable. */
- if (inq->iolength)
- set_parameter_ref (&block, ioparm_iolength, inq->iolength);
-
- /* Actual logic. */
last_dt = IOLENGTH;
- dt = build_dt(&iocall_iolength, code);
-
- gfc_add_expr_to_block (&block, dt);
-
- return gfc_finish_block (&block);
+ return build_dt (iocall[IOCALL_IOLENGTH], code);
}
tree
gfc_trans_read (gfc_code * code)
{
-
last_dt = READ;
- return build_dt (&iocall_read, code);
+ return build_dt (iocall[IOCALL_READ], code);
}
tree
gfc_trans_write (gfc_code * code)
{
-
last_dt = WRITE;
- return build_dt (&iocall_write, code);
+ return build_dt (iocall[IOCALL_WRITE], code);
}
switch (last_dt)
{
case READ:
- function = iocall_read_done;
+ function = iocall[IOCALL_READ_DONE];
break;
case WRITE:
- function = iocall_write_done;
+ function = iocall[IOCALL_WRITE_DONE];
break;
case IOLENGTH:
- function = iocall_iolength_done;
+ function = iocall[IOCALL_IOLENGTH_DONE];
break;
default:
gcc_unreachable ();
}
- tmp = gfc_build_function_call (function, NULL);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = gfc_chainon_list (NULL_TREE, tmp);
+ tmp = gfc_build_function_call (function, tmp);
gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, dt_post_end_block);
+ gfc_init_block (dt_post_end_block);
if (last_dt != IOLENGTH)
{
gcc_assert (code->ext.dt != NULL);
- io_result (&block, code->ext.dt->err,
+ io_result (&block, dt_parm, code->ext.dt->err,
code->ext.dt->end, code->ext.dt->eor);
}
{
case BT_INTEGER:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_integer;
+ function = iocall[IOCALL_X_INTEGER];
break;
case BT_REAL:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_real;
+ function = iocall[IOCALL_X_REAL];
break;
case BT_COMPLEX:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_complex;
+ function = iocall[IOCALL_X_COMPLEX];
break;
case BT_LOGICAL:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_logical;
+ function = iocall[IOCALL_X_LOGICAL];
break;
case BT_CHARACTER:
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
}
- function = iocall_x_character;
+ function = iocall[IOCALL_X_CHARACTER];
break;
case BT_DERIVED:
internal_error ("Bad IO basetype (%d)", ts->type);
}
- args = gfc_chainon_list (NULL_TREE, addr_expr);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+ args = gfc_chainon_list (args, addr_expr);
args = gfc_chainon_list (args, arg2);
tmp = gfc_build_function_call (function, args);
kind_arg = build_int_cst (NULL_TREE, ts->kind);
- args = gfc_chainon_list (NULL_TREE, addr_expr);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+ args = gfc_chainon_list (args, addr_expr);
args = gfc_chainon_list (args, kind_arg);
args = gfc_chainon_list (args, charlen_arg);
- tmp = gfc_build_function_call (iocall_x_array, args);
+ tmp = gfc_build_function_call (iocall[IOCALL_X_ARRAY], args);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_add_block_to_block (&se->pre, &se->post);
}
+2005-11-21 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/24774
+ * gfortran.dg/inquire_9.f90: New test.
+
+ PR fortran/21647
+ * gfortran.fortran-torture/execute/inquire_5.f90: New test.
+
2005-11-21 Eric Botcazou <ebotcazou@libertysurf.fr>
PR libfortran/24432
--- /dev/null
+! PR fortran/24774
+! { dg-do run }
+ logical :: l
+ l = .true.
+ inquire (file='inquire_9 file that should not exist', exist=l)
+ if (l) call abort
+ l = .true.
+ inquire (unit=-16, exist=l)
+ if (l) call abort
+ open (unit=16, file='inquire_9.tst')
+ print (unit=16, fmt='(a)'), 'Test'
+ l = .false.
+ inquire (unit=16, exist=l)
+ if (.not.l) call abort
+ l = .false.
+ inquire (file='inquire_9.tst', exist=l)
+ if (.not.l) call abort
+ close (unit=16)
+ l = .false.
+ inquire (file='inquire_9.tst', exist=l)
+ if (.not.l) call abort
+ open (unit=16, file='inquire_9.tst')
+ close (unit=16, status='delete')
+end
--- /dev/null
+! PR fortran/21647
+program inquire_5
+ integer (kind = 8) :: unit8
+ logical (kind = 8) :: exist8
+ integer (kind = 4) :: unit4
+ logical (kind = 4) :: exist4
+ integer (kind = 2) :: unit2
+ logical (kind = 2) :: exist2
+ integer (kind = 1) :: unit1
+ logical (kind = 1) :: exist1
+ character (len = 6) :: del
+ unit8 = 78
+ open (file = 'inquire_5.txt', unit = unit8)
+ unit8 = -1
+ exist8 = .false.
+ unit4 = -1
+ exist4 = .false.
+ unit2 = -1
+ exist2 = .false.
+ unit1 = -1
+ exist1 = .false.
+ inquire (file = 'inquire_5.txt', number = unit8, exist = exist8)
+ if (unit8 .ne. 78 .or. .not. exist8) call abort
+ inquire (file = 'inquire_5.txt', number = unit4, exist = exist4)
+ if (unit4 .ne. 78 .or. .not. exist4) call abort
+ inquire (file = 'inquire_5.txt', number = unit2, exist = exist2)
+ if (unit2 .ne. 78 .or. .not. exist2) call abort
+ inquire (file = 'inquire_5.txt', number = unit1, exist = exist1)
+ if (unit1 .ne. 78 .or. .not. exist1) call abort
+ del = 'delete'
+ close (unit = 78, status = del)
+end
+2005-11-21 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/24774
+ PR fortran/14943
+ PR fortran/21647
+ * Makefile.am (AM_CPPFLAGS): Add gcc directories as -I paths,
+ add -D_GNU_SOURCE.
+ * Makefile.in: Regenerated.
+ * acinclude.m4 (LIBGFOR_CHECK_SYNC_FETCH_AND_ADD,
+ LIBGFOR_CHECK_GTHR_DEFAULT, LIBGFOR_CHECK_PRAGMA_WEAK): New macros.
+ * configure.ac: Add them.
+ * configure: Rebuilt.
+ * config.h.in: Rebuilt.
+ * libtool-version: Bump libgfortran.so SONAME to libgfortran.so.1.
+ * libgfortran.h (library_start, show_locus, internal_error,
+ generate_error, find_option): Add st_parameter_common * argument.
+ (library_end): Change into a dummy macro.
+ * io/io.h: Include gthr.h.
+ (SUPPORTS_WEAK): Define if HAVE_PRAGMA_WEAK.
+ (CHARACTER): Remove define.
+ (st_parameter, global_t): Remove typedef.
+ (ioparm, g, ionml, current_unit): Remove variables.
+ (init_error_stream): Remove prototype.
+ (CHARACTER1, CHARACTER2): Define.
+ (st_parameter_common, st_parameter_open, st_parameter_close,
+ st_parameter_filepos, st_parameter_inquire, st_parameter_dt): New
+ typedefs.
+ (IOPARM_LIBRETURN_MASK, IOPARM_LIBRETURN_OK, IOPARM_LIBRETURN_ERROR,
+ IOPARM_LIBRETURN_END, IOPARM_LIBRETURN_EOR, IOPARM_ERR, IOPARM_END,
+ IOPARM_EOR, IOPARM_HAS_IOSTAT, IOPARM_HAS_IOMSG, IOPARM_COMMON_MASK,
+ IOPARM_OPEN_HAS_RECL_IN, IOPARM_OPEN_HAS_FILE, IOPARM_OPEN_HAS_STATUS,
+ IOPARM_OPEN_HAS_ACCESS, IOPARM_OPEN_HAS_FORM, IOPARM_OPEN_HAS_BLANK,
+ IOPARM_OPEN_HAS_POSITION, IOPARM_OPEN_HAS_ACTION,
+ IOPARM_OPEN_HAS_DELIM, IOPARM_OPEN_HAS_PAD, IOPARM_CLOSE_HAS_STATUS,
+ IOPARM_INQUIRE_HAS_EXIST, IOPARM_INQUIRE_HAS_OPENED,
+ IOPARM_INQUIRE_HAS_NUMBER, IOPARM_INQUIRE_HAS_NAMED,
+ IOPARM_INQUIRE_HAS_NEXTREC, IOPARM_INQUIRE_HAS_RECL_OUT,
+ IOPARM_INQUIRE_HAS_FILE, IOPARM_INQUIRE_HAS_ACCESS,
+ IOPARM_INQUIRE_HAS_FORM, IOPARM_INQUIRE_HAS_BLANK,
+ IOPARM_INQUIRE_HAS_POSITION, IOPARM_INQUIRE_HAS_ACTION,
+ IOPARM_INQUIRE_HAS_DELIM, IOPARM_INQUIRE_HAS_PAD,
+ IOPARM_INQUIRE_HAS_NAME, IOPARM_INQUIRE_HAS_SEQUENTIAL,
+ IOPARM_INQUIRE_HAS_DIRECT, IOPARM_INQUIRE_HAS_FORMATTED,
+ IOPARM_INQUIRE_HAS_UNFORMATTED, IOPARM_INQUIRE_HAS_READ,
+ IOPARM_INQUIRE_HAS_WRITE, IOPARM_INQUIRE_HAS_READWRITE,
+ IOPARM_DT_LIST_FORMAT, IOPARM_DT_NAMELIST_READ_MODE,
+ IOPARM_DT_HAS_REC, IOPARM_DT_HAS_SIZE, IOPARM_DT_HAS_IOLENGTH,
+ IOPARM_DT_HAS_FORMAT, IOPARM_DT_HAS_ADVANCE,
+ IOPARM_DT_HAS_INTERNAL_UNIT, IOPARM_DT_HAS_NAMELIST_NAME,
+ IOPARM_DT_IONML_SET): Define.
+ (gfc_unit): Add lock, waiting and close fields. Change file
+ from flexible array member into pointer to char.
+ (open_external): Add st_parameter_open * argument.
+ (find_file, file_exists): Add file and file_len arguments.
+ (flush_all_units): New prototype.
+ (max_offset, unit_root, unit_lock): New variable.
+ (is_internal_unit, is_array_io, next_array_record,
+ parse_format, next_format, unget_format, format_error,
+ read_block, write_block, next_record, convert_real,
+ read_a, read_f, read_l, read_x, read_radix, read_decimal,
+ list_formatted_read, finish_list_read, namelist_read,
+ namelist_write, write_a, write_b, write_d, write_e, write_en,
+ write_es, write_f, write_i, write_l, write_o, write_x, write_z,
+ list_formatted_write, get_unit): Add st_parameter_dt * argument.
+ (insert_unit): Remove prototype.
+ (find_or_create_unit, unlock_unit): New prototype.
+ (new_unit): Return gfc_unit *. Add st_parameter_open *
+ and gfc_unit * arguments.
+ (free_fnodes): Remove prototype.
+ (free_format_data): New prototype.
+ (scratch): Remove.
+ (init_at_eol): Remove prototype.
+ (free_ionml): New prototype.
+ (inc_waiting_locked, predec_waiting_locked, dec_waiting_unlocked):
+ New inline functions.
+ * io/unit.c (max_offset, unit_root, unit_lock): New variables.
+ (insert): Adjust os_error caller.
+ (insert_unit): Made static. Allocate memory here, initialize
+ lock and after inserting it return it, locked.
+ (delete_unit): Adjust for deletion of g.
+ (find_unit_1): New function.
+ (find_unit): Use it.
+ (find_or_create_unit): New function.
+ (get_unit): Add dtp argument, change meaning of the int argument
+ as creation request flag. Adjust for different st_* calling
+ conventions, lock internal unit's lock before returning it
+ and removal of g. Call find_unit_1 instead of find_unit.
+ (is_internal_unit, is_array_io): Add dtp argument, adjust for
+ removal of most of global variables.
+ (init_units): Initialize unit_lock. Adjust insert_unit callers
+ and adjust for g removal.
+ (close_unit_1): New function.
+ (close_unit): Use it.
+ (unlock_unit): New function.
+ (close_units): Lock unit_lock, use close_unit_1 rather than
+ close_unit.
+ * io/close.c (st_close): Add clp argument. Adjust for new
+ st_* calling conventions and internal function API changes.
+ * io/file_pos.c (st_backspace, st_endfile, st_rewind, st_flush):
+ Add fpp argument. Adjust for new st_* calling conventions and
+ internal function API changes.
+ (formatted_backspace, unformatted_backspace): Likewise. Add
+ u argument.
+ * io/open.c (edit_modes, st_open): Add opp argument. Adjust for
+ new st_* calling conventions and internal function API changes.
+ (already_open): Likewise. If not HAVE_UNLINK_OPEN_FILE, unlink
+ scratch file. Instead of calling close_unit just call sclose,
+ free u->file if any and clear a few u fields before calling
+ new_unit.
+ (new_unit): Return gfc_unit *. Add opp and u arguments.
+ Adjust for new st_* calling conventions and internal function
+ API changes. Don't allocate unit here, rather than work with
+ already created unit u already locked on entry. In case
+ of failure, close_unit it.
+ * io/unix.c: Include unix.h.
+ (BUFFER_SIZE, unix_stream): Moved to unix.h.
+ (unit_to_fd): Add unlock_unit call.
+ (tempfile): Add opp argument, use its fields rather than ioparm.
+ (regular_file): Likewise.
+ (open_external): Likewise. Only unlink file if fd >= 0.
+ (init_error_stream): Add error argument, set structure it points
+ to rather than filling static variable and returning its address.
+ (FIND_FILE0_DECL, FIND_FILE0_ARGS): Define.
+ (find_file0): Use them. Don't crash if u->s == NULL.
+ (find_file): Add file and file_len arguments, use them instead
+ of ioparm. Add locking. Pass either an array of 2 struct stat
+ or file and file_len pair to find_file0.
+ (flush_all_units_1, flush_all_units): New functions.
+ (file_exists): Add file and file_len arguments, use them instead
+ of ioparm.
+ * io/unix.h: New file.
+ * io/lock.c (ioparm, g, ionml): Remove variables.
+ (library_start): Add cmp argument, adjust for new st_* calling
+ conventions.
+ (library_end): Remove.
+ (free_ionml): New function.
+ * io/inquire.c (inquire_via_unit, inquire_via_filename,
+ st_inquire): Add iqp argument, adjust for new st_* calling
+ conventions and internal function API changes.
+ * io/format.c (FARRAY_SIZE): Decrease to 64.
+ (fnode_array, format_data): New typedefs.
+ (avail, array, format_string, string, error, saved_token, value,
+ format_string_len, reversion_ok, saved_format): Remove variables.
+ (colon_node): Add const.
+ (free_fnode, free_fnodes): Remove.
+ (free_format_data): New function.
+ (next_char, unget_char, get_fnode, format_lex, parse_format_list,
+ format_error, parse_format, revert, unget_format, next_test): Add
+ fmt or dtp arguments, pass it all around, adjust for internal
+ function API changes and adjust for removal of global variables.
+ (next_format): Likewise. Constify return type.
+ (next_format0): Constify return type.
+ * io/transfer.c (current_unit, sf_seen_eor, eor_condition, max_pos,
+ skips, pending_spaces, scratch, line_buffer, advance_status,
+ transfer): Remove variables.
+ (transfer_integer, transfer_real, transfer_logical,
+ transfer_character, transfer_complex, transfer_array, current_mode,
+ read_sf, read_block, read_block_direct, write_block,
+ write_block_direct, unformatted_read, unformatted_write,
+ type_name, write_constant_string, require_type,
+ formatted_transfer_scalar, us_read, us_write, pre_position,
+ data_transfer_init, next_record_r, next_record_w, next_record,
+ finalize_transfer, iolength_transfer, iolength_transfer_init,
+ st_iolength, st_iolength_done, st_read, st_read_done, st_write,
+ st_write_done, st_set_nml_var, st_set_nml_var_dim,
+ next_array_record): Add dtp argument, pass it all around, adjust for
+ internal function API changes and removal of global variables.
+ * io/list_read.c (repeat_count, saved_length, saved_used,
+ input_complete, at_eol, comma_flag, last_char, saved_string,
+ saved_type, namelist_mode, nml_read_error, value, parse_err_msg,
+ nml_err_msg, prev_nl): Remove variables.
+ (push_char, free_saved, next_char, unget_char, eat_spaces,
+ eat_separator, finish_separator, nml_bad_return, convert_integer,
+ parse_repeat, read_logical, read_integer, read_character,
+ parse_real, read_complex, read_real, check_type,
+ list_formatted_read_scalar, list_formatted_read, finish_list_read,
+ find_nml_node, nml_untouch_nodes, nml_match_name, nml_query,
+ namelist_read): Add dtp argument, pass it all around, adjust for
+ internal function API changes and removal of global variables.
+ (nml_parse_qualifier): Likewise. Add parse_err_msg argument.
+ (nml_read_obj): Likewise. Add pprev_nl, nml_err_msg, clow and
+ chigh arguments.
+ (nml_get_obj_data): Likewise. Add pprev_nl and nml_err_msg
+ arguments.
+ (init_at_eol): Removed.
+ * io/read.c (convert_real, read_l, read_a, next_char, read_decimal,
+ read_radix, read_f, read_x): Add dtp argument, pass it all around,
+ adjust for internal function API changes and removal of global
+ variables.
+ (set_integer): Adjust internal_error caller.
+ * io/write.c (no_leading_blank, nml_delim): Remove variables.
+ (write_a, calculate_sign, calculate_G_format, output_float,
+ write_l, write_float, write_int, write_decimal, write_i, write_b,
+ write_o, write_z, write_d, write_e, write_f, write_en, write_es,
+ write_x, write_char, write_logical, write_integer, write_character,
+ write_real, write_complex, write_separator,
+ list_formatted_write_scalar, list_formatted_write, nml_write_obj,
+ namelist_write): Add dtp argument, pass it all around, adjust for
+ internal function API changes and removal of global variables.
+ (extract_int, extract_uint, extract_real): Adjust internal_error
+ callers.
+ * runtime/fpu.c (_GNU_SOURCE): Don't define here.
+ * runtime/error.c: Include ../io/unix.h.
+ (filename, line): Remove variables.
+ (st_printf): Pass address of a local variable to init_error_stream.
+ (show_locus): Add cmp argument. Use fields it points to rather than
+ filename and line variables.
+ (os_error, runtime_error): Remove show_locus calls.
+ (internal_error): Add cmp argument. Pass it down to show_locus.
+ (generate_error): Likewise. Use flags bitmask instead of non-NULL
+ check for iostat and iomsg parameter presence, adjust for st_*
+ calling convention changes.
+ * runtime/stop.c (stop_numeric, stop_string): Remove show_locus
+ calls.
+ * runtime/pause.c (pause_numeric, pause_string): Likewise.
+ * runtime/string.c: Include ../io/io.h.
+ (find_option): Add cmp argument. Pass it down to generate_error.
+ * intrinsics/flush.c (recursive_flush): Remove.
+ (flush_i4, flush_i8): Use flush_all_units. Add unlock_unit
+ call.
+ * intrinsics/rand.c: Include ../io/io.h.
+ (rand_seed_lock): New variable.
+ (srand, irand): Add locking.
+ (init): New constructor function.
+ * intrinsics/random.c: Include ../io/io.h.
+ (random_lock): New variable.
+ (random_r4, random_r8, arandom_r4, arandom_r8): Add locking.
+ (random_seed): Likewise. open failed if fd < 0. Set i correctly.
+ (init): New constructor function.
+ * intrinsics/system_clock.c (tp0, t0): Remove.
+ (system_clock_4, system_clock_8): Don't subtract tp0/t0 from current
+ time, use just integer arithmetics.
+ * intrinsics/tty.c (isatty_l4, isatty_l8, ttynam_sub): Add
+ unlock_unit calls.
+
2005-11-20 Richard Henderson <rth@redhat.com>
* Makefile.am: Revert 2005-11-14 change. Enable -free-vectorize
## io.h conflicts with some a system header on some platforms, so
## use -iquote
-AM_CPPFLAGS = -iquote$(srcdir)/io
+AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
+ -I$(srcdir)/$(MULTISRCTOP)../gcc/config \
+ -I$(MULTIBUILDTOP)../../gcc -D_GNU_SOURCE
gfor_io_src= \
io/close.c \
libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` -lm $(extra_ldflags_libgfortran)
libgfortranbegin_la_SOURCES = fmain.c
libgfortranbegin_la_LDFLAGS = -static
-AM_CPPFLAGS = -iquote$(srcdir)/io
+AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
+ -I$(srcdir)/$(MULTISRCTOP)../gcc/config \
+ -I$(MULTIBUILDTOP)../../gcc -D_GNU_SOURCE
+
gfor_io_src = \
io/close.c \
io/file_pos.c \
[Define to 1 if the target supports __attribute__((alias(...))).])
fi])
+dnl Check whether the target supports __sync_fetch_and_add.
+AC_DEFUN([LIBGFOR_CHECK_SYNC_FETCH_AND_ADD], [
+ AC_CACHE_CHECK([whether the target supports __sync_fetch_and_add],
+ have_sync_fetch_and_add, [
+ AC_TRY_LINK([int foovar = 0;], [
+if (foovar <= 0) return __sync_fetch_and_add (&foovar, 1);
+if (foovar > 10) return __sync_add_and_fetch (&foovar, -1);],
+ have_sync_fetch_and_add=yes, have_sync_fetch_and_add=no)])
+ if test $have_sync_fetch_and_add = yes; then
+ AC_DEFINE(HAVE_SYNC_FETCH_AND_ADD, 1,
+ [Define to 1 if the target supports __sync_fetch_and_add])
+ fi])
+
+dnl Check if threads are supported.
+AC_DEFUN([LIBGFOR_CHECK_GTHR_DEFAULT], [
+ AC_CACHE_CHECK([configured target thread model],
+ target_thread_file, [
+target_thread_file=`$CC -v 2>&1 | sed -n 's/^Thread model: //p'`])
+
+ if test $target_thread_file != single; then
+ AC_DEFINE(HAVE_GTHR_DEFAULT, 1,
+ [Define if the compiler has a thread header that is non single.])
+ fi])
+
+dnl Check for pragma weak.
+AC_DEFUN([LIBGFOR_CHECK_PRAGMA_WEAK], [
+ AC_CACHE_CHECK([whether pragma weak works],
+ have_pragma_weak, [
+ gfor_save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -Wunknown-pragmas"
+ AC_TRY_COMPILE([void foo (void);
+#pragma weak foo], [if (foo) foo ();],
+ have_pragma_weak=yes, have_pragma_weak=no)])
+ if test $have_pragma_weak = yes; then
+ AC_DEFINE(HAVE_PRAGMA_WEAK, 1,
+ [Define to 1 if the target supports #pragma weak])
+ fi])
+
dnl Check whether target can unlink a file still open.
AC_DEFUN([LIBGFOR_CHECK_UNLINK_OPEN_FILE], [
AC_CACHE_CHECK([whether the target can unlink an open file],
/* libc includes getuid */
#undef HAVE_GETUID
+/* Define if the compiler has a thread header that is non single. */
+#undef HAVE_GTHR_DEFAULT
+
/* libm includes hypot */
#undef HAVE_HYPOT
/* libm includes powl */
#undef HAVE_POWL
+/* Define to 1 if the target supports #pragma weak */
+#undef HAVE_PRAGMA_WEAK
+
/* libm includes round */
#undef HAVE_ROUND
/* Define to 1 if you have the `symlink' function. */
#undef HAVE_SYMLINK
+/* Define to 1 if the target supports __sync_fetch_and_add */
+#undef HAVE_SYNC_FETCH_AND_ADD
+
/* Define to 1 if you have the <sys/mman.h> header file. */
#undef HAVE_SYS_MMAN_H
fi
+# Check out sync builtins support.
+
+ echo "$as_me:$LINENO: checking whether the target supports __sync_fetch_and_add" >&5
+echo $ECHO_N "checking whether the target supports __sync_fetch_and_add... $ECHO_C" >&6
+if test "${have_sync_fetch_and_add+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+ if test x$gcc_no_link = xyes; then
+ { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5
+echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;}
+ { (exit 1); exit 1; }; }
+fi
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+int foovar = 0;
+int
+main ()
+{
+
+if (foovar <= 0) return __sync_fetch_and_add (&foovar, 1);
+if (foovar > 10) return __sync_add_and_fetch (&foovar, -1);
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+ (eval $ac_link) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest$ac_exeext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ have_sync_fetch_and_add=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+have_sync_fetch_and_add=no
+fi
+rm -f conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+fi
+echo "$as_me:$LINENO: result: $have_sync_fetch_and_add" >&5
+echo "${ECHO_T}$have_sync_fetch_and_add" >&6
+ if test $have_sync_fetch_and_add = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_SYNC_FETCH_AND_ADD 1
+_ACEOF
+
+ fi
+
+# Check out thread support.
+
+ echo "$as_me:$LINENO: checking configured target thread model" >&5
+echo $ECHO_N "checking configured target thread model... $ECHO_C" >&6
+if test "${target_thread_file+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+target_thread_file=`$CC -v 2>&1 | sed -n 's/^Thread model: //p'`
+fi
+echo "$as_me:$LINENO: result: $target_thread_file" >&5
+echo "${ECHO_T}$target_thread_file" >&6
+
+ if test $target_thread_file != single; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_GTHR_DEFAULT 1
+_ACEOF
+
+ fi
+
+# Check out #pragma weak.
+
+ echo "$as_me:$LINENO: checking whether pragma weak works" >&5
+echo $ECHO_N "checking whether pragma weak works... $ECHO_C" >&6
+if test "${have_pragma_weak+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+ gfor_save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -Wunknown-pragmas"
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+void foo (void);
+#pragma weak foo
+int
+main ()
+{
+if (foo) foo ();
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+ (eval $ac_compile) 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } &&
+ { ac_try='test -z "$ac_c_werror_flag"
+ || test ! -s conftest.err'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; } &&
+ { ac_try='test -s conftest.$ac_objext'
+ { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+ (eval $ac_try) 2>&5
+ ac_status=$?
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); }; }; then
+ have_pragma_weak=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+have_pragma_weak=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+echo "$as_me:$LINENO: result: $have_pragma_weak" >&5
+echo "${ECHO_T}$have_pragma_weak" >&6
+ if test $have_pragma_weak = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_PRAGMA_WEAK 1
+_ACEOF
+
+ fi
+
# Various other checks on target
echo "$as_me:$LINENO: checking whether the target can unlink an open file" >&5
LIBGFOR_CHECK_ATTRIBUTE_DLLEXPORT
LIBGFOR_CHECK_ATTRIBUTE_ALIAS
+# Check out sync builtins support.
+LIBGFOR_CHECK_SYNC_FETCH_AND_ADD
+
+# Check out thread support.
+LIBGFOR_CHECK_GTHR_DEFAULT
+
+# Check out #pragma weak.
+LIBGFOR_CHECK_PRAGMA_WEAK
+
# Various other checks on target
LIBGFOR_CHECK_UNLINK_OPEN_FILE
/* SUBROUTINE FLUSH(UNIT)
INTEGER, INTENT(IN), OPTIONAL :: UNIT */
-static void
-recursive_flush (gfc_unit *us)
-{
- /* There can be no open files. */
- if (us == NULL)
- return;
-
- flush (us->s);
- recursive_flush (us->left);
- recursive_flush (us->right);
-}
-
-
extern void flush_i4 (GFC_INTEGER_4 *);
export_proto(flush_i4);
/* flush all streams */
if (unit == NULL)
- {
- us = g.unit_root;
- recursive_flush(us);
- }
+ flush_all_units ();
else
{
- us = find_unit(*unit);
+ us = find_unit (*unit);
if (us != NULL)
- flush (us->s);
+ {
+ flush (us->s);
+ unlock_unit (us);
+ }
}
}
/* flush all streams */
if (unit == NULL)
- {
- us = g.unit_root;
- recursive_flush(us);
- }
+ flush_all_units ();
else
{
- us = find_unit(*unit);
+ us = find_unit (*unit);
if (us != NULL)
- flush (us->s);
+ {
+ flush (us->s);
+ unlock_unit (us);
+ }
}
}
/* Implementation of the IRAND, RAND, and SRAND intrinsics.
- Copyright (C) 2004 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2005 Free Software Foundation, Inc.
Contributed by Steven G. Kargl <kargls@comcast.net>.
This file is part of the GNU Fortran 95 runtime library (libgfortran).
#include "config.h"
#include "libgfortran.h"
+#include "../io/io.h"
#define GFC_RAND_A 16807
#define GFC_RAND_M 2147483647
#define GFC_RAND_M1 (GFC_RAND_M - 1)
static GFC_UINTEGER_8 rand_seed = 1;
+#ifdef __GTHREAD_MUTEX_INIT
+static __gthread_mutex_t rand_seed_lock = __GTHREAD_MUTEX_INIT;
+#else
+static __gthread_mutex_t rand_seed_lock;
+#endif
/* Set the seed of the irand generator. Note 0 is a bad seed. */
void
PREFIX(srand) (GFC_INTEGER_4 *i)
{
+ __gthread_mutex_lock (&rand_seed_lock);
srand_internal (*i);
+ __gthread_mutex_unlock (&rand_seed_lock);
}
/* Return an INTEGER in the range [1,GFC_RAND_M-1]. */
else
j = 0;
+ __gthread_mutex_lock (&rand_seed_lock);
+
switch (j)
{
/* Return the next RN. */
}
rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M;
+ j = (GFC_INTEGER_4) rand_seed;
+
+ __gthread_mutex_unlock (&rand_seed_lock);
- return (GFC_INTEGER_4) rand_seed;
+ return j;
}
iexport(irand);
{
return normalize_r4_i4 (irand (i) - 1, GFC_RAND_M1 - 1);
}
+
+#ifndef __GTHREAD_MUTEX_INIT
+static void __attribute__((constructor))
+init (void)
+{
+ __GTHREAD_MUTEX_INIT_FUNCTION (&rand_seed_lock);
+}
+#endif
Boston, MA 02110-1301, USA. */
#include "libgfortran.h"
+#include "../io/io.h"
extern void random_r4 (GFC_REAL_4 *);
iexport_proto(random_r4);
extern void arandom_r8 (gfc_array_r8 *);
export_proto(arandom_r8);
+#ifdef __GTHREAD_MUTEX_INIT
+static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT;
+#else
+static __gthread_mutex_t random_lock;
+#endif
+
#if 0
/* The Mersenne Twister code is currently commented out due to
void
random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
{
+ __gthread_mutex_lock (&random_lock);
+
/* Initialize the seed in system dependent manner. */
if (get == NULL && put == NULL && size == NULL)
{
int fd;
fd = open ("/dev/urandom", O_RDONLY);
- if (fd == 0)
+ if (fd < 0)
{
/* We dont have urandom. */
GFC_UINTEGER_4 s = (GFC_UINTEGER_4) seed;
/* Using urandom, might have a length issue. */
read (fd, &seed[0], sizeof (GFC_UINTEGER_4) * N);
close (fd);
+ i = N;
}
- return;
+ goto return_unlock;
}
/* Return the size of the seed */
if (size != NULL)
{
*size = N;
- return;
+ goto return_unlock;
}
/* if we have gotten to this pount we have a get or put
/* If this is the case the array is a temporary */
if (put->dim[0].stride == 0)
- return;
+ goto return_unlock;
/* This code now should do correct strides. */
for (i = 0; i < N; i++)
/* If this is the case the array is a temporary */
if (get->dim[0].stride == 0)
- return;
+ goto return_unlock;
/* This code now should do correct strides. */
for (i = 0; i < N; i++)
get->data[i * get->dim[0].stride] = seed[i];
}
+
+ random_unlock:
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_seed);
void
random_r4 (GFC_REAL_4 * harv)
{
+ __gthread_mutex_lock (&random_lock);
+
/* Regenerate if we need to. */
if (i >= N)
random_generate ();
/* Convert uint32 to REAL(KIND=4). */
*harv = (GFC_REAL_4) ((GFC_REAL_4) (GFC_UINTEGER_4) seed[i++] /
(GFC_REAL_4) (~(GFC_UINTEGER_4) 0));
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r4);
void
random_r8 (GFC_REAL_8 * harv)
{
+ __gthread_mutex_lock (&random_lock);
+
/* Regenerate if we need to, may waste one 32-bit value. */
if ((i + 1) >= N)
random_generate ();
*harv = ((GFC_REAL_8) ((((GFC_UINTEGER_8) seed[i+1]) << 32) + seed[i])) /
(GFC_REAL_8) (~(GFC_UINTEGER_8) 0);
i += 2;
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r8);
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
/* Set the elements. */
}
}
}
+
+ __gthread_mutex_unlock (&random_lock);
}
/* REAL(KIND=8) array. */
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
/* Set the elements. */
}
}
}
+
+ __gthread_mutex_unlock (&random_lock);
}
#else
{
GFC_UINTEGER_4 kiss;
+ __gthread_mutex_lock (&random_lock);
kiss = kiss_random_kernel ();
/* Burn a random number, so the REAL*4 and REAL*8 functions
produce similar sequences of random numbers. */
kiss_random_kernel ();
*x = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0);
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r4);
{
GFC_UINTEGER_8 kiss;
+ __gthread_mutex_lock (&random_lock);
kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32;
kiss += kiss_random_kernel ();
*x = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0);
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_r8);
index_type stride0;
index_type dim;
GFC_REAL_4 *dest;
+ GFC_UINTEGER_4 kiss;
int n;
dest = x->data;
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
- random_r4 (dest);
+ /* random_r4 (dest); */
+ kiss = kiss_random_kernel ();
+ /* Burn a random number, so the REAL*4 and REAL*8 functions
+ produce similar sequences of random numbers. */
+ kiss_random_kernel ();
+ *dest = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0);
/* Advance to the next element. */
dest += stride0;
}
}
}
+ __gthread_mutex_unlock (&random_lock);
}
/* This function fills a REAL(8) array with values from the uniform
index_type stride0;
index_type dim;
GFC_REAL_8 *dest;
+ GFC_UINTEGER_8 kiss;
int n;
dest = x->data;
stride0 = stride[0];
+ __gthread_mutex_lock (&random_lock);
+
while (dest)
{
- random_r8 (dest);
+ /* random_r8 (dest); */
+ kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32;
+ kiss += kiss_random_kernel ();
+ *dest = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0);
/* Advance to the next element. */
dest += stride0;
}
}
}
+ __gthread_mutex_unlock (&random_lock);
}
/* random_seed is used to seed the PRNG with either a default
{
int i;
+ __gthread_mutex_lock (&random_lock);
+
if (size == NULL && put == NULL && get == NULL)
{
/* From the standard: "If no argument is present, the processor assigns
for (i = 0; i < kiss_size; i++)
get->data[i * get->dim[0].stride] = (GFC_INTEGER_4) kiss_seed[i];
}
+
+ __gthread_mutex_unlock (&random_lock);
}
iexport(random_seed);
#endif /* mersenne twister */
+
+#ifndef __GTHREAD_MUTEX_INIT
+static void __attribute__((constructor))
+init (void)
+{
+ __GTHREAD_MUTEX_INIT_FUNCTION (&random_lock);
+}
+#endif
#endif
-#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
-static struct timeval tp0 = {-1, 0};
-#elif defined(HAVE_TIME_H)
-static time_t t0 = (time_t) -2;
-#endif
-
-
extern void system_clock_4 (GFC_INTEGER_4 *, GFC_INTEGER_4 *, GFC_INTEGER_4 *);
export_proto(system_clock_4);
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
struct timeval tp1;
struct timezone tzp;
- double t;
+
+ if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "tv_sec too small");
if (gettimeofday(&tp1, &tzp) == 0)
{
- if (tp0.tv_sec < 0)
- {
- tp0 = tp1;
- cnt = 0;
- }
+ GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK;
+ ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
else
- {
- /* TODO: Convert this to integer arithmetic. */
- t = (double) (tp1.tv_sec - tp0.tv_sec);
- t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
- t *= TCK;
-
- if (t > (double) GFC_INTEGER_4_HUGE)
- {
- /* Time has wrapped. */
- while (t > (double) GFC_INTEGER_4_HUGE)
- t -= (double) GFC_INTEGER_4_HUGE;
- tp0 = tp1;
- }
- cnt = (GFC_INTEGER_4) t;
- }
+ cnt = ucnt;
rate = TCK;
mx = GFC_INTEGER_4_HUGE;
}
return;
}
#elif defined(HAVE_TIME_H)
- time_t t, t1;
+ GFC_UINTEGER_4 ucnt;
- t1 = time(NULL);
+ if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "time_t too small");
- if (t1 == (time_t) -1)
- {
- cnt = - GFC_INTEGER_4_HUGE;
- mx = 0;
- }
- else if (t0 == (time_t) -2)
- t0 = t1;
+ ucnt = time (NULL);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
else
- {
- /* The timer counts in seconts, so for simplicity assume it never wraps.
- Even with 32-bit counters this only happens once every 68 years. */
- cnt = t1 - t0;
- mx = GFC_INTEGER_4_HUGE;
- }
+ cnt = ucnt;
+ mx = GFC_INTEGER_4_HUGE;
#else
cnt = - GFC_INTEGER_4_HUGE;
mx = 0;
void
system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate,
- GFC_INTEGER_8 *count_max)
+ GFC_INTEGER_8 *count_max)
{
GFC_INTEGER_8 cnt;
GFC_INTEGER_8 rate;
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
struct timeval tp1;
struct timezone tzp;
- double t;
+
+ if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "tv_sec too small");
if (gettimeofday(&tp1, &tzp) == 0)
{
- if (tp0.tv_sec < 0)
- {
- tp0 = tp1;
- cnt = 0;
- }
+ if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_8))
+ {
+ GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK;
+ ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
+ else
+ cnt = ucnt;
+ mx = GFC_INTEGER_4_HUGE;
+ }
else
- {
- /* TODO: Convert this to integer arithmetic. */
- t = (double) (tp1.tv_sec - tp0.tv_sec);
- t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
- t *= TCK;
-
- if (t > (double) GFC_INTEGER_8_HUGE)
- {
- /* Time has wrapped. */
- while (t > (double) GFC_INTEGER_8_HUGE)
- t -= (double) GFC_INTEGER_8_HUGE;
- tp0 = tp1;
- }
- cnt = (GFC_INTEGER_8) t;
- }
+ {
+ GFC_UINTEGER_8 ucnt = (GFC_UINTEGER_8) tp1.tv_sec * TCK;
+ ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+ if (ucnt > GFC_INTEGER_8_HUGE)
+ cnt = ucnt - GFC_INTEGER_8_HUGE - 1;
+ else
+ cnt = ucnt;
+ mx = GFC_INTEGER_8_HUGE;
+ }
rate = TCK;
- mx = GFC_INTEGER_8_HUGE;
}
else
{
return;
}
#elif defined(HAVE_TIME_H)
- time_t t, t1;
-
- t1 = time(NULL);
-
- if (t1 == (time_t) -1)
+ if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
+ internal_error (NULL, "time_t too small");
+ else if (sizeof (time_t) == sizeof (GFC_INTEGER_4))
{
- cnt = - GFC_INTEGER_8_HUGE;
- mx = 0;
+ GFC_UINTEGER_4 ucnt = time (NULL);
+ if (ucnt > GFC_INTEGER_4_HUGE)
+ cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
+ else
+ cnt = ucnt;
+ mx = GFC_INTEGER_4_HUGE;
}
- else if (t0 == (time_t) -2)
- t0 = t1;
else
{
- /* The timer counts in seconts, so for simplicity assume it never wraps.
- Even with 32-bit counters this only happens once every 68 years. */
- cnt = t1 - t0;
+ GFC_UINTEGER_8 ucnt = time (NULL);
+ if (ucnt > GFC_INTEGER_8_HUGE)
+ cnt = ucnt - GFC_INTEGER_8_HUGE - 1;
+ else
+ cnt = ucnt;
mx = GFC_INTEGER_8_HUGE;
}
#else
isatty_l4 (int *unit)
{
gfc_unit *u;
+ GFC_LOGICAL_4 ret = 0;
u = find_unit (*unit);
if (u != NULL)
- return (GFC_LOGICAL_4) stream_isatty (u->s);
- else
- return 0;
+ {
+ ret = (GFC_LOGICAL_4) stream_isatty (u->s);
+ unlock_unit (u);
+ }
+ return ret;
}
isatty_l8 (int *unit)
{
gfc_unit *u;
+ GFC_LOGICAL_8 ret = 0;
u = find_unit (*unit);
if (u != NULL)
- return (GFC_LOGICAL_8) stream_isatty (u->s);
- else
- return 0;
+ {
+ ret = (GFC_LOGICAL_8) stream_isatty (u->s);
+ unlock_unit (u);
+ }
+ return ret;
}
while (*n && i < name_len)
name[i++] = *(n++);
}
+ unlock_unit (u);
}
}
};
-extern void st_close (void);
+extern void st_close (st_parameter_close *);
export_proto(st_close);
void
-st_close (void)
+st_close (st_parameter_close *clp)
{
close_status status;
gfc_unit *u;
path = NULL;
#endif
- library_start ();
+ library_start (&clp->common);
- status = (ioparm.status == NULL) ? CLOSE_UNSPECIFIED :
- find_option (ioparm.status, ioparm.status_len, status_opt,
- "Bad STATUS parameter in CLOSE statement");
+ status = !(clp->common.flags & IOPARM_CLOSE_HAS_STATUS) ? CLOSE_UNSPECIFIED :
+ find_option (&clp->common, clp->status, clp->status_len,
+ status_opt, "Bad STATUS parameter in CLOSE statement");
- if (ioparm.library_return != LIBRARY_OK)
+ if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
library_end ();
return;
}
- u = find_unit (ioparm.unit);
+ u = find_unit (clp->common.unit);
if (u != NULL)
{
if (u->flags.status == STATUS_SCRATCH)
{
if (status == CLOSE_KEEP)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&clp->common, ERROR_BAD_OPTION,
"Can't KEEP a scratch file on CLOSE");
#if !HAVE_UNLINK_OPEN_FILE
path = (char *) gfc_alloca (u->file_len + 1);
ENDFILE, and REWIND as well as the FLUSH statement. */
-/* formatted_backspace(void)-- Move the file back one line. The
+/* formatted_backspace(fpp, u)-- Move the file back one line. The
current position is after the newline that terminates the previous
record, and we have to sift backwards to find the newline before
that or the start of the file, whichever comes first. */
#define READ_CHUNK 4096
static void
-formatted_backspace (void)
+formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
gfc_offset base;
char *p;
int n;
- base = file_position (current_unit->s) - 1;
+ base = file_position (u->s) - 1;
do
{
n = (base < READ_CHUNK) ? base : READ_CHUNK;
base -= n;
- p = salloc_r_at (current_unit->s, &n, base);
+ p = salloc_r_at (u->s, &n, base);
if (p == NULL)
goto io_error;
/* base is the new pointer. Seek to it exactly. */
done:
- if (sseek (current_unit->s, base) == FAILURE)
+ if (sseek (u->s, base) == FAILURE)
goto io_error;
- current_unit->last_record--;
- current_unit->endfile = NO_ENDFILE;
+ u->last_record--;
+ u->endfile = NO_ENDFILE;
return;
io_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&fpp->common, ERROR_OS, NULL);
}
-/* unformatted_backspace() -- Move the file backwards for an unformatted
+/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
sequential file. We are guaranteed to be between records on entry and
we have to shift to the previous record. */
static void
-unformatted_backspace (void)
+unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
gfc_offset m, new;
int length;
length = sizeof (gfc_offset);
- p = salloc_r_at (current_unit->s, &length,
- file_position (current_unit->s) - length);
+ p = salloc_r_at (u->s, &length,
+ file_position (u->s) - length);
if (p == NULL)
goto io_error;
memcpy (&m, p, sizeof (gfc_offset));
- new = file_position (current_unit->s) - m - 2*length;
- if (sseek (current_unit->s, new) == FAILURE)
+ new = file_position (u->s) - m - 2*length;
+ if (sseek (u->s, new) == FAILURE)
goto io_error;
- current_unit->last_record--;
+ u->last_record--;
return;
io_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&fpp->common, ERROR_OS, NULL);
}
-extern void st_backspace (void);
+extern void st_backspace (st_parameter_filepos *);
export_proto(st_backspace);
void
-st_backspace (void)
+st_backspace (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = find_unit (ioparm.unit);
+ u = find_unit (fpp->common.unit);
if (u == NULL)
{
- generate_error (ERROR_BAD_UNIT, NULL);
+ generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
goto done;
}
- current_unit = u;
-
/* Ignore direct access. Non-advancing I/O is only allowed for formatted
sequential I/O and the next direct access transfer repositions the file
anyway. */
}
if (u->flags.form == FORM_FORMATTED)
- formatted_backspace ();
+ formatted_backspace (fpp, u);
else
- unformatted_backspace ();
+ unformatted_backspace (fpp, u);
u->endfile = NO_ENDFILE;
u->current_record = 0;
}
done:
+ if (u != NULL)
+ unlock_unit (u);
+
library_end ();
}
-extern void st_endfile (void);
+extern void st_endfile (st_parameter_filepos *);
export_proto(st_endfile);
void
-st_endfile (void)
+st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = get_unit (0);
+ u = find_unit (fpp->common.unit);
if (u != NULL)
{
- current_unit = u; /* next_record() needs this set. */
if (u->current_record)
- next_record (1);
+ {
+ st_parameter_dt dtp;
+ dtp.common = fpp->common;
+ memset (&dtp.u.p, 0, sizeof (dtp.u.p));
+ dtp.u.p.current_unit = u;
+ next_record (&dtp, 1);
+ }
- flush(u->s);
+ flush (u->s);
struncate (u->s);
u->endfile = AFTER_ENDFILE;
+ unlock_unit (u);
}
library_end ();
}
-extern void st_rewind (void);
+extern void st_rewind (st_parameter_filepos *);
export_proto(st_rewind);
void
-st_rewind (void)
+st_rewind (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = find_unit (ioparm.unit);
+ u = find_unit (fpp->common.unit);
if (u != NULL)
{
if (u->flags.access != ACCESS_SEQUENTIAL)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&fpp->common, ERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access");
else
{
u->mode = READING;
u->last_record = 0;
if (sseek (u->s, 0) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ generate_error (&fpp->common, ERROR_OS, NULL);
u->endfile = NO_ENDFILE;
u->current_record = 0;
}
/* Update position for INQUIRE. */
u->flags.position = POSITION_REWIND;
+ unlock_unit (u);
}
library_end ();
}
-extern void st_flush (void);
+extern void st_flush (st_parameter_filepos *);
export_proto(st_flush);
void
-st_flush (void)
+st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
- library_start ();
+ library_start (&fpp->common);
- u = get_unit (0);
+ u = find_unit (fpp->common.unit);
if (u != NULL)
{
- current_unit = u; /* Just to be sure. */
- flush(u->s);
+ flush (u->s);
+ unlock_unit (u);
}
library_end ();
#include "libgfortran.h"
#include "io.h"
+#define FARRAY_SIZE 64
+typedef struct fnode_array
+{
+ struct fnode_array *next;
+ fnode array[FARRAY_SIZE];
+}
+fnode_array;
-/* Number of format nodes that we can store statically before we have
- * to resort to dynamic allocation. The root node is array[0]. */
-
-#define FARRAY_SIZE 200
-
-static fnode *avail, array[FARRAY_SIZE];
-
-/* Local variables for checking format strings. The saved_token is
- * used to back up by a single format token during the parsing process. */
-
-static char *format_string, *string;
-static const char *error;
-static format_token saved_token;
-static int value, format_string_len, reversion_ok;
+typedef struct format_data
+{
+ char *format_string, *string;
+ const char *error;
+ format_token saved_token;
+ int value, format_string_len, reversion_ok;
+ fnode *avail;
+ const fnode *saved_format;
+ fnode_array *last;
+ fnode_array array;
+}
+format_data;
-static fnode *saved_format;
-static fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
- NULL };
+static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
+ NULL };
/* Error messages */
* spaces are significant, otherwise they are not. */
static int
-next_char (int literal)
+next_char (format_data *fmt, int literal)
{
int c;
do
{
- if (format_string_len == 0)
+ if (fmt->format_string_len == 0)
return -1;
- format_string_len--;
- c = toupper (*format_string++);
+ fmt->format_string_len--;
+ c = toupper (*fmt->format_string++);
}
while (c == ' ' && !literal);
/* unget_char()-- Back up one character position. */
-#define unget_char() { format_string--; format_string_len++; }
+#define unget_char(fmt) \
+ { fmt->format_string--; fmt->format_string_len++; }
/* get_fnode()-- Allocate a new format node, inserting it into the
* static buffer. */
static fnode *
-get_fnode (fnode ** head, fnode ** tail, format_token t)
+get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
{
fnode *f;
- if (avail - array >= FARRAY_SIZE)
- f = get_mem (sizeof (fnode));
- else
+ if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
{
- f = avail++;
- memset (f, '\0', sizeof (fnode));
+ fmt->last->next = get_mem (sizeof (fnode_array));
+ fmt->last = fmt->last->next;
+ fmt->last->next = NULL;
+ fmt->avail = &fmt->last->array[0];
}
+ f = fmt->avail++;
+ memset (f, '\0', sizeof (fnode));
if (*head == NULL)
*head = *tail = f;
f->format = t;
f->repeat = -1;
- f->source = format_string;
+ f->source = fmt->format_string;
return f;
}
-/* free_fnode()-- Recursive function to free the given fnode and
- * everything it points to. We only have to actually free something
- * if it is outside of the static array. */
+/* free_format_data()-- Free all allocated format data. */
-static void
-free_fnode (fnode * f)
+void
+free_format_data (st_parameter_dt *dtp)
{
- fnode *next;
+ fnode_array *fa, *fa_next;
+ format_data *fmt = dtp->u.p.fmt;
- for (; f; f = next)
- {
- next = f->next;
+ if (fmt == NULL)
+ return;
- if (f->format == FMT_LPAREN)
- free_fnode (f->u.child);
- if (f < array || f >= array + FARRAY_SIZE)
- free_mem (f);
+ for (fa = fmt->array.next; fa; fa = fa_next)
+ {
+ fa_next = fa->next;
+ free_mem (fa);
}
-}
-
-/* free_fnodes()-- Free the current tree of fnodes. We only have to
- * traverse the tree if some nodes were allocated dynamically. */
-
-void
-free_fnodes (void)
-{
- if (avail - array >= FARRAY_SIZE)
- free_fnode (&array[0]);
-
- avail = array;
- memset(array, 0, sizeof(avail[0]) * FARRAY_SIZE);
+ free_mem (fmt);
+ dtp->u.p.fmt = NULL;
}
/* format_lex()-- Simple lexical analyzer for getting the next token
* in a FORMAT string. We support a one-level token pushback in the
- * saved_token variable. */
+ * fmt->saved_token variable. */
static format_token
-format_lex (void)
+format_lex (format_data *fmt)
{
format_token token;
int negative_flag;
int c;
char delim;
- if (saved_token != FMT_NONE)
+ if (fmt->saved_token != FMT_NONE)
{
- token = saved_token;
- saved_token = FMT_NONE;
+ token = fmt->saved_token;
+ fmt->saved_token = FMT_NONE;
return token;
}
negative_flag = 0;
- c = next_char (0);
+ c = next_char (fmt, 0);
switch (c)
{
/* Fall Through */
case '+':
- c = next_char (0);
+ c = next_char (fmt, 0);
if (!isdigit (c))
{
token = FMT_UNKNOWN;
break;
}
- value = c - '0';
+ fmt->value = c - '0';
for (;;)
{
- c = next_char (0);
+ c = next_char (fmt, 0);
if (!isdigit (c))
break;
- value = 10 * value + c - '0';
+ fmt->value = 10 * fmt->value + c - '0';
}
- unget_char ();
+ unget_char (fmt);
if (negative_flag)
- value = -value;
+ fmt->value = -fmt->value;
token = FMT_SIGNED_INT;
break;
case '7':
case '8':
case '9':
- value = c - '0';
+ fmt->value = c - '0';
for (;;)
{
- c = next_char (0);
+ c = next_char (fmt, 0);
if (!isdigit (c))
break;
- value = 10 * value + c - '0';
+ fmt->value = 10 * fmt->value + c - '0';
}
- unget_char ();
- token = (value == 0) ? FMT_ZERO : FMT_POSINT;
+ unget_char (fmt);
+ token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT;
break;
case '.':
break;
case 'T':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'L':
token = FMT_TL;
break;
default:
token = FMT_T;
- unget_char ();
+ unget_char (fmt);
break;
}
break;
case 'S':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'S':
token = FMT_SS;
break;
default:
token = FMT_S;
- unget_char ();
+ unget_char (fmt);
break;
}
break;
case 'B':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'N':
token = FMT_BN;
break;
default:
token = FMT_B;
- unget_char ();
+ unget_char (fmt);
break;
}
case '"':
delim = c;
- string = format_string;
- value = 0; /* This is the length of the string */
+ fmt->string = fmt->format_string;
+ fmt->value = 0; /* This is the length of the string */
for (;;)
{
- c = next_char (1);
+ c = next_char (fmt, 1);
if (c == -1)
{
token = FMT_BADSTRING;
- error = bad_string;
+ fmt->error = bad_string;
break;
}
if (c == delim)
{
- c = next_char (1);
+ c = next_char (fmt, 1);
if (c == -1)
{
token = FMT_BADSTRING;
- error = bad_string;
+ fmt->error = bad_string;
break;
}
if (c != delim)
{
- unget_char ();
+ unget_char (fmt);
token = FMT_STRING;
break;
}
}
- value++;
+ fmt->value++;
}
break;
break;
case 'E':
- switch (next_char (0))
+ switch (next_char (fmt, 0))
{
case 'N':
token = FMT_EN;
break;
default:
token = FMT_E;
- unget_char ();
+ unget_char (fmt);
break;
}
* parenthesis node which contains the rest of the list. */
static fnode *
-parse_format_list (void)
+parse_format_list (st_parameter_dt *dtp)
{
fnode *head, *tail;
format_token t, u, t2;
int repeat;
+ format_data *fmt = dtp->u.p.fmt;
head = tail = NULL;
/* Get the next format item */
format_item:
- t = format_lex ();
+ t = format_lex (fmt);
format_item_1:
switch (t)
{
case FMT_POSINT:
- repeat = value;
+ repeat = fmt->value;
- t = format_lex ();
+ t = format_lex (fmt);
switch (t)
{
case FMT_LPAREN:
- get_fnode (&head, &tail, FMT_LPAREN);
+ get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = repeat;
- tail->u.child = parse_format_list ();
- if (error != NULL)
+ tail->u.child = parse_format_list (dtp);
+ if (fmt->error != NULL)
goto finished;
goto between_desc;
case FMT_SLASH:
- get_fnode (&head, &tail, FMT_SLASH);
+ get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = repeat;
goto optional_comma;
case FMT_X:
- get_fnode (&head, &tail, FMT_X);
+ get_fnode (fmt, &head, &tail, FMT_X);
tail->repeat = 1;
- tail->u.k = value;
+ tail->u.k = fmt->value;
goto between_desc;
case FMT_P:
}
case FMT_LPAREN:
- get_fnode (&head, &tail, FMT_LPAREN);
+ get_fnode (fmt, &head, &tail, FMT_LPAREN);
tail->repeat = 1;
- tail->u.child = parse_format_list ();
- if (error != NULL)
+ tail->u.child = parse_format_list (dtp);
+ if (fmt->error != NULL)
goto finished;
goto between_desc;
case FMT_SIGNED_INT: /* Signed integer can only precede a P format. */
case FMT_ZERO: /* Same for zero. */
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_P)
{
- error = "Expected P edit descriptor in format";
+ fmt->error = "Expected P edit descriptor in format";
goto finished;
}
p_descriptor:
- get_fnode (&head, &tail, FMT_P);
- tail->u.k = value;
+ get_fnode (fmt, &head, &tail, FMT_P);
+ tail->u.k = fmt->value;
tail->repeat = 1;
- t = format_lex ();
+ t = format_lex (fmt);
if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
|| t == FMT_G || t == FMT_E)
{
goto data_desc;
}
- saved_token = t;
+ fmt->saved_token = t;
goto optional_comma;
case FMT_P: /* P and X require a prior number */
- error = "P descriptor requires leading scale factor";
+ fmt->error = "P descriptor requires leading scale factor";
goto finished;
case FMT_X:
If we would be pedantic in the library, we would have to reject
an X descriptor without an integer prefix:
- error = "X descriptor requires leading space count";
+ fmt->error = "X descriptor requires leading space count";
goto finished;
However, this is an extension supported by many Fortran compilers,
runtime library, and make the front end reject it if the compiler
is in pedantic mode. The interpretation of 'X' is '1X'.
*/
- get_fnode (&head, &tail, FMT_X);
+ get_fnode (fmt, &head, &tail, FMT_X);
tail->repeat = 1;
tail->u.k = 1;
goto between_desc;
case FMT_STRING:
- get_fnode (&head, &tail, FMT_STRING);
+ get_fnode (fmt, &head, &tail, FMT_STRING);
- tail->u.string.p = string;
- tail->u.string.length = value;
+ tail->u.string.p = fmt->string;
+ tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
case FMT_SP:
case FMT_BN:
case FMT_BZ:
- get_fnode (&head, &tail, t);
+ get_fnode (fmt, &head, &tail, t);
tail->repeat = 1;
goto between_desc;
case FMT_COLON:
- get_fnode (&head, &tail, FMT_COLON);
+ get_fnode (fmt, &head, &tail, FMT_COLON);
tail->repeat = 1;
goto optional_comma;
case FMT_SLASH:
- get_fnode (&head, &tail, FMT_SLASH);
+ get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = 1;
tail->u.r = 1;
goto optional_comma;
case FMT_DOLLAR:
- get_fnode (&head, &tail, FMT_DOLLAR);
+ get_fnode (fmt, &head, &tail, FMT_DOLLAR);
tail->repeat = 1;
notify_std (GFC_STD_GNU, "Extension: $ descriptor");
goto between_desc;
case FMT_T:
case FMT_TL:
case FMT_TR:
- t2 = format_lex ();
+ t2 = format_lex (fmt);
if (t2 != FMT_POSINT)
{
- error = posint_required;
+ fmt->error = posint_required;
goto finished;
}
- get_fnode (&head, &tail, t);
- tail->u.n = value;
+ get_fnode (fmt, &head, &tail, t);
+ tail->u.n = fmt->value;
tail->repeat = 1;
goto between_desc;
goto data_desc;
case FMT_H:
- get_fnode (&head, &tail, FMT_STRING);
+ get_fnode (fmt, &head, &tail, FMT_STRING);
- if (format_string_len < 1)
+ if (fmt->format_string_len < 1)
{
- error = bad_hollerith;
+ fmt->error = bad_hollerith;
goto finished;
}
- tail->u.string.p = format_string;
+ tail->u.string.p = fmt->format_string;
tail->u.string.length = 1;
tail->repeat = 1;
- format_string++;
- format_string_len--;
+ fmt->format_string++;
+ fmt->format_string_len--;
goto between_desc;
case FMT_END:
- error = unexpected_end;
+ fmt->error = unexpected_end;
goto finished;
case FMT_BADSTRING:
goto finished;
default:
- error = unexpected_element;
+ fmt->error = unexpected_element;
goto finished;
}
switch (t)
{
case FMT_P:
- t = format_lex ();
+ t = format_lex (fmt);
if (t == FMT_POSINT)
{
- error = "Repeat count cannot follow P descriptor";
+ fmt->error = "Repeat count cannot follow P descriptor";
goto finished;
}
- saved_token = t;
- get_fnode (&head, &tail, FMT_P);
+ fmt->saved_token = t;
+ get_fnode (fmt, &head, &tail, FMT_P);
goto optional_comma;
case FMT_L:
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_POSINT)
{
- error = posint_required;
+ fmt->error = posint_required;
goto finished;
}
- get_fnode (&head, &tail, FMT_L);
- tail->u.n = value;
+ get_fnode (fmt, &head, &tail, FMT_L);
+ tail->u.n = fmt->value;
tail->repeat = repeat;
break;
case FMT_A:
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_POSINT)
{
- saved_token = t;
- value = -1; /* Width not present */
+ fmt->saved_token = t;
+ fmt->value = -1; /* Width not present */
}
- get_fnode (&head, &tail, FMT_A);
+ get_fnode (fmt, &head, &tail, FMT_A);
tail->repeat = repeat;
- tail->u.n = value;
+ tail->u.n = fmt->value;
break;
case FMT_D:
case FMT_G:
case FMT_EN:
case FMT_ES:
- get_fnode (&head, &tail, t);
+ get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
- u = format_lex ();
- if (t == FMT_F || g.mode == WRITING)
+ u = format_lex (fmt);
+ if (t == FMT_F || dtp->u.p.mode == WRITING)
{
if (u != FMT_POSINT && u != FMT_ZERO)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
}
{
if (u != FMT_POSINT)
{
- error = posint_required;
+ fmt->error = posint_required;
goto finished;
}
}
- tail->u.real.w = value;
+ tail->u.real.w = fmt->value;
t2 = t;
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_PERIOD)
{
- error = period_required;
+ fmt->error = period_required;
goto finished;
}
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_ZERO && t != FMT_POSINT)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
- tail->u.real.d = value;
+ tail->u.real.d = fmt->value;
if (t == FMT_D || t == FMT_F)
break;
tail->u.real.e = -1;
/* Look for optional exponent */
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_E)
- saved_token = t;
+ fmt->saved_token = t;
else
{
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_POSINT)
{
- error = "Positive exponent width required in format";
+ fmt->error = "Positive exponent width required in format";
goto finished;
}
- tail->u.real.e = value;
+ tail->u.real.e = fmt->value;
}
break;
case FMT_H:
- if (repeat > format_string_len)
+ if (repeat > fmt->format_string_len)
{
- error = bad_hollerith;
+ fmt->error = bad_hollerith;
goto finished;
}
- get_fnode (&head, &tail, FMT_STRING);
+ get_fnode (fmt, &head, &tail, FMT_STRING);
- tail->u.string.p = format_string;
+ tail->u.string.p = fmt->format_string;
tail->u.string.length = repeat;
tail->repeat = 1;
- format_string += value;
- format_string_len -= repeat;
+ fmt->format_string += fmt->value;
+ fmt->format_string_len -= repeat;
break;
case FMT_B:
case FMT_O:
case FMT_Z:
- get_fnode (&head, &tail, t);
+ get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
- t = format_lex ();
+ t = format_lex (fmt);
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
{
if (t != FMT_POSINT)
{
- error = posint_required;
+ fmt->error = posint_required;
goto finished;
}
}
{
if (t != FMT_ZERO && t != FMT_POSINT)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
}
- tail->u.integer.w = value;
+ tail->u.integer.w = fmt->value;
tail->u.integer.m = -1;
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_PERIOD)
{
- saved_token = t;
+ fmt->saved_token = t;
}
else
{
- t = format_lex ();
+ t = format_lex (fmt);
if (t != FMT_ZERO && t != FMT_POSINT)
{
- error = nonneg_required;
+ fmt->error = nonneg_required;
goto finished;
}
- tail->u.integer.m = value;
+ tail->u.integer.m = fmt->value;
}
if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
{
- error = "Minimum digits exceeds field width";
+ fmt->error = "Minimum digits exceeds field width";
goto finished;
}
break;
default:
- error = unexpected_element;
+ fmt->error = unexpected_element;
goto finished;
}
/* Between a descriptor and what comes next */
between_desc:
- t = format_lex ();
+ t = format_lex (fmt);
switch (t)
{
case FMT_COMMA:
goto finished;
case FMT_SLASH:
- get_fnode (&head, &tail, FMT_SLASH);
+ get_fnode (fmt, &head, &tail, FMT_SLASH);
tail->repeat = 1;
/* Fall Through */
goto optional_comma;
case FMT_END:
- error = unexpected_end;
+ fmt->error = unexpected_end;
goto finished;
default:
/* Optional comma is a weird between state where we've just finished
reading a colon, slash or P descriptor. */
optional_comma:
- t = format_lex ();
+ t = format_lex (fmt);
switch (t)
{
case FMT_COMMA:
goto finished;
default: /* Assume that we have another format item */
- saved_token = t;
+ fmt->saved_token = t;
break;
}
* is assumed to happen at parse time, and the current location of the
* parser is shown.
*
- * After freeing any dynamically allocated fnodes, generate a message
- * showing where the problem is. We take extra care to print only the
- * relevant part of the format if it is longer than a standard 80
- * column display. */
+ * We generate a message showing where the problem is. We take extra
+ * care to print only the relevant part of the format if it is longer
+ * than a standard 80 column display. */
void
-format_error (fnode * f, const char *message)
+format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
{
int width, i, j, offset;
char *p, buffer[300];
+ format_data *fmt = dtp->u.p.fmt;
if (f != NULL)
- format_string = f->source;
-
- free_fnodes ();
+ fmt->format_string = f->source;
st_sprintf (buffer, "%s\n", message);
- j = format_string - ioparm.format;
+ j = fmt->format_string - dtp->format;
offset = (j > 60) ? j - 40 : 0;
j -= offset;
- width = ioparm.format_len - offset;
+ width = dtp->format_len - offset;
if (width > 80)
width = 80;
p = strchr (buffer, '\0');
- memcpy (p, ioparm.format + offset, width);
+ memcpy (p, dtp->format + offset, width);
p += width;
*p++ = '\n';
*p++ = '^';
*p = '\0';
- generate_error (ERROR_FORMAT, buffer);
+ generate_error (&dtp->common, ERROR_FORMAT, buffer);
}
/* parse_format()-- Parse a format string. */
void
-parse_format (void)
+parse_format (st_parameter_dt *dtp)
{
- format_string = ioparm.format;
- format_string_len = ioparm.format_len;
+ format_data *fmt;
- saved_token = FMT_NONE;
- error = NULL;
+ dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
+ fmt->format_string = dtp->format;
+ fmt->format_string_len = dtp->format_len;
+
+ fmt->string = NULL;
+ fmt->saved_token = FMT_NONE;
+ fmt->error = NULL;
+ fmt->value = 0;
/* Initialize variables used during traversal of the tree */
- reversion_ok = 0;
- g.reversion_flag = 0;
- saved_format = NULL;
+ fmt->reversion_ok = 0;
+ fmt->saved_format = NULL;
/* Allocate the first format node as the root of the tree */
- avail = array;
+ fmt->last = &fmt->array;
+ fmt->last->next = NULL;
+ fmt->avail = &fmt->array.array[0];
- avail->format = FMT_LPAREN;
- avail->repeat = 1;
- avail++;
+ memset (fmt->avail, 0, sizeof (*fmt->avail));
+ fmt->avail->format = FMT_LPAREN;
+ fmt->avail->repeat = 1;
+ fmt->avail++;
- if (format_lex () == FMT_LPAREN)
- array[0].u.child = parse_format_list ();
+ if (format_lex (fmt) == FMT_LPAREN)
+ fmt->array.array[0].u.child = parse_format_list (dtp);
else
- error = "Missing initial left parenthesis in format";
+ fmt->error = "Missing initial left parenthesis in format";
- if (error)
- format_error (NULL, error);
+ if (fmt->error)
+ format_error (dtp, NULL, fmt->error);
}
* level. */
static void
-revert (void)
+revert (st_parameter_dt *dtp)
{
fnode *f, *r;
+ format_data *fmt = dtp->u.p.fmt;
- g.reversion_flag = 1;
+ dtp->u.p.reversion_flag = 1;
r = NULL;
- for (f = array[0].u.child; f; f = f->next)
+ for (f = fmt->array.array[0].u.child; f; f = f->next)
if (f->format == FMT_LPAREN)
r = f;
/* If r is NULL because no node was found, the whole tree will be used */
- array[0].current = r;
- array[0].count = 0;
+ fmt->array.array[0].current = r;
+ fmt->array.array[0].count = 0;
}
* Parenthesis nodes are incremented after the list has been
* exhausted, other nodes are incremented before they are returned. */
-static fnode *
+static const fnode *
next_format0 (fnode * f)
{
- fnode *r;
+ const fnode *r;
if (f == NULL)
return NULL;
* are no more data descriptors to return (which is an error
* condition). */
-fnode *
-next_format (void)
+const fnode *
+next_format (st_parameter_dt *dtp)
{
format_token t;
- fnode *f;
+ const fnode *f;
+ format_data *fmt = dtp->u.p.fmt;
- if (saved_format != NULL)
+ if (fmt->saved_format != NULL)
{ /* Deal with a pushed-back format node */
- f = saved_format;
- saved_format = NULL;
+ f = fmt->saved_format;
+ fmt->saved_format = NULL;
goto done;
}
- f = next_format0 (&array[0]);
+ f = next_format0 (&fmt->array.array[0]);
if (f == NULL)
{
- if (!reversion_ok)
- {
- return NULL;
- }
+ if (!fmt->reversion_ok)
+ return NULL;
- reversion_ok = 0;
- revert ();
+ fmt->reversion_ok = 0;
+ revert (dtp);
- f = next_format0 (&array[0]);
+ f = next_format0 (&fmt->array.array[0]);
if (f == NULL)
{
- format_error (NULL, reversion_error);
+ format_error (dtp, NULL, reversion_error);
return NULL;
}
/* Push the first reverted token and return a colon node in case
* there are no more data items. */
- saved_format = f;
+ fmt->saved_format = f;
return &colon_node;
}
done:
t = f->format;
- if (!reversion_ok &&
+ if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
t == FMT_A || t == FMT_D))
- reversion_ok = 1;
+ fmt->reversion_ok = 1;
return f;
}
* which calls the library back with the data item (or not). */
void
-unget_format (fnode * f)
+unget_format (st_parameter_dt *dtp, const fnode *f)
{
- saved_format = f;
+ dtp->u.p.fmt->saved_format = f;
}
void
-next_test (void)
+next_test (st_parameter_dt *dtp)
{
fnode *f;
int i;
for (i = 0; i < 20; i++)
{
- f = next_format ();
+ f = next_format (dtp);
if (f == NULL)
{
st_printf ("No format!\n");
-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
/* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
static void
-inquire_via_unit (gfc_unit * u)
+inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
{
const char *p;
+ GFC_INTEGER_4 cf = iqp->common.flags;
- if (ioparm.exist != NULL)
- {
- if (ioparm.unit >= 0)
- *ioparm.exist = 1;
- else
- *ioparm.exist = 0;
- }
+ if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
+ *iqp->exist = iqp->common.unit >= 0;
- if (ioparm.opened != NULL)
- *ioparm.opened = (u != NULL);
+ if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+ *iqp->opened = (u != NULL);
- if (ioparm.number != NULL)
- *ioparm.number = (u != NULL) ? u->unit_number : -1;
+ if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+ *iqp->number = (u != NULL) ? u->unit_number : -1;
- if (ioparm.named != NULL)
- *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
+ if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+ *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
- if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
- fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
+ if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
+ && u != NULL && u->flags.status != STATUS_SCRATCH)
+ fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
- if (ioparm.access != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
{
if (u == NULL)
p = undefined;
p = "DIRECT";
break;
default:
- internal_error ("inquire_via_unit(): Bad access");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad access");
}
- cf_strcpy (ioparm.access, ioparm.access_len, p);
+ cf_strcpy (iqp->access, iqp->access_len, p);
}
- if (ioparm.sequential != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
{
if (u == NULL)
p = inquire_sequential (NULL, 0);
p = inquire_sequential (u->file, u->file_len);
}
- cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+ cf_strcpy (iqp->sequential, iqp->sequential_len, p);
}
- if (ioparm.direct != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
{
p = (u == NULL) ? inquire_direct (NULL, 0) :
inquire_direct (u->file, u->file_len);
- cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+ cf_strcpy (iqp->direct, iqp->direct_len, p);
}
- if (ioparm.form != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
{
if (u == NULL)
p = undefined;
p = "UNFORMATTED";
break;
default:
- internal_error ("inquire_via_unit(): Bad form");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad form");
}
- cf_strcpy (ioparm.form, ioparm.form_len, p);
+ cf_strcpy (iqp->form, iqp->form_len, p);
}
- if (ioparm.formatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
{
p = (u == NULL) ? inquire_formatted (NULL, 0) :
inquire_formatted (u->file, u->file_len);
- cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+ cf_strcpy (iqp->formatted, iqp->formatted_len, p);
}
- if (ioparm.unformatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
{
p = (u == NULL) ? inquire_unformatted (NULL, 0) :
inquire_unformatted (u->file, u->file_len);
- cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+ cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
}
- if (ioparm.recl_out != NULL)
- *ioparm.recl_out = (u != NULL) ? u->recl : 0;
+ if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+ *iqp->recl_out = (u != NULL) ? u->recl : 0;
- if (ioparm.nextrec != NULL)
- *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
+ if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+ *iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0;
- if (ioparm.blank != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
{
if (u == NULL)
p = undefined;
switch (u->flags.blank)
{
case BLANK_NULL:
- p = "NULL";
+ p = "NULL";
break;
case BLANK_ZERO:
p = "ZERO";
break;
default:
- internal_error ("inquire_via_unit(): Bad blank");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
}
- cf_strcpy (ioparm.blank, ioparm.blank_len, p);
+ cf_strcpy (iqp->blank, iqp->blank_len, p);
}
- if (ioparm.position != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
{
if (u == NULL || u->flags.access == ACCESS_DIRECT)
p = undefined;
p = "ASIS";
break;
}
- cf_strcpy (ioparm.position, ioparm.position_len, p);
+ cf_strcpy (iqp->position, iqp->position_len, p);
}
- if (ioparm.action != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
{
if (u == NULL)
p = undefined;
p = "READWRITE";
break;
default:
- internal_error ("inquire_via_unit(): Bad action");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad action");
}
- cf_strcpy (ioparm.action, ioparm.action_len, p);
+ cf_strcpy (iqp->action, iqp->action_len, p);
}
- if (ioparm.read != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
{
p = (u == NULL) ? inquire_read (NULL, 0) :
inquire_read (u->file, u->file_len);
- cf_strcpy (ioparm.read, ioparm.read_len, p);
+ cf_strcpy (iqp->read, iqp->read_len, p);
}
- if (ioparm.write != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
{
p = (u == NULL) ? inquire_write (NULL, 0) :
inquire_write (u->file, u->file_len);
- cf_strcpy (ioparm.write, ioparm.write_len, p);
+ cf_strcpy (iqp->write, iqp->write_len, p);
}
- if (ioparm.readwrite != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
{
p = (u == NULL) ? inquire_readwrite (NULL, 0) :
inquire_readwrite (u->file, u->file_len);
- cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+ cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
}
- if (ioparm.delim != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined;
p = "APOSTROPHE";
break;
default:
- internal_error ("inquire_via_unit(): Bad delim");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
}
- cf_strcpy (ioparm.delim, ioparm.delim_len, p);
+ cf_strcpy (iqp->delim, iqp->delim_len, p);
}
- if (ioparm.pad != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
p = undefined;
p = "YES";
break;
default:
- internal_error ("inquire_via_unit(): Bad pad");
+ internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
}
- cf_strcpy (ioparm.pad, ioparm.pad_len, p);
+ cf_strcpy (iqp->pad, iqp->pad_len, p);
}
}
* only used if the filename is *not* connected to a unit number. */
static void
-inquire_via_filename (void)
+inquire_via_filename (st_parameter_inquire *iqp)
{
const char *p;
+ GFC_INTEGER_4 cf = iqp->common.flags;
- if (ioparm.exist != NULL)
- *ioparm.exist = file_exists ();
+ if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
+ *iqp->exist = file_exists (iqp->file, iqp->file_len);
- if (ioparm.opened != NULL)
- *ioparm.opened = 0;
+ if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+ *iqp->opened = 0;
- if (ioparm.number != NULL)
- *ioparm.number = -1;
+ if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+ *iqp->number = -1;
- if (ioparm.named != NULL)
- *ioparm.named = 1;
+ if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+ *iqp->named = 1;
- if (ioparm.name != NULL)
- fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
+ if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
+ fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
- if (ioparm.access != NULL)
- cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+ cf_strcpy (iqp->access, iqp->access_len, undefined);
- if (ioparm.sequential != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
{
- p = inquire_sequential (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+ p = inquire_sequential (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->sequential, iqp->sequential_len, p);
}
- if (ioparm.direct != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
{
- p = inquire_direct (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+ p = inquire_direct (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->direct, iqp->direct_len, p);
}
- if (ioparm.form != NULL)
- cf_strcpy (ioparm.form, ioparm.form_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
+ cf_strcpy (iqp->form, iqp->form_len, undefined);
- if (ioparm.formatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
{
- p = inquire_formatted (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+ p = inquire_formatted (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->formatted, iqp->formatted_len, p);
}
- if (ioparm.unformatted != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
{
- p = inquire_unformatted (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+ p = inquire_unformatted (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
}
- if (ioparm.recl_out != NULL)
- *ioparm.recl_out = 0;
+ if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+ *iqp->recl_out = 0;
- if (ioparm.nextrec != NULL)
- *ioparm.nextrec = 0;
+ if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+ *iqp->nextrec = 0;
- if (ioparm.blank != NULL)
- cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
+ cf_strcpy (iqp->blank, iqp->blank_len, undefined);
- if (ioparm.position != NULL)
- cf_strcpy (ioparm.position, ioparm.position_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
+ cf_strcpy (iqp->position, iqp->position_len, undefined);
- if (ioparm.access != NULL)
- cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+ cf_strcpy (iqp->access, iqp->access_len, undefined);
- if (ioparm.read != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
{
- p = inquire_read (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.read, ioparm.read_len, p);
+ p = inquire_read (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->read, iqp->read_len, p);
}
- if (ioparm.write != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
{
- p = inquire_write (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.write, ioparm.write_len, p);
+ p = inquire_write (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->write, iqp->write_len, p);
}
- if (ioparm.readwrite != NULL)
+ if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
{
- p = inquire_read (ioparm.file, ioparm.file_len);
- cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+ p = inquire_read (iqp->file, iqp->file_len);
+ cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
}
- if (ioparm.delim != NULL)
- cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
-
- if (ioparm.pad != NULL)
- cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
+ cf_strcpy (iqp->delim, iqp->delim_len, undefined);
+ if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+ cf_strcpy (iqp->pad, iqp->pad_len, undefined);
}
/* Library entry point for the INQUIRE statement (non-IOLENGTH
form). */
-extern void st_inquire (void);
+extern void st_inquire (st_parameter_inquire *);
export_proto(st_inquire);
void
-st_inquire (void)
+st_inquire (st_parameter_inquire *iqp)
{
gfc_unit *u;
- library_start ();
+ library_start (&iqp->common);
- if (ioparm.file == NULL)
- inquire_via_unit (find_unit (ioparm.unit));
+ if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
+ {
+ u = find_unit (iqp->common.unit);
+ inquire_via_unit (iqp, u);
+ }
else
{
- u = find_file ();
+ u = find_file (iqp->file, iqp->file_len);
if (u == NULL)
- inquire_via_filename ();
+ inquire_via_filename (iqp);
else
- inquire_via_unit (u);
+ inquire_via_unit (iqp, u);
}
+ if (u != NULL)
+ unlock_unit (u);
library_end ();
}
#include <setjmp.h>
#include "libgfortran.h"
+#ifdef HAVE_PRAGMA_WEAK
+/* Used by gthr.h. */
+#define SUPPORTS_WEAK 1
+#endif
+#include <gthr.h>
#define DEFAULT_TEMPDIR "/tmp"
{ SUCCESS = 1, FAILURE }
try;
+struct st_parameter_dt;
+
typedef struct stream
{
char *(*alloc_w_at) (struct stream *, int *, gfc_offset);
{READING, WRITING}
unit_mode;
-/* Statement parameters. These are all the things that can appear in
- an I/O statement. Some are inputs and some are outputs, but none
- are both. All of these values are initially zeroed and are zeroed
- at the end of a library statement. The relevant values need to be
- set before entry to an I/O statement. This structure needs to be
- duplicated by the back end. */
+#define CHARACTER1(name) \
+ char * name; \
+ gfc_charlen_type name ## _len
+#define CHARACTER2(name) \
+ gfc_charlen_type name ## _len; \
+ char * name
+
+#define IOPARM_LIBRETURN_MASK (3 << 0)
+#define IOPARM_LIBRETURN_OK (0 << 0)
+#define IOPARM_LIBRETURN_ERROR (1 << 0)
+#define IOPARM_LIBRETURN_END (2 << 0)
+#define IOPARM_LIBRETURN_EOR (3 << 0)
+#define IOPARM_ERR (1 << 2)
+#define IOPARM_END (1 << 3)
+#define IOPARM_EOR (1 << 4)
+#define IOPARM_HAS_IOSTAT (1 << 5)
+#define IOPARM_HAS_IOMSG (1 << 6)
+
+#define IOPARM_COMMON_MASK ((1 << 7) - 1)
+
+typedef struct st_parameter_common
+{
+ GFC_INTEGER_4 flags;
+ GFC_INTEGER_4 unit;
+ const char *filename;
+ GFC_INTEGER_4 line;
+ CHARACTER2 (iomsg);
+ GFC_INTEGER_4 *iostat;
+}
+st_parameter_common;
+
+#define IOPARM_OPEN_HAS_RECL_IN (1 << 7)
+#define IOPARM_OPEN_HAS_FILE (1 << 8)
+#define IOPARM_OPEN_HAS_STATUS (1 << 9)
+#define IOPARM_OPEN_HAS_ACCESS (1 << 10)
+#define IOPARM_OPEN_HAS_FORM (1 << 11)
+#define IOPARM_OPEN_HAS_BLANK (1 << 12)
+#define IOPARM_OPEN_HAS_POSITION (1 << 13)
+#define IOPARM_OPEN_HAS_ACTION (1 << 14)
+#define IOPARM_OPEN_HAS_DELIM (1 << 15)
+#define IOPARM_OPEN_HAS_PAD (1 << 16)
typedef struct
{
- GFC_INTEGER_4 unit;
- GFC_INTEGER_4 err, end, eor, list_format; /* These are flags, not values. */
+ st_parameter_common common;
+ GFC_INTEGER_4 recl_in;
+ CHARACTER2 (file);
+ CHARACTER1 (status);
+ CHARACTER2 (access);
+ CHARACTER1 (form);
+ CHARACTER2 (blank);
+ CHARACTER1 (position);
+ CHARACTER2 (action);
+ CHARACTER1 (delim);
+ CHARACTER2 (pad);
+}
+st_parameter_open;
-/* Return values from library statements. These are returned only if
- the labels are specified in the statement itself and the condition
- occurs. In most cases, none of the labels are specified and the
- return value does not have to be checked. Must be consistent with
- the front end. */
+#define IOPARM_CLOSE_HAS_STATUS (1 << 7)
- enum
- {
- LIBRARY_OK = 0,
- LIBRARY_ERROR,
- LIBRARY_END,
- LIBRARY_EOR
- }
- library_return;
+typedef struct
+{
+ st_parameter_common common;
+ CHARACTER1 (status);
+}
+st_parameter_close;
- GFC_INTEGER_4 *iostat, *exist, *opened, *number, *named;
- GFC_INTEGER_4 rec;
- GFC_INTEGER_4 *nextrec, *size;
+typedef struct
+{
+ st_parameter_common common;
+}
+st_parameter_filepos;
+
+#define IOPARM_INQUIRE_HAS_EXIST (1 << 7)
+#define IOPARM_INQUIRE_HAS_OPENED (1 << 8)
+#define IOPARM_INQUIRE_HAS_NUMBER (1 << 9)
+#define IOPARM_INQUIRE_HAS_NAMED (1 << 10)
+#define IOPARM_INQUIRE_HAS_NEXTREC (1 << 11)
+#define IOPARM_INQUIRE_HAS_RECL_OUT (1 << 12)
+#define IOPARM_INQUIRE_HAS_FILE (1 << 13)
+#define IOPARM_INQUIRE_HAS_ACCESS (1 << 14)
+#define IOPARM_INQUIRE_HAS_FORM (1 << 15)
+#define IOPARM_INQUIRE_HAS_BLANK (1 << 16)
+#define IOPARM_INQUIRE_HAS_POSITION (1 << 17)
+#define IOPARM_INQUIRE_HAS_ACTION (1 << 18)
+#define IOPARM_INQUIRE_HAS_DELIM (1 << 19)
+#define IOPARM_INQUIRE_HAS_PAD (1 << 20)
+#define IOPARM_INQUIRE_HAS_NAME (1 << 21)
+#define IOPARM_INQUIRE_HAS_SEQUENTIAL (1 << 22)
+#define IOPARM_INQUIRE_HAS_DIRECT (1 << 23)
+#define IOPARM_INQUIRE_HAS_FORMATTED (1 << 24)
+#define IOPARM_INQUIRE_HAS_UNFORMATTED (1 << 25)
+#define IOPARM_INQUIRE_HAS_READ (1 << 26)
+#define IOPARM_INQUIRE_HAS_WRITE (1 << 27)
+#define IOPARM_INQUIRE_HAS_READWRITE (1 << 28)
- GFC_INTEGER_4 recl_in;
- GFC_INTEGER_4 *recl_out;
-
- GFC_INTEGER_4 *iolength;
-
-#define CHARACTER(name) \
- char * name; \
- gfc_charlen_type name ## _len
- CHARACTER (file);
- CHARACTER (status);
- CHARACTER (access);
- CHARACTER (form);
- CHARACTER (blank);
- CHARACTER (position);
- CHARACTER (action);
- CHARACTER (delim);
- CHARACTER (pad);
- CHARACTER (format);
- CHARACTER (advance);
- CHARACTER (name);
- CHARACTER (internal_unit);
+typedef struct
+{
+ st_parameter_common common;
+ GFC_INTEGER_4 *exist, *opened, *number, *named;
+ GFC_INTEGER_4 *nextrec, *recl_out;
+ CHARACTER1 (file);
+ CHARACTER2 (access);
+ CHARACTER1 (form);
+ CHARACTER2 (blank);
+ CHARACTER1 (position);
+ CHARACTER2 (action);
+ CHARACTER1 (delim);
+ CHARACTER2 (pad);
+ CHARACTER1 (name);
+ CHARACTER2 (sequential);
+ CHARACTER1 (direct);
+ CHARACTER2 (formatted);
+ CHARACTER1 (unformatted);
+ CHARACTER2 (read);
+ CHARACTER1 (write);
+ CHARACTER2 (readwrite);
+}
+st_parameter_inquire;
+
+struct gfc_unit;
+struct format_data;
+
+#define IOPARM_DT_LIST_FORMAT (1 << 7)
+#define IOPARM_DT_NAMELIST_READ_MODE (1 << 8)
+#define IOPARM_DT_HAS_REC (1 << 9)
+#define IOPARM_DT_HAS_SIZE (1 << 10)
+#define IOPARM_DT_HAS_IOLENGTH (1 << 11)
+#define IOPARM_DT_HAS_FORMAT (1 << 12)
+#define IOPARM_DT_HAS_ADVANCE (1 << 13)
+#define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14)
+#define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15)
+/* Internal use bit. */
+#define IOPARM_DT_IONML_SET (1 << 31)
+
+typedef struct st_parameter_dt
+{
+ st_parameter_common common;
+ GFC_INTEGER_4 rec;
+ GFC_INTEGER_4 *size, *iolength;
gfc_array_char *internal_unit_desc;
- CHARACTER (sequential);
- CHARACTER (direct);
- CHARACTER (formatted);
- CHARACTER (unformatted);
- CHARACTER (read);
- CHARACTER (write);
- CHARACTER (readwrite);
-
-/* namelist related data */
- CHARACTER (namelist_name);
- GFC_INTEGER_4 namelist_read_mode;
-
- /* iomsg */
- CHARACTER (iomsg);
-
-#undef CHARACTER
+ CHARACTER1 (format);
+ CHARACTER2 (advance);
+ CHARACTER1 (internal_unit);
+ CHARACTER2 (namelist_name);
+ /* Private part of the structure. The compiler just needs
+ to reserve enough space. */
+ union
+ {
+ struct
+ {
+ void (*transfer) (struct st_parameter_dt *, bt, void *, int,
+ size_t, size_t);
+ struct gfc_unit *current_unit;
+ int item_count; /* Item number in a formatted data transfer. */
+ unit_mode mode;
+ unit_blank blank_status;
+ enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
+ int scale_factor;
+ int max_pos; /* Maximum righthand column written to. */
+ /* Number of skips + spaces to be done for T and X-editing. */
+ int skips;
+ /* Number of spaces to be done for T and X-editing. */
+ int pending_spaces;
+ unit_advance advance_status;
+ char reversion_flag; /* Format reversion has occurred. */
+ char first_item;
+ char seen_dollar;
+ char sf_seen_eor;
+ char eor_condition;
+ char no_leading_blank;
+ char nml_delim;
+ char char_flag;
+ char input_complete;
+ char at_eol;
+ char comma_flag;
+ char last_char;
+ /* A namelist specific flag used in the list directed library
+ to flag that calls are being made from namelist read (eg. to
+ ignore comments or to treat '/' as a terminator) */
+ char namelist_mode;
+ /* A namelist specific flag used in the list directed library
+ to flag read errors and return, so that an attempt can be
+ made to read a new object name. */
+ char nml_read_error;
+ /* Storage area for values except for strings. Must be large
+ enough to hold a complex value (two reals) of the largest
+ kind. */
+ char value[32];
+ int repeat_count;
+ int saved_length;
+ int saved_used;
+ bt saved_type;
+ char *saved_string;
+ char *scratch;
+ char *line_buffer;
+ struct format_data *fmt;
+ jmp_buf *eof_jump;
+ namelist_info *ionml;
+ } p;
+ char pad[16 * sizeof (char *) + 32 * sizeof (int)];
+ } u;
}
-st_parameter;
+st_parameter_dt;
-extern st_parameter ioparm;
-iexport_data_proto(ioparm);
-
-extern namelist_info * ionml;
-internal_proto(ionml);
+#undef CHARACTER1
+#undef CHARACTER2
typedef struct
{
{ NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
endfile;
- unit_mode mode;
+ unit_mode mode;
unit_flags flags;
-
+
/* recl -- Record length of the file.
last_record -- Last record number read or written
maxrec -- Maximum record number in a direct access file
bytes_left -- Bytes left in current record. */
gfc_offset recl, last_record, maxrec, bytes_left;
+ __gthread_mutex_t lock;
+ /* Number of threads waiting to acquire this unit's lock.
+ When non-zero, close_unit doesn't only removes the unit
+ from the UNIT_ROOT tree, but doesn't free it and the
+ last of the waiting threads will do that.
+ This must be either atomically increased/decreased, or
+ always guarded by UNIT_LOCK. */
+ int waiting;
+ /* Flag set by close_unit if the unit as been closed.
+ Must be manipulated under unit's lock. */
+ int closed;
+
/* For traversing arrays */
array_loop_spec *ls;
int rank;
-
- /* Filename is allocated at the end of the structure. */
+
int file_len;
- char file[1];
+ char *file;
}
gfc_unit;
-/* Global variables. Putting these in a structure makes it easier to
- maintain, particularly with the constraint of a prefix. */
-
-typedef struct
-{
- int in_library; /* Nonzero if a library call is being processed. */
- int size; /* Bytes processed by the current data-transfer statement. */
- gfc_offset max_offset; /* Maximum file offset. */
- int item_count; /* Item number in a formatted data transfer. */
- int reversion_flag; /* Format reversion has occurred. */
- int first_item;
-
- gfc_unit *unit_root;
- int seen_dollar;
-
- unit_mode mode;
-
- unit_blank blank_status;
- enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
- int scale_factor;
- jmp_buf eof_jump;
-}
-global_t;
-
-extern global_t g;
-internal_proto(g);
-
-extern gfc_unit *current_unit;
-internal_proto(current_unit);
-
/* Format tokens. Only about half of these can be stored in the
format nodes. */
extern int compare_files (stream *, stream *);
internal_proto(compare_files);
-extern stream *init_error_stream (void);
-internal_proto(init_error_stream);
-
-extern stream *open_external (unit_flags *);
+extern stream *open_external (st_parameter_open *, unit_flags *);
internal_proto(open_external);
extern stream *open_internal (char *, int);
extern int compare_file_filename (gfc_unit *, const char *, int);
internal_proto(compare_file_filename);
-extern gfc_unit *find_file (void);
+extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
internal_proto(find_file);
+extern void flush_all_units (void);
+internal_proto(flush_all_units);
+
extern int stream_at_bof (stream *);
internal_proto(stream_at_bof);
extern int delete_file (gfc_unit *);
internal_proto(delete_file);
-extern int file_exists (void);
+extern int file_exists (const char *file, gfc_charlen_type file_len);
internal_proto(file_exists);
extern const char *inquire_sequential (const char *, int);
/* unit.c */
-extern void insert_unit (gfc_unit *);
-internal_proto(insert_unit);
+/* Maximum file offset, computed at library initialization time. */
+extern gfc_offset max_offset;
+internal_proto(max_offset);
+
+/* Unit tree root. */
+extern gfc_unit *unit_root;
+internal_proto(unit_root);
+
+extern __gthread_mutex_t unit_lock;
+internal_proto(unit_lock);
extern int close_unit (gfc_unit *);
internal_proto(close_unit);
-extern int is_internal_unit (void);
+extern int is_internal_unit (st_parameter_dt *);
internal_proto(is_internal_unit);
-extern int is_array_io (void);
+extern int is_array_io (st_parameter_dt *);
internal_proto(is_array_io);
extern gfc_unit *find_unit (int);
internal_proto(find_unit);
-extern gfc_unit *get_unit (int);
+extern gfc_unit *find_or_create_unit (int);
+internal_proto(find_unit);
+
+extern gfc_unit *get_unit (st_parameter_dt *, int);
internal_proto(get_unit);
+extern void unlock_unit (gfc_unit *);
+internal_proto(unlock_unit);
+
/* open.c */
extern void test_endfile (gfc_unit *);
internal_proto(test_endfile);
-extern void new_unit (unit_flags *);
+extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
internal_proto(new_unit);
/* format.c */
-extern void parse_format (void);
+extern void parse_format (st_parameter_dt *);
internal_proto(parse_format);
-extern fnode *next_format (void);
+extern const fnode *next_format (st_parameter_dt *);
internal_proto(next_format);
-extern void unget_format (fnode *);
+extern void unget_format (st_parameter_dt *, const fnode *);
internal_proto(unget_format);
-extern void format_error (fnode *, const char *);
+extern void format_error (st_parameter_dt *, const fnode *, const char *);
internal_proto(format_error);
-extern void free_fnodes (void);
-internal_proto(free_fnodes);
+extern void free_format_data (st_parameter_dt *);
+internal_proto(free_format_data);
/* transfer.c */
#define SCRATCH_SIZE 300
-extern char scratch[];
-internal_proto(scratch);
-
extern const char *type_name (bt);
internal_proto(type_name);
-extern void *read_block (int *);
+extern void *read_block (st_parameter_dt *, int *);
internal_proto(read_block);
-extern void *write_block (int);
+extern void *write_block (st_parameter_dt *, int);
internal_proto(write_block);
-extern gfc_offset next_array_record (array_loop_spec *);
+extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *);
internal_proto(next_array_record);
-extern gfc_offset init_loop_spec (gfc_array_char *desc, array_loop_spec *ls);
+extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *);
internal_proto(init_loop_spec);
-extern void next_record (int);
+extern void next_record (st_parameter_dt *, int);
internal_proto(next_record);
/* read.c */
extern GFC_UINTEGER_LARGEST max_value (int, int);
internal_proto(max_value);
-extern int convert_real (void *, const char *, int);
+extern int convert_real (st_parameter_dt *, void *, const char *, int);
internal_proto(convert_real);
-extern void read_a (fnode *, char *, int);
+extern void read_a (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_a);
-extern void read_f (fnode *, char *, int);
+extern void read_f (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_f);
-extern void read_l (fnode *, char *, int);
+extern void read_l (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_l);
-extern void read_x (int);
+extern void read_x (st_parameter_dt *, int);
internal_proto(read_x);
-extern void read_radix (fnode *, char *, int, int);
+extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
internal_proto(read_radix);
-extern void read_decimal (fnode *, char *, int);
+extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_decimal);
/* list_read.c */
-extern void list_formatted_read (bt, void *, int, size_t, size_t);
+extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
+ size_t);
internal_proto(list_formatted_read);
-extern void finish_list_read (void);
+extern void finish_list_read (st_parameter_dt *);
internal_proto(finish_list_read);
-extern void init_at_eol (void);
-internal_proto(init_at_eol);
-
-extern void namelist_read (void);
+extern void namelist_read (st_parameter_dt *);
internal_proto(namelist_read);
-extern void namelist_write (void);
+extern void namelist_write (st_parameter_dt *);
internal_proto(namelist_write);
/* write.c */
-extern void write_a (fnode *, const char *, int);
+extern void write_a (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_a);
-extern void write_b (fnode *, const char *, int);
+extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_b);
-extern void write_d (fnode *, const char *, int);
+extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_d);
-extern void write_e (fnode *, const char *, int);
+extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_e);
-extern void write_en (fnode *, const char *, int);
+extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_en);
-extern void write_es (fnode *, const char *, int);
+extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_es);
-extern void write_f (fnode *, const char *, int);
+extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_f);
-extern void write_i (fnode *, const char *, int);
+extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_i);
-extern void write_l (fnode *, char *, int);
+extern void write_l (st_parameter_dt *, const fnode *, char *, int);
internal_proto(write_l);
-extern void write_o (fnode *, const char *, int);
+extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_o);
-extern void write_x (int, int);
+extern void write_x (st_parameter_dt *, int, int);
internal_proto(write_x);
-extern void write_z (fnode *, const char *, int);
+extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_z);
-extern void list_formatted_write (bt, void *, int, size_t, size_t);
+extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
+ size_t);
internal_proto(list_formatted_write);
/* error.c */
extern size_t size_from_complex_kind (int);
internal_proto(size_from_complex_kind);
+/* lock.c */
+extern void free_ionml (st_parameter_dt *);
+internal_proto(free_ionml);
+
+static inline void
+inc_waiting_locked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+ (void) __sync_fetch_and_add (&u->waiting, 1);
+#else
+ u->waiting++;
+#endif
+}
+
+static inline int
+predec_waiting_locked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+ return __sync_add_and_fetch (&u->waiting, -1);
+#else
+ return --u->waiting;
+#endif
+}
+
+static inline void
+dec_waiting_unlocked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+ (void) __sync_fetch_and_add (&u->waiting, -1);
+#else
+ __gthread_mutex_lock (&unit_lock);
+ u->waiting--;
+ __gthread_mutex_unlock (&unit_lock);
+#endif
+}
+
#endif
the repeat count. Since we can have a lot of potential leading
zeros, we have to be able to back up by arbitrary amount. Because
the input might not be seekable, we have to buffer the data
- ourselves. Data is buffered in scratch[] until it becomes too
- large, after which we start allocating memory on the heap. */
-
-static int repeat_count, saved_length, saved_used;
-static int input_complete, at_eol, comma_flag;
-static char last_char, *saved_string;
-static bt saved_type;
-
-/* A namelist specific flag used in the list directed library
- to flag that calls are being made from namelist read (eg. to ignore
- comments or to treat '/' as a terminator) */
-
-static int namelist_mode;
-
-/* A namelist specific flag used in the list directed library to flag
- read errors and return, so that an attempt can be made to read a
- new object name. */
-
-static int nml_read_error;
-
-/* Storage area for values except for strings. Must be large enough
- to hold a complex value (two reals) of the largest kind. */
-
-static char value[32];
+ ourselves. */
#define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
case '5': case '6': case '7': case '8': case '9'
/* Save a character to a string buffer, enlarging it as necessary. */
static void
-push_char (char c)
+push_char (st_parameter_dt *dtp, char c)
{
char *new;
- if (saved_string == NULL)
+ if (dtp->u.p.saved_string == NULL)
{
- saved_string = scratch;
- memset (saved_string,0,SCRATCH_SIZE);
- saved_length = SCRATCH_SIZE;
- saved_used = 0;
+ if (dtp->u.p.scratch == NULL)
+ dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
+ dtp->u.p.saved_string = dtp->u.p.scratch;
+ memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
+ dtp->u.p.saved_length = SCRATCH_SIZE;
+ dtp->u.p.saved_used = 0;
}
- if (saved_used >= saved_length)
+ if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
{
- saved_length = 2 * saved_length;
- new = get_mem (2 * saved_length);
+ dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
+ new = get_mem (2 * dtp->u.p.saved_length);
- memset (new,0,2 * saved_length);
+ memset (new, 0, 2 * dtp->u.p.saved_length);
- memcpy (new, saved_string, saved_used);
- if (saved_string != scratch)
- free_mem (saved_string);
+ memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
+ if (dtp->u.p.saved_string != dtp->u.p.scratch)
+ free_mem (dtp->u.p.saved_string);
- saved_string = new;
+ dtp->u.p.saved_string = new;
}
- saved_string[saved_used++] = c;
+ dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
}
/* Free the input buffer if necessary. */
static void
-free_saved (void)
+free_saved (st_parameter_dt *dtp)
{
- if (saved_string == NULL)
+ if (dtp->u.p.saved_string == NULL)
return;
- if (saved_string != scratch)
- free_mem (saved_string);
+ if (dtp->u.p.saved_string != dtp->u.p.scratch)
+ free_mem (dtp->u.p.saved_string);
- saved_string = NULL;
- saved_used = 0;
+ dtp->u.p.saved_string = NULL;
+ dtp->u.p.saved_used = 0;
}
static char
-next_char (void)
+next_char (st_parameter_dt *dtp)
{
int length;
char c, *p;
- if (last_char != '\0')
+ if (dtp->u.p.last_char != '\0')
{
- at_eol = 0;
- c = last_char;
- last_char = '\0';
+ dtp->u.p.at_eol = 0;
+ c = dtp->u.p.last_char;
+ dtp->u.p.last_char = '\0';
goto done;
}
length = 1;
- p = salloc_r (current_unit->s, &length);
+ p = salloc_r (dtp->u.p.current_unit->s, &length);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
return '\0';
}
/* For internal files return a newline instead of signalling EOF. */
/* ??? This isn't quite right, but we don't handle internal files
with multiple records. */
- if (is_internal_unit ())
+ if (is_internal_unit (dtp))
c = '\n';
else
- longjmp (g.eof_jump, 1);
+ longjmp (*dtp->u.p.eof_jump, 1);
}
else
c = *p;
done:
- at_eol = (c == '\n' || c == '\r');
+ dtp->u.p.at_eol = (c == '\n' || c == '\r');
return c;
}
/* Push a character back onto the input. */
static void
-unget_char (char c)
+unget_char (st_parameter_dt *dtp, char c)
{
- last_char = c;
+ dtp->u.p.last_char = c;
}
terminated the eating and also places it back on the input. */
static char
-eat_spaces (void)
+eat_spaces (st_parameter_dt *dtp)
{
char c;
do
{
- c = next_char ();
+ c = next_char (dtp);
}
while (c == ' ' || c == '\t');
- unget_char (c);
+ unget_char (dtp, c);
return c;
}
of the separator. */
static void
-eat_separator (void)
+eat_separator (st_parameter_dt *dtp)
{
char c;
- eat_spaces ();
- comma_flag = 0;
+ eat_spaces (dtp);
+ dtp->u.p.comma_flag = 0;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case ',':
- comma_flag = 1;
- eat_spaces ();
+ dtp->u.p.comma_flag = 1;
+ eat_spaces (dtp);
break;
case '/':
- input_complete = 1;
+ dtp->u.p.input_complete = 1;
break;
case '\n':
case '\r':
- at_eol = 1;
+ dtp->u.p.at_eol = 1;
break;
case '!':
- if (namelist_mode)
+ if (dtp->u.p.namelist_mode)
{ /* Eat a namelist comment. */
do
- c = next_char ();
+ c = next_char (dtp);
while (c != '\n');
break;
/* Fall Through... */
default:
- unget_char (c);
+ unget_char (dtp, c);
break;
}
}
we started on the previous line. */
static void
-finish_separator (void)
+finish_separator (st_parameter_dt *dtp)
{
char c;
restart:
- eat_spaces ();
+ eat_spaces (dtp);
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case ',':
- if (comma_flag)
- unget_char (c);
+ if (dtp->u.p.comma_flag)
+ unget_char (dtp, c);
else
{
- c = eat_spaces ();
+ c = eat_spaces (dtp);
if (c == '\n')
goto restart;
}
break;
case '/':
- input_complete = 1;
- if (!namelist_mode) next_record (0);
+ dtp->u.p.input_complete = 1;
+ if (!dtp->u.p.namelist_mode) next_record (dtp, 0);
break;
case '\n':
goto restart;
case '!':
- if (namelist_mode)
+ if (dtp->u.p.namelist_mode)
{
do
- c = next_char ();
+ c = next_char (dtp);
while (c != '\n');
goto restart;
}
default:
- unget_char (c);
+ unget_char (dtp, c);
break;
}
}
/* This function is needed to catch bad conversions so that namelist can
- attempt to see if saved_string contains a new object name rather than
- a bad value. */
+ attempt to see if dtp->u.p.saved_string contains a new object name rather
+ than a bad value. */
static int
-nml_bad_return (char c)
+nml_bad_return (st_parameter_dt *dtp, char c)
{
- if (namelist_mode)
+ if (dtp->u.p.namelist_mode)
{
- nml_read_error = 1;
- unget_char(c);
+ dtp->u.p.nml_read_error = 1;
+ unget_char (dtp, c);
return 1;
}
return 0;
/* Convert an unsigned string to an integer. The length value is -1
if we are working on a repeat count. Returns nonzero if we have a
- range problem. As a side effect, frees the saved_string. */
+ range problem. As a side effect, frees the dtp->u.p.saved_string. */
static int
-convert_integer (int length, int negative)
+convert_integer (st_parameter_dt *dtp, int length, int negative)
{
char c, *buffer, message[100];
int m;
GFC_INTEGER_LARGEST v, max, max10;
- buffer = saved_string;
+ buffer = dtp->u.p.saved_string;
v = 0;
max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
{
if (negative)
v = -v;
- set_integer (value, v, length);
+ set_integer (dtp->u.p.value, v, length);
}
else
{
- repeat_count = v;
+ dtp->u.p.repeat_count = v;
- if (repeat_count == 0)
+ if (dtp->u.p.repeat_count == 0)
{
st_sprintf (message, "Zero repeat count in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
m = 1;
}
}
- free_saved ();
+ free_saved (dtp);
return m;
overflow:
if (length == -1)
st_sprintf (message, "Repeat count overflow in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
else
st_sprintf (message, "Integer overflow while reading item %d",
- g.item_count);
+ dtp->u.p.item_count);
- free_saved ();
- generate_error (ERROR_READ_VALUE, message);
+ free_saved (dtp);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
should continue on. */
static int
-parse_repeat (void)
+parse_repeat (st_parameter_dt *dtp)
{
char c, message[100];
int repeat;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
break;
CASE_SEPARATORS:
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
return 1;
default:
- unget_char (c);
+ unget_char (dtp, c);
return 0;
}
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
{
st_sprintf (message,
"Repeat count overflow in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
{
st_sprintf (message,
"Zero repeat count in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
}
done:
- repeat_count = repeat;
+ dtp->u.p.repeat_count = repeat;
return 0;
bad_repeat:
st_sprintf (message, "Bad repeat count in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
/* Read a logical character on the input. */
static void
-read_logical (int length)
+read_logical (st_parameter_dt *dtp, int length)
{
char c, message[100];
int v;
- if (parse_repeat ())
+ if (parse_repeat (dtp))
return;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case 't':
break;
case '.':
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case 't':
break;
CASE_SEPARATORS:
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
return; /* Null value. */
default:
goto bad_logical;
}
- saved_type = BT_LOGICAL;
- saved_length = length;
+ dtp->u.p.saved_type = BT_LOGICAL;
+ dtp->u.p.saved_length = length;
/* Eat trailing garbage. */
do
{
- c = next_char ();
+ c = next_char (dtp);
}
while (!is_separator (c));
- unget_char (c);
- eat_separator ();
- free_saved ();
- set_integer ((int *) value, v, length);
+ unget_char (dtp, c);
+ eat_separator (dtp);
+ free_saved (dtp);
+ set_integer ((int *) dtp->u.p.value, v, length);
return;
bad_logical:
- if (nml_bad_return (c))
+ if (nml_bad_return (dtp, c))
return;
st_sprintf (message, "Bad logical value while reading item %d",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
used for repeat counts. */
static void
-read_integer (int length)
+read_integer (st_parameter_dt *dtp, int length)
{
char c, message[100];
int negative;
negative = 0;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '-':
/* Fall through... */
case '+':
- c = next_char ();
+ c = next_char (dtp);
goto get_integer;
CASE_SEPARATORS: /* Single null. */
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
return;
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
default:
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
case '*':
- push_char ('\0');
+ push_char (dtp, '\0');
goto repeat;
CASE_SEPARATORS: /* Not a repeat count. */
}
repeat:
- if (convert_integer (-1, 0))
+ if (convert_integer (dtp, -1, 0))
return;
/* Get the real integer. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
break;
CASE_SEPARATORS:
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
return;
case '-':
/* Fall through... */
case '+':
- c = next_char ();
+ c = next_char (dtp);
break;
}
get_integer:
if (!isdigit (c))
goto bad_integer;
- push_char (c);
+ push_char (dtp, c);
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
CASE_SEPARATORS:
bad_integer:
- if (nml_bad_return (c))
+ if (nml_bad_return (dtp, c))
return;
- free_saved ();
+ free_saved (dtp);
- st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ st_sprintf (message, "Bad integer for item %d in list input",
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return;
done:
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
- push_char ('\0');
- if (convert_integer (length, negative))
+ push_char (dtp, '\0');
+ if (convert_integer (dtp, length, negative))
{
- free_saved ();
+ free_saved (dtp);
return;
}
- free_saved ();
- saved_type = BT_INTEGER;
+ free_saved (dtp);
+ dtp->u.p.saved_type = BT_INTEGER;
}
/* Read a character variable. */
static void
-read_character (int length __attribute__ ((unused)))
+read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
{
char c, quote, message[100];
quote = ' '; /* Space means no quote character. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
CASE_SEPARATORS:
- unget_char (c); /* NULL value. */
- eat_separator ();
+ unget_char (dtp, c); /* NULL value. */
+ eat_separator (dtp);
return;
case '"':
goto get_string;
default:
- push_char (c);
+ push_char (dtp, c);
goto get_string;
}
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
CASE_SEPARATORS:
- unget_char (c);
+ unget_char (dtp, c);
goto done; /* String was only digits! */
case '*':
- push_char ('\0');
+ push_char (dtp, '\0');
goto got_repeat;
default:
- push_char (c);
+ push_char (dtp, c);
goto get_string; /* Not a repeat count after all. */
}
}
got_repeat:
- if (convert_integer (-1, 0))
+ if (convert_integer (dtp, -1, 0))
return;
/* Now get the real string. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_SEPARATORS:
- unget_char (c); /* Repeated NULL values. */
- eat_separator ();
+ unget_char (dtp, c); /* Repeated NULL values. */
+ eat_separator (dtp);
return;
case '"':
break;
default:
- push_char (c);
+ push_char (dtp, c);
break;
}
get_string:
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '"':
case '\'':
if (c != quote)
{
- push_char (c);
+ push_char (dtp, c);
break;
}
/* See if we have a doubled quote character or the end of
the string. */
- c = next_char ();
+ c = next_char (dtp);
if (c == quote)
{
- push_char (quote);
+ push_char (dtp, quote);
break;
}
- unget_char (c);
+ unget_char (dtp, c);
goto done;
CASE_SEPARATORS:
if (quote == ' ')
{
- unget_char (c);
+ unget_char (dtp, c);
goto done;
}
if (c != '\n')
- push_char (c);
+ push_char (dtp, c);
break;
default:
- push_char (c);
+ push_char (dtp, c);
break;
}
}
/* At this point, we have to have a separator, or else the string is
invalid. */
done:
- c = next_char ();
+ c = next_char (dtp);
if (is_separator (c))
{
- unget_char (c);
- eat_separator ();
- saved_type = BT_CHARACTER;
+ unget_char (dtp, c);
+ eat_separator (dtp);
+ dtp->u.p.saved_type = BT_CHARACTER;
}
else
{
- free_saved ();
- st_sprintf (message, "Invalid string input in item %d", g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ free_saved (dtp);
+ st_sprintf (message, "Invalid string input in item %d",
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
}
are sure is already there. This is a straight real number parser. */
static int
-parse_real (void *buffer, int length)
+parse_real (st_parameter_dt *dtp, void *buffer, int length)
{
char c, message[100];
int m, seen_dp;
- c = next_char ();
+ c = next_char (dtp);
if (c == '-' || c == '+')
{
- push_char (c);
- c = next_char ();
+ push_char (dtp, c);
+ c = next_char (dtp);
}
if (!isdigit (c) && c != '.')
goto bad;
- push_char (c);
+ push_char (dtp, c);
seen_dp = (c == '.') ? 1 : 0;
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
case '.':
goto bad;
seen_dp = 1;
- push_char (c);
+ push_char (dtp, c);
break;
case 'e':
case 'E':
case 'd':
case 'D':
- push_char ('e');
+ push_char (dtp, 'e');
goto exp1;
case '-':
case '+':
- push_char ('e');
- push_char (c);
- c = next_char ();
+ push_char (dtp, 'e');
+ push_char (dtp, c);
+ c = next_char (dtp);
goto exp2;
CASE_SEPARATORS:
- unget_char (c);
+ unget_char (dtp, c);
goto done;
default:
}
exp1:
- c = next_char ();
+ c = next_char (dtp);
if (c != '-' && c != '+')
- push_char ('+');
+ push_char (dtp, '+');
else
{
- push_char (c);
- c = next_char ();
+ push_char (dtp, c);
+ c = next_char (dtp);
}
exp2:
if (!isdigit (c))
goto bad;
- push_char (c);
+ push_char (dtp, c);
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
CASE_SEPARATORS:
- unget_char (c);
+ unget_char (dtp, c);
goto done;
default:
}
done:
- unget_char (c);
- push_char ('\0');
+ unget_char (dtp, c);
+ push_char (dtp, '\0');
- m = convert_real (buffer, saved_string, length);
- free_saved ();
+ m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
+ free_saved (dtp);
return m;
bad:
- free_saved ();
- st_sprintf (message, "Bad floating point number for item %d", g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ free_saved (dtp);
+ st_sprintf (message, "Bad floating point number for item %d",
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
what it is right away. */
static void
-read_complex (int kind, size_t size)
+read_complex (st_parameter_dt *dtp, int kind, size_t size)
{
char message[100];
char c;
- if (parse_repeat ())
+ if (parse_repeat (dtp))
return;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '(':
break;
CASE_SEPARATORS:
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
return;
default:
goto bad_complex;
}
- eat_spaces ();
- if (parse_real (value, kind))
+ eat_spaces (dtp);
+ if (parse_real (dtp, dtp->u.p.value, kind))
return;
eol_1:
- eat_spaces ();
- c = next_char ();
+ eat_spaces (dtp);
+ c = next_char (dtp);
if (c == '\n' || c== '\r')
goto eol_1;
else
- unget_char (c);
+ unget_char (dtp, c);
- if (next_char () != ',')
+ if (next_char (dtp) != ',')
goto bad_complex;
eol_2:
- eat_spaces ();
- c = next_char ();
+ eat_spaces (dtp);
+ c = next_char (dtp);
if (c == '\n' || c== '\r')
goto eol_2;
else
- unget_char (c);
+ unget_char (dtp, c);
- if (parse_real (value + size / 2, kind))
+ if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
return;
- eat_spaces ();
- if (next_char () != ')')
+ eat_spaces (dtp);
+ if (next_char (dtp) != ')')
goto bad_complex;
- c = next_char ();
+ c = next_char (dtp);
if (!is_separator (c))
goto bad_complex;
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
- free_saved ();
- saved_type = BT_COMPLEX;
+ free_saved (dtp);
+ dtp->u.p.saved_type = BT_COMPLEX;
return;
bad_complex:
- if (nml_bad_return (c))
+ if (nml_bad_return (dtp, c))
return;
st_sprintf (message, "Bad complex value in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
/* Parse a real number with a possible repeat count. */
static void
-read_real (int length)
+read_real (st_parameter_dt *dtp, int length)
{
char c, message[100];
int seen_dp;
seen_dp = 0;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
case '.':
- push_char (c);
+ push_char (dtp, c);
seen_dp = 1;
break;
goto got_sign;
CASE_SEPARATORS:
- unget_char (c); /* Single null. */
- eat_separator ();
+ unget_char (dtp, c); /* Single null. */
+ eat_separator (dtp);
return;
default:
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
case '.':
goto bad_real;
seen_dp = 1;
- push_char (c);
+ push_char (dtp, c);
goto real_loop;
case 'E':
case '+':
case '-':
- push_char ('e');
- push_char (c);
- c = next_char ();
+ push_char (dtp, 'e');
+ push_char (dtp, c);
+ c = next_char (dtp);
goto exp2;
case '*':
- push_char ('\0');
+ push_char (dtp, '\0');
goto got_repeat;
CASE_SEPARATORS:
if (c != '\n' && c != ',' && c != '\r')
- unget_char (c);
+ unget_char (dtp, c);
goto done;
default:
}
got_repeat:
- if (convert_integer (-1, 0))
+ if (convert_integer (dtp, -1, 0))
return;
/* Now get the number itself. */
- c = next_char ();
+ c = next_char (dtp);
if (is_separator (c))
{ /* Repeated null value. */
- unget_char (c);
- eat_separator ();
+ unget_char (dtp, c);
+ eat_separator (dtp);
return;
}
if (c != '-' && c != '+')
- push_char ('+');
+ push_char (dtp, '+');
else
{
got_sign:
- push_char (c);
- c = next_char ();
+ push_char (dtp, c);
+ c = next_char (dtp);
}
if (!isdigit (c) && c != '.')
seen_dp = 1;
}
- push_char (c);
+ push_char (dtp, c);
real_loop:
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
CASE_SEPARATORS:
goto bad_real;
seen_dp = 1;
- push_char (c);
+ push_char (dtp, c);
break;
case 'E':
case '+':
case '-':
- push_char ('e');
- push_char (c);
- c = next_char ();
+ push_char (dtp, 'e');
+ push_char (dtp, c);
+ c = next_char (dtp);
goto exp2;
default:
}
exp1:
- push_char ('e');
+ push_char (dtp, 'e');
- c = next_char ();
+ c = next_char (dtp);
if (c != '+' && c != '-')
- push_char ('+');
+ push_char (dtp, '+');
else
{
- push_char (c);
- c = next_char ();
+ push_char (dtp, c);
+ c = next_char (dtp);
}
exp2:
if (!isdigit (c))
goto bad_real;
- push_char (c);
+ push_char (dtp, c);
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
break;
CASE_SEPARATORS:
}
done:
- unget_char (c);
- eat_separator ();
- push_char ('\0');
- if (convert_real (value, saved_string, length))
+ unget_char (dtp, c);
+ eat_separator (dtp);
+ push_char (dtp, '\0');
+ if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
return;
- free_saved ();
- saved_type = BT_REAL;
+ free_saved (dtp);
+ dtp->u.p.saved_type = BT_REAL;
return;
bad_real:
- if (nml_bad_return (c))
+ if (nml_bad_return (dtp, c))
return;
st_sprintf (message, "Bad real number in item %d of list input",
- g.item_count);
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
compatible. Returns nonzero if incompatible. */
static int
-check_type (bt type, int len)
+check_type (st_parameter_dt *dtp, bt type, int len)
{
char message[100];
- if (saved_type != BT_NULL && saved_type != type)
+ if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
{
st_sprintf (message, "Read type %s where %s was expected for item %d",
- type_name (saved_type), type_name (type), g.item_count);
+ type_name (dtp->u.p.saved_type), type_name (type),
+ dtp->u.p.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
- if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
+ if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
return 0;
- if (saved_length != len)
+ if (dtp->u.p.saved_length != len)
{
st_sprintf (message,
"Read kind %d %s where kind %d is required for item %d",
- saved_length, type_name (saved_type), len, g.item_count);
- generate_error (ERROR_READ_VALUE, message);
+ dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
/* Top level data transfer subroutine for list reads. Because we have
to deal with repeat counts, the data item is always saved after
- reading, usually in the value[] array. If a repeat count is
+ reading, usually in the dtp->u.p.value[] array. If a repeat count is
greater than one, we copy the data item multiple times. */
static void
-list_formatted_read_scalar (bt type, void *p, int kind, size_t size)
+list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size)
{
char c;
int m;
+ jmp_buf eof_jump;
- namelist_mode = 0;
+ dtp->u.p.namelist_mode = 0;
- if (setjmp (g.eof_jump))
+ dtp->u.p.eof_jump = &eof_jump;
+ if (setjmp (eof_jump))
{
- generate_error (ERROR_END, NULL);
- return;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ goto cleanup;
}
- if (g.first_item)
+ if (dtp->u.p.first_item)
{
- g.first_item = 0;
- input_complete = 0;
- repeat_count = 1;
- at_eol = 0;
+ dtp->u.p.first_item = 0;
+ dtp->u.p.input_complete = 0;
+ dtp->u.p.repeat_count = 1;
+ dtp->u.p.at_eol = 0;
- c = eat_spaces ();
+ c = eat_spaces (dtp);
if (is_separator (c))
{ /* Found a null value. */
- eat_separator ();
- repeat_count = 0;
- if (at_eol)
- finish_separator ();
+ eat_separator (dtp);
+ dtp->u.p.repeat_count = 0;
+ if (dtp->u.p.at_eol)
+ finish_separator (dtp);
else
- return;
+ goto cleanup;
}
}
else
{
- if (input_complete)
- return;
+ if (dtp->u.p.input_complete)
+ goto cleanup;
- if (repeat_count > 0)
+ if (dtp->u.p.repeat_count > 0)
{
- if (check_type (type, kind))
+ if (check_type (dtp, type, kind))
return;
goto set_value;
}
- if (at_eol)
- finish_separator ();
+ if (dtp->u.p.at_eol)
+ finish_separator (dtp);
else
{
- eat_spaces ();
+ eat_spaces (dtp);
/* trailing spaces prior to end of line */
- if (at_eol)
- finish_separator ();
+ if (dtp->u.p.at_eol)
+ finish_separator (dtp);
}
- saved_type = BT_NULL;
- repeat_count = 1;
+ dtp->u.p.saved_type = BT_NULL;
+ dtp->u.p.repeat_count = 1;
}
switch (type)
{
case BT_INTEGER:
- read_integer (kind);
+ read_integer (dtp, kind);
break;
case BT_LOGICAL:
- read_logical (kind);
+ read_logical (dtp, kind);
break;
case BT_CHARACTER:
- read_character (kind);
+ read_character (dtp, kind);
break;
case BT_REAL:
- read_real (kind);
+ read_real (dtp, kind);
break;
case BT_COMPLEX:
- read_complex (kind, size);
+ read_complex (dtp, kind, size);
break;
default:
- internal_error ("Bad type for list read");
+ internal_error (&dtp->common, "Bad type for list read");
}
- if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
- saved_length = size;
+ if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
+ dtp->u.p.saved_length = size;
- if (ioparm.library_return != LIBRARY_OK)
- return;
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ goto cleanup;
set_value:
- switch (saved_type)
+ switch (dtp->u.p.saved_type)
{
case BT_COMPLEX:
case BT_INTEGER:
case BT_REAL:
case BT_LOGICAL:
- memcpy (p, value, size);
+ memcpy (p, dtp->u.p.value, size);
break;
case BT_CHARACTER:
- if (saved_string)
+ if (dtp->u.p.saved_string)
{
- m = ((int) size < saved_used) ? (int) size : saved_used;
- memcpy (p, saved_string, m);
+ m = ((int) size < dtp->u.p.saved_used)
+ ? (int) size : dtp->u.p.saved_used;
+ memcpy (p, dtp->u.p.saved_string, m);
}
else
/* Just delimiters encountered, nothing to copy but SPACE. */
break;
}
- if (--repeat_count <= 0)
- free_saved ();
+ if (--dtp->u.p.repeat_count <= 0)
+ free_saved (dtp);
+
+cleanup:
+ dtp->u.p.eof_jump = NULL;
}
void
-list_formatted_read (bt type, void *p, int kind, size_t size, size_t nelems)
+list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size, size_t nelems)
{
size_t elem;
char *tmp;
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
- g.item_count++;
- list_formatted_read_scalar (type, tmp + size*elem, kind, size);
+ dtp->u.p.item_count++;
+ list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
}
}
-void
-init_at_eol(void)
-{
- at_eol = 0;
-}
-
/* Finish a list read. */
void
-finish_list_read (void)
+finish_list_read (st_parameter_dt *dtp)
{
char c;
- free_saved ();
+ free_saved (dtp);
- if (at_eol)
+ if (dtp->u.p.at_eol)
{
- at_eol = 0;
+ dtp->u.p.at_eol = 0;
return;
}
do
{
- c = next_char ();
+ c = next_char (dtp);
}
while (c != '\n');
}
/* NAMELIST INPUT
-void namelist_read (void)
+void namelist_read (st_parameter_dt *dtp)
calls:
static void nml_match_name (char *name, int len)
- static int nml_query (void)
- static int nml_get_obj_data (void)
+ static int nml_query (st_parameter_dt *dtp)
+ static int nml_get_obj_data (st_parameter_dt *dtp,
+ namelist_info **prev_nl, char *)
calls:
- static void nml_untouch_nodes (void)
- static namelist_info * find_nml_node (char * var_name)
+ static void nml_untouch_nodes (st_parameter_dt *dtp)
+ static namelist_info * find_nml_node (st_parameter_dt *dtp,
+ char * var_name)
static int nml_parse_qualifier(descriptor_dimension * ad,
- array_loop_spec * ls, int rank)
+ array_loop_spec * ls, int rank, char *)
static void nml_touch_nodes (namelist_info * nl)
- static int nml_read_obj (namelist_info * nl, index_type offset)
+ static int nml_read_obj (namelist_info *nl, index_type offset,
+ namelist_info **prev_nl, char *,
+ index_type clow, index_type chigh)
calls:
-itself- */
-/* Carries error messages from the qualifier parser. */
-static char parse_err_msg[30];
-
-/* Carries error messages for error returns. */
-static char nml_err_msg[100];
-
-/* Pointer to the previously read object, in case attempt is made to read
- new object name. Should this fail, error message can give previous
- name. */
-
-static namelist_info * prev_nl;
-
-/* Lower index for substring qualifier. */
-
-static index_type clow;
-
-/* Upper index for substring qualifier. */
-
-static index_type chigh;
-
/* Inputs a rank-dimensional qualifier, which can contain
singlets, doublets, triplets or ':' with the standard meanings. */
static try
-nml_parse_qualifier(descriptor_dimension * ad,
- array_loop_spec * ls, int rank)
+nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
+ array_loop_spec *ls, int rank, char *parse_err_msg)
{
int dim;
int indx;
/* The next character in the stream should be the '('. */
- c = next_char ();
+ c = next_char (dtp);
/* Process the qualifier, by dimension and triplet. */
{
for (indx=0; indx<3; indx++)
{
- free_saved ();
- eat_spaces ();
+ free_saved (dtp);
+ eat_spaces (dtp);
neg = 0;
/*process a potential sign. */
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '-':
break;
default:
- unget_char (c);
+ unget_char (dtp, c);
break;
}
for (;;)
{
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
break;
CASE_DIGITS:
- push_char (c);
+ push_char (dtp, c);
continue;
case ' ': case '\t':
- eat_spaces ();
- c = next_char ();
+ eat_spaces (dtp);
+ c = next_char (dtp);
break;
default:
goto err_ret;
}
- if (( c==',' || c==')') && indx==0 && saved_string == 0 )
+ if ((c == ',' || c == ')') && indx == 0
+ && dtp->u.p.saved_string == 0)
{
st_sprintf (parse_err_msg, "Null index field");
goto err_ret;
}
- if ( ( c==':' && indx==1 && saved_string == 0)
- || (indx==2 && saved_string == 0))
+ if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
+ || (indx == 2 && dtp->u.p.saved_string == 0))
{
st_sprintf(parse_err_msg, "Bad index triplet");
goto err_ret;
/* If '( : ? )' or '( ? : )' break and flag read failure. */
null_flag = 0;
- if ( (c==':' && indx==0 && saved_string == 0)
- || (indx==1 && saved_string == 0))
+ if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
+ || (indx==1 && dtp->u.p.saved_string == 0))
{
null_flag = 1;
break;
/* Now read the index. */
- if (convert_integer (sizeof(int),neg))
+ if (convert_integer (dtp, sizeof(int), neg))
{
st_sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
if (!null_flag)
{
if (indx == 0)
- ls[dim].start = *(int *)value;
+ ls[dim].start = *(int *)dtp->u.p.value;
if (indx == 1)
- ls[dim].end = *(int *)value;
+ ls[dim].end = *(int *)dtp->u.p.value;
if (indx == 2)
- ls[dim].step = *(int *)value;
+ ls[dim].step = *(int *)dtp->u.p.value;
}
/*singlet or doublet indices */
{
if (indx == 0)
{
- ls[dim].start = *(int *)value;
- ls[dim].end = *(int *)value;
+ ls[dim].start = *(int *)dtp->u.p.value;
+ ls[dim].end = *(int *)dtp->u.p.value;
}
break;
}
ls[dim].idx = ls[dim].start;
}
- eat_spaces ();
+ eat_spaces (dtp);
return SUCCESS;
err_ret:
}
static namelist_info *
-find_nml_node (char * var_name)
+find_nml_node (st_parameter_dt *dtp, char * var_name)
{
- namelist_info * t = ionml;
+ namelist_info * t = dtp->u.p.ionml;
while (t != NULL)
{
- if (strcmp (var_name,t->var_name) == 0)
+ if (strcmp (var_name, t->var_name) == 0)
{
t->touched = 1;
return t;
new object. */
static void
-nml_untouch_nodes (void)
+nml_untouch_nodes (st_parameter_dt *dtp)
{
namelist_info * t;
- for (t = ionml; t; t = t->next)
+ for (t = dtp->u.p.ionml; t; t = t->next)
t->touched = 0;
return;
}
-/* Attempts to input name to namelist name. Returns nml_read_error = 1
- on no match. */
+/* Attempts to input name to namelist name. Returns
+ dtp->u.p.nml_read_error = 1 on no match. */
static void
-nml_match_name (const char *name, index_type len)
+nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
{
index_type i;
char c;
- nml_read_error = 0;
+ dtp->u.p.nml_read_error = 0;
for (i = 0; i < len; i++)
{
- c = next_char ();
+ c = next_char (dtp);
if (tolower (c) != tolower (name[i]))
{
- nml_read_error = 1;
+ dtp->u.p.nml_read_error = 1;
break;
}
}
the names alone are printed. */
static void
-nml_query (char c)
+nml_query (st_parameter_dt *dtp, char c)
{
gfc_unit * temp_unit;
namelist_info * nl;
index_type len;
char * p;
- if (current_unit->unit_number != options.stdin_unit)
+ if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
return;
/* Store the current unit and transfer to stdout. */
- temp_unit = current_unit;
- current_unit = find_unit (options.stdout_unit);
+ temp_unit = dtp->u.p.current_unit;
+ dtp->u.p.current_unit = find_unit (options.stdout_unit);
- if (current_unit)
+ if (dtp->u.p.current_unit)
{
- g.mode =WRITING;
- next_record (0);
+ dtp->u.p.mode = WRITING;
+ next_record (dtp, 0);
/* Write the namelist in its entirety. */
if (c == '=')
- namelist_write ();
+ namelist_write (dtp);
/* Or write the list of names. */
/* "&namelist_name\n" */
- len = ioparm.namelist_name_len;
- p = write_block (len + 2);
+ len = dtp->namelist_name_len;
+ p = write_block (dtp, len + 2);
if (!p)
goto query_return;
memcpy (p, "&", 1);
- memcpy ((char*)(p + 1), ioparm.namelist_name, len);
+ memcpy ((char*)(p + 1), dtp->namelist_name, len);
memcpy ((char*)(p + len + 1), "\n", 1);
- for (nl =ionml; nl; nl = nl->next)
+ for (nl = dtp->u.p.ionml; nl; nl = nl->next)
{
/* " var_name\n" */
len = strlen (nl->var_name);
- p = write_block (len + 2);
+ p = write_block (dtp, len + 2);
if (!p)
goto query_return;
memcpy (p, " ", 1);
/* "&end\n" */
- p = write_block (5);
+ p = write_block (dtp, 5);
if (!p)
goto query_return;
memcpy (p, "&end\n", 5);
/* Flush the stream to force immediate output. */
- flush (current_unit->s);
+ flush (dtp->u.p.current_unit->s);
+ unlock_unit (dtp->u.p.current_unit);
}
query_return:
/* Restore the current unit. */
- current_unit = temp_unit;
- g.mode = READING;
+ dtp->u.p.current_unit = temp_unit;
+ dtp->u.p.mode = READING;
return;
}
error. */
static try
-nml_read_obj (namelist_info * nl, index_type offset)
+nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
+ namelist_info **pprev_nl, char *nml_err_msg,
+ index_type clow, index_type chigh)
{
namelist_info * cmp;
if (!nl->touched)
return SUCCESS;
- repeat_count = 0;
- eat_spaces();
+ dtp->u.p.repeat_count = 0;
+ eat_spaces (dtp);
len = nl->len;
switch (nl->type)
nl->dim[dim].stride * nl->size);
/* Reset the error flag and try to read next value, if
- repeat_count=0 */
+ dtp->u.p.repeat_count=0 */
- nml_read_error = 0;
+ dtp->u.p.nml_read_error = 0;
nml_carry = 0;
- if (--repeat_count <= 0)
+ if (--dtp->u.p.repeat_count <= 0)
{
- if (input_complete)
+ if (dtp->u.p.input_complete)
return SUCCESS;
- if (at_eol)
- finish_separator ();
- if (input_complete)
+ if (dtp->u.p.at_eol)
+ finish_separator (dtp);
+ if (dtp->u.p.input_complete)
return SUCCESS;
/* GFC_TYPE_UNKNOWN through for nulls and is detected
after the switch block. */
- saved_type = GFC_DTYPE_UNKNOWN;
- free_saved ();
+ dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
+ free_saved (dtp);
switch (nl->type)
{
case GFC_DTYPE_INTEGER:
- read_integer (len);
+ read_integer (dtp, len);
break;
case GFC_DTYPE_LOGICAL:
- read_logical (len);
+ read_logical (dtp, len);
break;
case GFC_DTYPE_CHARACTER:
- read_character (len);
+ read_character (dtp, len);
break;
case GFC_DTYPE_REAL:
- read_real (len);
+ read_real (dtp, len);
break;
case GFC_DTYPE_COMPLEX:
- read_complex (len, dlen);
+ read_complex (dtp, len, dlen);
break;
case GFC_DTYPE_DERIVED:
cmp = cmp->next)
{
- if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
+ if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
+ pprev_nl, nml_err_msg, clow, chigh)
+ == FAILURE)
{
free_mem (obj_name);
return FAILURE;
}
- if (input_complete)
+ if (dtp->u.p.input_complete)
{
free_mem (obj_name);
return SUCCESS;
default:
st_sprintf (nml_err_msg, "Bad type for namelist object %s",
- nl->var_name );
- internal_error (nml_err_msg);
+ nl->var_name);
+ internal_error (&dtp->common, nml_err_msg);
goto nml_err_ret;
}
}
/* The standard permits array data to stop short of the number of
elements specified in the loop specification. In this case, we
- should be here with nml_read_error != 0. Control returns to
+ should be here with dtp->u.p.nml_read_error != 0. Control returns to
nml_get_obj_data and an attempt is made to read object name. */
- prev_nl = nl;
- if (nml_read_error)
+ *pprev_nl = nl;
+ if (dtp->u.p.nml_read_error)
return SUCCESS;
- if (saved_type == GFC_DTYPE_UNKNOWN)
+ if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
goto incr_idx;
/* Note the switch from GFC_DTYPE_type to BT_type at this point.
This comes about because the read functions return BT_types. */
- switch (saved_type)
+ switch (dtp->u.p.saved_type)
{
case BT_COMPLEX:
case BT_REAL:
case BT_INTEGER:
case BT_LOGICAL:
- memcpy (pdata, value, dlen);
+ memcpy (pdata, dtp->u.p.value, dlen);
break;
case BT_CHARACTER:
- m = (dlen < saved_used) ? dlen : saved_used;
+ m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
pdata = (void*)( pdata + clow - 1 );
- memcpy (pdata, saved_string, m);
+ memcpy (pdata, dtp->u.p.saved_string, m);
if (m < dlen)
memset ((void*)( pdata + m ), ' ', dlen - m);
break;
}
} while (!nml_carry);
- if (repeat_count > 1)
+ if (dtp->u.p.repeat_count > 1)
{
st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
nl->var_name );
the manner specified by the object name. */
static try
-nml_get_obj_data (void)
+nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
+ char *nml_err_msg)
{
char c;
- char * ext_name;
namelist_info * nl;
namelist_info * first_nl = NULL;
namelist_info * root_nl = NULL;
int dim;
int component_flag;
+ char parse_err_msg[30];
+ index_type clow, chigh;
/* Look for end of input or object name. If '?' or '=?' are encountered
in stdin, print the node names or the namelist to stdout. */
- eat_separator ();
- if (input_complete)
+ eat_separator (dtp);
+ if (dtp->u.p.input_complete)
return SUCCESS;
- if ( at_eol )
- finish_separator ();
- if (input_complete)
+ if (dtp->u.p.at_eol)
+ finish_separator (dtp);
+ if (dtp->u.p.input_complete)
return SUCCESS;
- c = next_char ();
+ c = next_char (dtp);
switch (c)
{
case '=':
- c = next_char ();
+ c = next_char (dtp);
if (c != '?')
{
st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
goto nml_err_ret;
}
- nml_query ('=');
+ nml_query (dtp, '=');
return SUCCESS;
case '?':
- nml_query ('?');
+ nml_query (dtp, '?');
return SUCCESS;
case '$':
case '&':
- nml_match_name ("end", 3);
- if (nml_read_error)
+ nml_match_name (dtp, "end", 3);
+ if (dtp->u.p.nml_read_error)
{
st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
goto nml_err_ret;
}
case '/':
- input_complete = 1;
+ dtp->u.p.input_complete = 1;
return SUCCESS;
default :
/* Untouch all nodes of the namelist and reset the flag that is set for
derived type components. */
- nml_untouch_nodes();
+ nml_untouch_nodes (dtp);
component_flag = 0;
/* Get the object name - should '!' and '\n' be permitted separators? */
get_name:
- free_saved ();
+ free_saved (dtp);
do
{
- push_char(tolower(c));
- c = next_char ();
+ push_char (dtp, tolower(c));
+ c = next_char (dtp);
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
- unget_char (c);
+ unget_char (dtp, c);
/* Check that the name is in the namelist and get pointer to object.
Three error conditions exist: (i) An attempt is being made to
are present for an object. (iii) gives the same error message
as (i) */
- push_char ('\0');
+ push_char (dtp, '\0');
if (component_flag)
{
- ext_name = (char*)get_mem (strlen (root_nl->var_name)
- + (saved_string ? strlen (saved_string) : 0)
- + 1);
- strcpy (ext_name, root_nl->var_name);
- strcat (ext_name, saved_string);
- nl = find_nml_node (ext_name);
- free_mem (ext_name);
+ size_t var_len = strlen (root_nl->var_name);
+ size_t saved_len
+ = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
+ char ext_name[var_len + saved_len + 1];
+
+ memcpy (ext_name, root_nl->var_name, var_len);
+ if (dtp->u.p.saved_string)
+ memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
+ ext_name[var_len + saved_len] = '\0';
+ nl = find_nml_node (dtp, ext_name);
}
else
- nl = find_nml_node (saved_string);
+ nl = find_nml_node (dtp, dtp->u.p.saved_string);
if (nl == NULL)
{
- if (nml_read_error && prev_nl)
+ if (dtp->u.p.nml_read_error && *pprev_nl)
st_sprintf (nml_err_msg, "Bad data for namelist object %s",
- prev_nl->var_name);
+ (*pprev_nl)->var_name);
else
st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
- saved_string);
+ dtp->u.p.saved_string);
goto nml_err_ret;
}
if (c == '(' && nl->var_rank)
{
- if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
+ if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
+ parse_err_msg) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
- c = next_char ();
- unget_char (c);
+ c = next_char (dtp);
+ unget_char (dtp, c);
}
/* Now parse a derived type component. The root namelist_info address
root_nl = nl;
component_flag = 1;
- c = next_char ();
+ c = next_char (dtp);
goto get_name;
}
descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
- if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
+ if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
{
st_sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
- c = next_char ();
- unget_char (c);
+ c = next_char (dtp);
+ unget_char (dtp, c);
}
/* If a derived type touch its components and restore the root
/* According to the standard, an equal sign MUST follow an object name. The
following is possibly lax - it allows comments, blank lines and so on to
- intervene. eat_spaces (); c = next_char (); would be compliant*/
+ intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/
- free_saved ();
+ free_saved (dtp);
- eat_separator ();
- if (input_complete)
+ eat_separator (dtp);
+ if (dtp->u.p.input_complete)
return SUCCESS;
- if (at_eol)
- finish_separator ();
- if (input_complete)
+ if (dtp->u.p.at_eol)
+ finish_separator (dtp);
+ if (dtp->u.p.input_complete)
return SUCCESS;
- c = next_char ();
+ c = next_char (dtp);
if (c != '=')
{
goto nml_err_ret;
}
- if (nml_read_obj (nl, 0) == FAILURE)
+ if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
goto nml_err_ret;
return SUCCESS;
completed or there is an error. */
void
-namelist_read (void)
+namelist_read (st_parameter_dt *dtp)
{
char c;
+ jmp_buf eof_jump;
+ char nml_err_msg[100];
+ /* Pointer to the previously read object, in case attempt is made to read
+ new object name. Should this fail, error message can give previous
+ name. */
+ namelist_info *prev_nl = NULL;
- namelist_mode = 1;
- input_complete = 0;
+ dtp->u.p.namelist_mode = 1;
+ dtp->u.p.input_complete = 0;
- if (setjmp (g.eof_jump))
+ dtp->u.p.eof_jump = &eof_jump;
+ if (setjmp (eof_jump))
{
- generate_error (ERROR_END, NULL);
+ dtp->u.p.eof_jump = NULL;
+ generate_error (&dtp->common, ERROR_END, NULL);
return;
}
node names or namelist on stdout. */
find_nml_name:
- switch (c = next_char ())
+ switch (c = next_char (dtp))
{
case '$':
case '&':
break;
case '=':
- c = next_char ();
+ c = next_char (dtp);
if (c == '?')
- nml_query ('=');
+ nml_query (dtp, '=');
else
- unget_char (c);
+ unget_char (dtp, c);
goto find_nml_name;
case '?':
- nml_query ('?');
+ nml_query (dtp, '?');
default:
goto find_nml_name;
/* Match the name of the namelist. */
- nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
+ nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
- if (nml_read_error)
+ if (dtp->u.p.nml_read_error)
goto find_nml_name;
/* Ready to read namelist objects. If there is an error in input
from stdin, output the error message and continue. */
- while (!input_complete)
+ while (!dtp->u.p.input_complete)
{
- if (nml_get_obj_data () == FAILURE)
+ if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
{
- if (current_unit->unit_number != options.stdin_unit)
+ gfc_unit *u;
+
+ if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
goto nml_err_ret;
+ u = find_unit (options.stderr_unit);
st_printf ("%s\n", nml_err_msg);
- flush (find_unit (options.stderr_unit)->s);
+ if (u != NULL)
+ {
+ flush (u->s);
+ unlock_unit (u);
+ }
}
}
- free_saved ();
+
+ dtp->u.p.eof_jump = NULL;
+ free_saved (dtp);
return;
/* All namelist error calls return from here */
nml_err_ret:
- free_saved ();
- generate_error (ERROR_READ_VALUE , nml_err_msg);
+ dtp->u.p.eof_jump = NULL;
+ free_saved (dtp);
+ generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
return;
}
#include "libgfortran.h"
#include "io.h"
-st_parameter ioparm;
-iexport_data(ioparm);
-
-namelist_info *ionml;
-global_t g;
-
-
/* library_start()-- Called with a library call is entered. */
void
-library_start (void)
+library_start (st_parameter_common *cmp)
{
- if (g.in_library)
- internal_error ("Recursive library calls not allowed");
-
- /* The in_library flag indicates whether we're currently processing a
- library call. Some calls leave immediately, but READ and WRITE
- processing return control to the caller but are still considered to
- stay within the library. */
- g.in_library = 1;
+ if ((cmp->flags & IOPARM_HAS_IOSTAT) != 0)
+ *cmp->iostat = ERROR_OK;
- if (ioparm.iostat != NULL)
- *ioparm.iostat = ERROR_OK;
-
- ioparm.library_return = LIBRARY_OK;
+ cmp->flags &= ~IOPARM_LIBRETURN_MASK;
}
-/* library_end()-- Called when a library call is complete in order to
- clean up for the next call. */
-
void
-library_end (void)
+free_ionml (st_parameter_dt *dtp)
{
- int t;
namelist_info * t1, *t2;
- g.in_library = 0;
- filename = NULL;
- line = 0;
- t = ioparm.library_return;
-
/* Delete the namelist, if it exists. */
- if (ionml != NULL)
+ if (dtp->u.p.ionml != NULL)
{
- t1 = ionml;
+ t1 = dtp->u.p.ionml;
while (t1 != NULL)
{
t2 = t1;
free_mem (t2);
}
}
- ionml = NULL;
-
- memset (&ioparm, '\0', sizeof (ioparm));
- ioparm.library_return = t;
+ dtp->u.p.ionml = NULL;
}
changed. */
static void
-edit_modes (gfc_unit * u, unit_flags * flags)
+edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
/* Complain about attempts to change the unchangeable. */
if (flags->status != STATUS_UNSPECIFIED &&
u->flags.status != flags->status)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change STATUS parameter in OPEN statement");
if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change ACCESS parameter in OPEN statement");
if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change FORM parameter in OPEN statement");
- if (ioparm.recl_in != 0 && ioparm.recl_in != u->recl)
- generate_error (ERROR_BAD_OPTION,
+ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
+ && opp->recl_in != u->recl)
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change RECL parameter in OPEN statement");
if (flags->action != ACTION_UNSPECIFIED && u->flags.access != flags->access)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot change ACTION parameter in OPEN statement");
/* Status must be OLD if present. */
if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"OPEN statement must have a STATUS of OLD");
if (u->flags.form == FORM_UNFORMATTED)
{
if (flags->delim != DELIM_UNSPECIFIED)
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->blank != BLANK_UNSPECIFIED)
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
if (flags->pad != PAD_UNSPECIFIED)
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"PAD paramter conflicts with UNFORMATTED form in "
"OPEN statement");
}
- if (ioparm.library_return == LIBRARY_OK)
+ if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
{
/* Change the changeable: */
if (flags->blank != BLANK_UNSPECIFIED)
break;
seek_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&opp->common, ERROR_OS, NULL);
break;
}
+
+ unlock_unit (u);
}
/* Open an unused unit. */
-void
-new_unit (unit_flags * flags)
+gfc_unit *
+new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
{
- gfc_unit *u;
+ gfc_unit *u2;
stream *s;
char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
{
if (flags->form == FORM_UNFORMATTED)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
- goto cleanup;
+ goto fail;
}
}
{
if (flags->form == FORM_UNFORMATTED)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
- goto cleanup;
+ goto fail;
}
}
{
if (flags->form == FORM_UNFORMATTED)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"PAD paramter conflicts with UNFORMATTED form in "
"OPEN statement");
- goto cleanup;
+ goto fail;
}
}
if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&opp->common, ERROR_OPTION_CONFLICT,
"ACCESS parameter conflicts with SEQUENTIAL access in "
"OPEN statement");
- goto cleanup;
+ goto fail;
}
else
if (flags->position == POSITION_UNSPECIFIED)
/* Checks. */
- if (flags->access == ACCESS_DIRECT && ioparm.recl_in == 0)
+ if (flags->access == ACCESS_DIRECT
+ && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
{
- generate_error (ERROR_MISSING_OPTION,
+ generate_error (&opp->common, ERROR_MISSING_OPTION,
"Missing RECL parameter in OPEN statement");
- goto cleanup;
+ goto fail;
}
- if (ioparm.recl_in != 0 && ioparm.recl_in <= 0)
+ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
{
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"RECL parameter is non-positive in OPEN statement");
- goto cleanup;
+ goto fail;
}
switch (flags->status)
{
case STATUS_SCRATCH:
- if (ioparm.file == NULL)
- break;
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
+ {
+ opp->file = NULL;
+ break;
+ }
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"FILE parameter must not be present in OPEN statement");
- return;
+ goto fail;
case STATUS_OLD:
case STATUS_NEW:
case STATUS_REPLACE:
case STATUS_UNKNOWN:
- if (ioparm.file != NULL)
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
break;
- ioparm.file = tmpname;
- ioparm.file_len = sprintf(ioparm.file, "fort.%d", ioparm.unit);
+ opp->file = tmpname;
+ opp->file_len = sprintf(opp->file, "fort.%d", opp->common.unit);
break;
default:
- internal_error ("new_unit(): Bad status");
+ internal_error (&opp->common, "new_unit(): Bad status");
}
/* Make sure the file isn't already open someplace else.
Do not error if opening file preconnected to stdin, stdout, stderr. */
- u = find_file ();
- if (u != NULL
+ u2 = NULL;
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
+ u2 = find_file (opp->file, opp->file_len);
+ if (u2 != NULL
&& (options.stdin_unit < 0 || u->unit_number != options.stdin_unit)
&& (options.stdout_unit < 0 || u->unit_number != options.stdout_unit)
&& (options.stderr_unit < 0 || u->unit_number != options.stderr_unit))
{
- generate_error (ERROR_ALREADY_OPEN, NULL);
+ unlock_unit (u2);
+ generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
goto cleanup;
}
+ if (u2 != NULL)
+ unlock_unit (u2);
+
/* Open file. */
- s = open_external (flags);
+ s = open_external (opp, flags);
if (s == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&opp->common, ERROR_OS, NULL);
goto cleanup;
}
/* Create the unit structure. */
- u = get_mem (sizeof (gfc_unit) + ioparm.file_len);
- memset (u, '\0', sizeof (gfc_unit) + ioparm.file_len);
-
- u->unit_number = ioparm.unit;
+ u->file = get_mem (opp->file_len);
+ if (u->unit_number != opp->common.unit)
+ internal_error (&opp->common, "Unit number changed");
u->s = s;
u->flags = *flags;
+ u->read_bad = 0;
+ u->endfile = NO_ENDFILE;
+ u->last_record = 0;
+ u->current_record = 0;
+ u->mode = READING;
+ u->maxrec = 0;
+ u->bytes_left = 0;
if (flags->position == POSITION_APPEND)
- {
- if (sseek (u->s, file_length (u->s)) == FAILURE)
- generate_error (ERROR_OS, NULL);
- u->endfile = AT_ENDFILE;
- }
+ {
+ if (sseek (u->s, file_length (u->s)) == FAILURE)
+ generate_error (&opp->common, ERROR_OS, NULL);
+ u->endfile = AT_ENDFILE;
+ }
/* Unspecified recl ends up with a processor dependent value. */
- u->recl = (ioparm.recl_in != 0) ? ioparm.recl_in : g.max_offset;
- u->last_record = 0;
- u->current_record = 0;
+ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
+ u->recl = opp->recl_in;
+ else
+ u->recl = max_offset;
/* If the file is direct access, calculate the maximum record number
via a division now instead of letting the multiplication overflow
later. */
if (flags->access == ACCESS_DIRECT)
- u->maxrec = g.max_offset / u->recl;
-
- memmove (u->file, ioparm.file, ioparm.file_len);
- u->file_len = ioparm.file_len;
+ u->maxrec = max_offset / u->recl;
- insert_unit (u);
+ memmove (u->file, opp->file, opp->file_len);
+ u->file_len = opp->file_len;
- /* The file is now connected. Errors after this point leave the
- file connected. Curiously, the standard requires that the
+ /* Curiously, the standard requires that the
position specifier be ignored for new files so a newly connected
file starts out that the initial point. We still need to figure
out if the file is at the end or not. */
test_endfile (u);
+ if (flags->status == STATUS_SCRATCH && opp->file != NULL)
+ free_mem (opp->file);
+ return u;
+
cleanup:
/* Free memory associated with a temporary filename. */
- if (flags->status == STATUS_SCRATCH)
- free_mem (ioparm.file);
+ if (flags->status == STATUS_SCRATCH && opp->file != NULL)
+ free_mem (opp->file);
+
+ fail:
+
+ close_unit (u);
+ return NULL;
}
modes or closing what is there now and opening the new file. */
static void
-already_open (gfc_unit * u, unit_flags * flags)
+already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
- if (ioparm.file == NULL)
+ if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
{
- edit_modes (u, flags);
+ edit_modes (opp, u, flags);
return;
}
/* If the file is connected to something else, close it and open a
new unit. */
- if (!compare_file_filename (u, ioparm.file, ioparm.file_len))
+ if (!compare_file_filename (u, opp->file, opp->file_len))
{
- if (close_unit (u))
+#if !HAVE_UNLINK_OPEN_FILE
+ char *path = NULL;
+ if (u->file && u->flags.status == STATUS_SCRATCH)
{
- generate_error (ERROR_OS, "Error closing file in OPEN statement");
+ path = (char *) gfc_alloca (u->file_len + 1);
+ unpack_filename (path, u->file, u->file_len);
+ }
+#endif
+
+ if (sclose (u->s) == FAILURE)
+ {
+ unlock_unit (u);
+ generate_error (&opp->common, ERROR_OS,
+ "Error closing file in OPEN statement");
return;
}
- new_unit (flags);
+ u->s = NULL;
+ if (u->file)
+ free_mem (u->file);
+ u->file = NULL;
+ u->file_len = 0;
+
+#if !HAVE_UNLINK_OPEN_FILE
+ if (path != NULL)
+ unlink (path);
+#endif
+
+ u = new_unit (opp, u, flags);
+ if (u != NULL)
+ unlock_unit (u);
return;
}
- edit_modes (u, flags);
+ edit_modes (opp, u, flags);
}
/* Open file. */
-extern void st_open (void);
+extern void st_open (st_parameter_open *opp);
export_proto(st_open);
void
-st_open (void)
+st_open (st_parameter_open *opp)
{
unit_flags flags;
gfc_unit *u = NULL;
+ GFC_INTEGER_4 cf = opp->common.flags;
- library_start ();
+ library_start (&opp->common);
/* Decode options. */
- flags.access = (ioparm.access == NULL) ? ACCESS_UNSPECIFIED :
- find_option (ioparm.access, ioparm.access_len, access_opt,
- "Bad ACCESS parameter in OPEN statement");
+ flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
+ find_option (&opp->common, opp->access, opp->access_len,
+ access_opt, "Bad ACCESS parameter in OPEN statement");
- flags.action = (ioparm.action == NULL) ? ACTION_UNSPECIFIED :
- find_option (ioparm.action, ioparm.action_len, action_opt,
- "Bad ACTION parameter in OPEN statement");
+ flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
+ find_option (&opp->common, opp->action, opp->action_len,
+ action_opt, "Bad ACTION parameter in OPEN statement");
- flags.blank = (ioparm.blank == NULL) ? BLANK_UNSPECIFIED :
- find_option (ioparm.blank, ioparm.blank_len, blank_opt,
- "Bad BLANK parameter in OPEN statement");
+ flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
+ find_option (&opp->common, opp->blank, opp->blank_len,
+ blank_opt, "Bad BLANK parameter in OPEN statement");
- flags.delim = (ioparm.delim == NULL) ? DELIM_UNSPECIFIED :
- find_option (ioparm.delim, ioparm.delim_len, delim_opt,
- "Bad DELIM parameter in OPEN statement");
+ flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
+ find_option (&opp->common, opp->delim, opp->delim_len,
+ delim_opt, "Bad DELIM parameter in OPEN statement");
- flags.pad = (ioparm.pad == NULL) ? PAD_UNSPECIFIED :
- find_option (ioparm.pad, ioparm.pad_len, pad_opt,
- "Bad PAD parameter in OPEN statement");
+ flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
+ find_option (&opp->common, opp->pad, opp->pad_len,
+ pad_opt, "Bad PAD parameter in OPEN statement");
- flags.form = (ioparm.form == NULL) ? FORM_UNSPECIFIED :
- find_option (ioparm.form, ioparm.form_len, form_opt,
- "Bad FORM parameter in OPEN statement");
+ flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
+ find_option (&opp->common, opp->form, opp->form_len,
+ form_opt, "Bad FORM parameter in OPEN statement");
- flags.position = (ioparm.position == NULL) ? POSITION_UNSPECIFIED :
- find_option (ioparm.position, ioparm.position_len, position_opt,
- "Bad POSITION parameter in OPEN statement");
+ flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
+ find_option (&opp->common, opp->position, opp->position_len,
+ position_opt, "Bad POSITION parameter in OPEN statement");
- flags.status = (ioparm.status == NULL) ? STATUS_UNSPECIFIED :
- find_option (ioparm.status, ioparm.status_len, status_opt,
- "Bad STATUS parameter in OPEN statement");
+ flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
+ find_option (&opp->common, opp->status, opp->status_len,
+ status_opt, "Bad STATUS parameter in OPEN statement");
- if (ioparm.unit < 0)
- generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
+ if (opp->common.unit < 0)
+ generate_error (&opp->common, ERROR_BAD_OPTION,
+ "Bad unit number in OPEN statement");
if (flags.position != POSITION_UNSPECIFIED
&& flags.access == ACCESS_DIRECT)
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot use POSITION with direct access files");
if (flags.access == ACCESS_APPEND)
{
if (flags.position != POSITION_UNSPECIFIED
&& flags.position != POSITION_APPEND)
- generate_error (ERROR_BAD_OPTION, "Conflicting ACCESS and POSITION "
- "flags in OPEN statement");
-
+ generate_error (&opp->common, ERROR_BAD_OPTION,
+ "Conflicting ACCESS and POSITION flags in"
+ " OPEN statement");
+
notify_std (GFC_STD_GNU,
"Extension: APPEND as a value for ACCESS in OPEN statement");
flags.access = ACCESS_SEQUENTIAL;
if (flags.position == POSITION_UNSPECIFIED)
flags.position = POSITION_ASIS;
- if (ioparm.library_return != LIBRARY_OK)
- {
- library_end ();
- return;
- }
-
- u = find_unit (ioparm.unit);
+ if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
+ {
+ u = find_or_create_unit (opp->common.unit);
- if (u == NULL)
- new_unit (&flags);
- else
- already_open (u, &flags);
+ if (u->s == NULL)
+ {
+ u = new_unit (opp, u, &flags);
+ if (u != NULL)
+ unlock_unit (u);
+ }
+ else
+ already_open (opp, u, &flags);
+ }
library_end ();
}
-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
}
break;
default:
- internal_error ("Bad integer kind");
+ internal_error (NULL, "Bad integer kind");
}
}
value = signed_flag ? 0x7f : 0xff;
break;
default:
- internal_error ("Bad integer kind");
+ internal_error (NULL, "Bad integer kind");
}
return value;
* infinities. */
int
-convert_real (void *dest, const char *buffer, int length)
+convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
{
errno = 0;
break;
#endif
default:
- internal_error ("Unsupported real kind during IO");
+ internal_error (&dtp->common, "Unsupported real kind during IO");
}
if (errno != 0 && errno != EINVAL)
{
- generate_error (ERROR_READ_VALUE,
+ generate_error (&dtp->common, ERROR_READ_VALUE,
"Range error during floating point read");
return 1;
}
/* read_l()-- Read a logical value */
void
-read_l (fnode * f, char *dest, int length)
+read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
char *p;
int w;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
break;
default:
bad:
- generate_error (ERROR_READ_VALUE, "Bad value on logical read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value on logical read");
break;
}
}
/* read_a()-- Read a character record. This one is pretty easy. */
void
-read_a (fnode * f, char *p, int length)
+read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
{
char *source;
int w, m, n;
if (w == -1) /* '(A)' edit descriptor */
w = length;
- source = read_block (&w);
+ source = read_block (dtp, &w);
if (source == NULL)
return;
if (w > length)
static char
-next_char (char **p, int *w)
+next_char (st_parameter_dt *dtp, char **p, int *w)
{
char c, *q;
if (c != ' ')
return c;
- if (g.blank_status != BLANK_UNSPECIFIED)
+ if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
return ' '; /* return a blank to signal a null */
/* At this point, the rest of the field has to be trailing blanks */
* signed values. */
void
-read_decimal (fnode * f, char *dest, int length)
+read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
GFC_INTEGER_LARGEST v;
char c, *p;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
for (;;)
{
- c = next_char (&p, &w);
+ c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
- if (g.blank_status == BLANK_NULL) continue;
- if (g.blank_status == BLANK_ZERO) c = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL) continue;
+ if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
if (c < '0' || c > '9')
return;
bad:
- generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during integer read");
return;
overflow:
- generate_error (ERROR_READ_OVERFLOW,
+ generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
* the top bit is set, the value will be incorrect. */
void
-read_radix (fnode * f, char *dest, int length, int radix)
+read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
+ int radix)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_r;
GFC_INTEGER_LARGEST v;
char c, *p;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
for (;;)
{
- c = next_char (&p, &w);
+ c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
- if (g.blank_status == BLANK_NULL) continue;
- if (g.blank_status == BLANK_ZERO) c = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL) continue;
+ if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
switch (radix)
return;
bad:
- generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during integer read");
return;
overflow:
- generate_error (ERROR_READ_OVERFLOW,
+ generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
the input. */
void
-read_f (fnode * f, char *dest, int length)
+read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
int w, seen_dp, exponent;
int exponent_sign, val_sign;
int i;
char *p, *buffer;
char *digits;
+ char scratch[SCRATCH_SIZE];
val_sign = 1;
seen_dp = 0;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
}
/* No exponent has been seen, so we use the current scale factor */
- exponent = -g.scale_factor;
+ exponent = -dtp->u.p.scale_factor;
goto done;
bad_float:
- generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during floating point read");
return;
/* The value read is zero */
#endif
default:
- internal_error ("Unsupported real kind during IO");
+ internal_error (&dtp->common, "Unsupported real kind during IO");
}
return;
p++;
w--;
- if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
+ if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
{
while (w > 0 && isdigit (*p))
{
{
if (*p == ' ')
{
- if (g.blank_status == BLANK_ZERO) *p = '0';
- if (g.blank_status == BLANK_NULL)
+ if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL)
{
p++;
w--;
{
if (*digits == ' ')
{
- if (g.blank_status == BLANK_ZERO) *digits = '0';
- if (g.blank_status == BLANK_NULL)
+ if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL)
{
digits++;
continue;
sprintf (p, "%d", exponent);
/* Do the actual conversion. */
- convert_real (dest, buffer, length);
+ convert_real (dtp, dest, buffer, length);
if (buffer != scratch)
free_mem (buffer);
* and never look at it. */
void
-read_x (int n)
+read_x (st_parameter_dt *dtp, int n)
{
- if ((current_unit->flags.pad == PAD_NO || is_internal_unit ())
- && current_unit->bytes_left < n)
- n = current_unit->bytes_left;
+ if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
+ && dtp->u.p.current_unit->bytes_left < n)
+ n = dtp->u.p.current_unit->bytes_left;
if (n > 0)
- read_block (&n);
+ read_block (dtp, &n);
}
st_write(), an error inhibits any data from actually being
transferred. */
-extern void transfer_integer (void *, int);
+extern void transfer_integer (st_parameter_dt *, void *, int);
export_proto(transfer_integer);
-extern void transfer_real (void *, int);
+extern void transfer_real (st_parameter_dt *, void *, int);
export_proto(transfer_real);
-extern void transfer_logical (void *, int);
+extern void transfer_logical (st_parameter_dt *, void *, int);
export_proto(transfer_logical);
-extern void transfer_character (void *, int);
+extern void transfer_character (st_parameter_dt *, void *, int);
export_proto(transfer_character);
-extern void transfer_complex (void *, int);
+extern void transfer_complex (st_parameter_dt *, void *, int);
export_proto(transfer_complex);
-extern void transfer_array (gfc_array_char *, int, gfc_charlen_type);
+extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
+ gfc_charlen_type);
export_proto(transfer_array);
-gfc_unit *current_unit = NULL;
-static int sf_seen_eor = 0;
-static int eor_condition = 0;
-
-/* Maximum righthand column written to. */
-static int max_pos;
-/* Number of skips + spaces to be done for T and X-editing. */
-static int skips;
-/* Number of spaces to be done for T and X-editing. */
-static int pending_spaces;
-
-char scratch[SCRATCH_SIZE];
-static char *line_buffer = NULL;
-
-static unit_advance advance_status;
-
static const st_option advance_opt[] = {
{"yes", ADVANCE_YES},
{"no", ADVANCE_NO},
};
-static void (*transfer) (bt, void *, int, size_t, size_t);
-
-
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT
static file_mode
-current_mode (void)
+current_mode (st_parameter_dt *dtp)
{
file_mode m;
- if (current_unit->flags.access == ACCESS_DIRECT)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- m = current_unit->flags.form == FORM_FORMATTED ?
+ m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_DIRECT : UNFORMATTED_DIRECT;
}
else
{
- m = current_unit->flags.form == FORM_FORMATTED ?
+ m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
}
heap. Hopefully this won't happen very often. */
static char *
-read_sf (int *length)
+read_sf (st_parameter_dt *dtp, int *length)
{
- static char data[SCRATCH_SIZE];
char *base, *p, *q;
int n, readlen;
if (*length > SCRATCH_SIZE)
- p = base = line_buffer = get_mem (*length);
- else
- p = base = data;
+ dtp->u.p.line_buffer = get_mem (*length);
+ p = base = dtp->u.p.line_buffer;
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
- if (sf_seen_eor)
+ if (dtp->u.p.sf_seen_eor)
{
*length = 0;
return base;
do
{
- if (is_internal_unit())
+ if (is_internal_unit (dtp))
{
/* readlen may be modified inside salloc_r if
- is_internal_unit() is true. */
+ is_internal_unit (dtp) is true. */
readlen = 1;
}
- q = salloc_r (current_unit->s, &readlen);
+ q = salloc_r (dtp->u.p.current_unit->s, &readlen);
if (q == NULL)
break;
EOR below. */
if (readlen < 1 && n == 0)
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return NULL;
}
/* If we see an EOR during non-advancing I/O, we need to skip
the rest of the I/O statement. Set the corresponding flag. */
- if (advance_status == ADVANCE_NO || g.seen_dollar)
- eor_condition = 1;
+ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
+ dtp->u.p.eor_condition = 1;
/* Without padding, terminate the I/O statement without assigning
the value. With padding, the value still needs to be assigned,
so we can just continue with a short read. */
- if (current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
return NULL;
}
*length = n;
- sf_seen_eor = 1;
+ dtp->u.p.sf_seen_eor = 1;
break;
}
n++;
*p++ = *q;
- sf_seen_eor = 0;
+ dtp->u.p.sf_seen_eor = 0;
}
while (n < *length);
- current_unit->bytes_left -= *length;
+ dtp->u.p.current_unit->bytes_left -= *length;
- if (ioparm.size != NULL)
- *ioparm.size += *length;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += *length;
return base;
}
short reads. */
void *
-read_block (int *length)
+read_block (st_parameter_dt *dtp, int *length)
{
char *source;
int nread;
- if (current_unit->bytes_left < *length)
+ if (dtp->u.p.current_unit->bytes_left < *length)
{
- if (current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
- generate_error (ERROR_EOR, NULL); /* Not enough data left. */
+ generate_error (&dtp->common, ERROR_EOR, NULL);
+ /* Not enough data left. */
return NULL;
}
- *length = current_unit->bytes_left;
+ *length = dtp->u.p.current_unit->bytes_left;
}
- if (current_unit->flags.form == FORM_FORMATTED &&
- current_unit->flags.access == ACCESS_SEQUENTIAL)
- return read_sf (length); /* Special case. */
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+ dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ return read_sf (dtp, length); /* Special case. */
- current_unit->bytes_left -= *length;
+ dtp->u.p.current_unit->bytes_left -= *length;
nread = *length;
- source = salloc_r (current_unit->s, &nread);
+ source = salloc_r (dtp->u.p.current_unit->s, &nread);
- if (ioparm.size != NULL)
- *ioparm.size += nread;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += nread;
if (nread != *length)
{ /* Short read, this shouldn't happen. */
- if (current_unit->flags.pad == PAD_YES)
+ if (dtp->u.p.current_unit->flags.pad == PAD_YES)
*length = nread;
else
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
source = NULL;
}
}
/* Reads a block directly into application data space. */
static void
-read_block_direct (void * buf, size_t * nbytes)
+read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
int *length;
void *data;
size_t nread;
- if (current_unit->bytes_left < *nbytes)
+ if (dtp->u.p.current_unit->bytes_left < *nbytes)
{
- if (current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
- generate_error (ERROR_EOR, NULL); /* Not enough data left. */
+ /* Not enough data left. */
+ generate_error (&dtp->common, ERROR_EOR, NULL);
return;
}
- *nbytes = current_unit->bytes_left;
+ *nbytes = dtp->u.p.current_unit->bytes_left;
}
- if (current_unit->flags.form == FORM_FORMATTED &&
- current_unit->flags.access == ACCESS_SEQUENTIAL)
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+ dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
{
- length = (int*) nbytes;
- data = read_sf (length); /* Special case. */
+ length = (int *) nbytes;
+ data = read_sf (dtp, length); /* Special case. */
memcpy (buf, data, (size_t) *length);
return;
}
- current_unit->bytes_left -= *nbytes;
+ dtp->u.p.current_unit->bytes_left -= *nbytes;
nread = *nbytes;
- if (sread (current_unit->s, buf, &nread) != 0)
+ if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
- if (ioparm.size != NULL)
- *ioparm.size += (GFC_INTEGER_4) nread;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += (GFC_INTEGER_4) nread;
if (nread != *nbytes)
{ /* Short read, e.g. if we hit EOF. */
- if (current_unit->flags.pad == PAD_YES)
+ if (dtp->u.p.current_unit->flags.pad == PAD_YES)
{
memset (((char *) buf) + nread, ' ', *nbytes - nread);
*nbytes = nread;
}
else
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
}
}
fill in. Returns NULL on error. */
void *
-write_block (int length)
+write_block (st_parameter_dt *dtp, int length)
{
char *dest;
- if (current_unit->bytes_left < length)
+ if (dtp->u.p.current_unit->bytes_left < length)
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
return NULL;
}
- current_unit->bytes_left -= (gfc_offset)length;
- dest = salloc_w (current_unit->s, &length);
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
+ dest = salloc_w (dtp->u.p.current_unit->s, &length);
if (dest == NULL)
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return NULL;
}
- if (ioparm.size != NULL)
- *ioparm.size += length;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += length;
return dest;
}
buffer. */
static void
-write_block_direct (void * buf, size_t * nbytes)
+write_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
- if (current_unit->bytes_left < *nbytes)
- generate_error (ERROR_EOR, NULL);
+ if (dtp->u.p.current_unit->bytes_left < *nbytes)
+ generate_error (&dtp->common, ERROR_EOR, NULL);
- current_unit->bytes_left -= (gfc_offset) *nbytes;
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
- if (swrite (current_unit->s, buf, nbytes) != 0)
- generate_error (ERROR_OS, NULL);
+ if (swrite (dtp->u.p.current_unit->s, buf, nbytes) != 0)
+ generate_error (&dtp->common, ERROR_OS, NULL);
- if (ioparm.size != NULL)
- *ioparm.size += (GFC_INTEGER_4) *nbytes;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size += (GFC_INTEGER_4) *nbytes;
}
/* Master function for unformatted reads. */
static void
-unformatted_read (bt type __attribute__((unused)), void *dest,
- int kind __attribute__((unused)),
- size_t size, size_t nelems)
+unformatted_read (st_parameter_dt *dtp, bt type __attribute__((unused)),
+ void *dest, int kind __attribute__((unused)),
+ size_t size, size_t nelems)
{
size *= nelems;
- read_block_direct (dest, &size);
+ read_block_direct (dtp, dest, &size);
}
/* Master function for unformatted writes. */
static void
-unformatted_write (bt type __attribute__((unused)), void *source,
- int kind __attribute__((unused)),
- size_t size, size_t nelems)
+unformatted_write (st_parameter_dt *dtp, bt type __attribute__((unused)),
+ void *source, int kind __attribute__((unused)),
+ size_t size, size_t nelems)
{
size *= nelems;
- write_block_direct (source, &size);
+ write_block_direct (dtp, source, &size);
}
p = "COMPLEX";
break;
default:
- internal_error ("type_name(): Bad type");
+ internal_error (NULL, "type_name(): Bad type");
}
return p;
in it. The length in the format node is the true length. */
static void
-write_constant_string (fnode * f)
+write_constant_string (st_parameter_dt *dtp, const fnode *f)
{
char c, delimiter, *p, *q;
int length;
if (length == 0)
return;
- p = write_block (length);
+ p = write_block (dtp, length);
if (p == NULL)
return;
nonzero if something went wrong. */
static int
-require_type (bt expected, bt actual, fnode * f)
+require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
{
char buffer[100];
return 0;
st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
- type_name (expected), g.item_count, type_name (actual));
+ type_name (expected), dtp->u.p.item_count, type_name (actual));
- format_error (f, buffer);
+ format_error (dtp, f, buffer);
return 1;
}
of the next element, then comes back here to process it. */
static void
-formatted_transfer_scalar (bt type, void *p, int len, size_t size)
+formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
+ size_t size)
{
+ char scratch[SCRATCH_SIZE];
int pos, bytes_used;
- fnode *f;
+ const fnode *f;
format_token t;
int n;
int consume_data_flag;
/* If there's an EOR condition, we simulate finalizing the transfer
by doing nothing. */
- if (eor_condition)
+ if (dtp->u.p.eor_condition)
return;
+ dtp->u.p.line_buffer = scratch;
for (;;)
{
/* If reversion has occurred and there is another real data item,
then we have to move to the next record. */
- if (g.reversion_flag && n > 0)
+ if (dtp->u.p.reversion_flag && n > 0)
{
- g.reversion_flag = 0;
- next_record (0);
+ dtp->u.p.reversion_flag = 0;
+ next_record (dtp, 0);
}
consume_data_flag = 1 ;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
break;
- f = next_format ();
+ f = next_format (dtp);
if (f == NULL)
return; /* No data descriptors left (already raised). */
until a data producing format to suppress trailing spaces. */
t = f->format;
- if (g.mode == WRITING && skips != 0
+ if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
|| t == FMT_L || t == FMT_A || t == FMT_D))
|| t == FMT_STRING))
{
- if (skips > 0)
+ if (dtp->u.p.skips > 0)
{
- write_x (skips, pending_spaces);
- max_pos = (int)(current_unit->recl - current_unit->bytes_left);
+ write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+ dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left);
}
- if (skips < 0)
+ if (dtp->u.p.skips < 0)
{
- move_pos_offset (current_unit->s, skips);
- current_unit->bytes_left -= (gfc_offset)skips;
+ move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
}
- skips = pending_spaces = 0;
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
- bytes_used = (int)(current_unit->recl - current_unit->bytes_left);
+ bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
switch (t)
{
case FMT_I:
if (n == 0)
goto need_data;
- if (require_type (BT_INTEGER, type, f))
+ if (require_type (dtp, BT_INTEGER, type, f))
return;
- if (g.mode == READING)
- read_decimal (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_decimal (dtp, f, p, len);
else
- write_i (f, p, len);
+ write_i (dtp, f, p, len);
break;
case FMT_B:
if (n == 0)
goto need_data;
- if (require_type (BT_INTEGER, type, f))
+ if (require_type (dtp, BT_INTEGER, type, f))
return;
- if (g.mode == READING)
- read_radix (f, p, len, 2);
+ if (dtp->u.p.mode == READING)
+ read_radix (dtp, f, p, len, 2);
else
- write_b (f, p, len);
+ write_b (dtp, f, p, len);
break;
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_radix (f, p, len, 8);
+ if (dtp->u.p.mode == READING)
+ read_radix (dtp, f, p, len, 8);
else
- write_o (f, p, len);
+ write_o (dtp, f, p, len);
break;
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_radix (f, p, len, 16);
+ if (dtp->u.p.mode == READING)
+ read_radix (dtp, f, p, len, 16);
else
- write_z (f, p, len);
+ write_z (dtp, f, p, len);
break;
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_a (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_a (dtp, f, p, len);
else
- write_a (f, p, len);
+ write_a (dtp, f, p, len);
break;
if (n == 0)
goto need_data;
- if (g.mode == READING)
- read_l (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_l (dtp, f, p, len);
else
- write_l (f, p, len);
+ write_l (dtp, f, p, len);
break;
case FMT_D:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_d (f, p, len);
+ write_d (dtp, f, p, len);
break;
case FMT_E:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_e (f, p, len);
+ write_e (dtp, f, p, len);
break;
case FMT_EN:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_en (f, p, len);
+ write_en (dtp, f, p, len);
break;
case FMT_ES:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_es (f, p, len);
+ write_es (dtp, f, p, len);
break;
case FMT_F:
if (n == 0)
goto need_data;
- if (require_type (BT_REAL, type, f))
+ if (require_type (dtp, BT_REAL, type, f))
return;
- if (g.mode == READING)
- read_f (f, p, len);
+ if (dtp->u.p.mode == READING)
+ read_f (dtp, f, p, len);
else
- write_f (f, p, len);
+ write_f (dtp, f, p, len);
break;
case FMT_G:
if (n == 0)
goto need_data;
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
switch (type)
{
case BT_INTEGER:
- read_decimal (f, p, len);
+ read_decimal (dtp, f, p, len);
break;
case BT_LOGICAL:
- read_l (f, p, len);
+ read_l (dtp, f, p, len);
break;
case BT_CHARACTER:
- read_a (f, p, len);
+ read_a (dtp, f, p, len);
break;
case BT_REAL:
- read_f (f, p, len);
+ read_f (dtp, f, p, len);
break;
default:
goto bad_type;
switch (type)
{
case BT_INTEGER:
- write_i (f, p, len);
+ write_i (dtp, f, p, len);
break;
case BT_LOGICAL:
- write_l (f, p, len);
+ write_l (dtp, f, p, len);
break;
case BT_CHARACTER:
- write_a (f, p, len);
+ write_a (dtp, f, p, len);
break;
case BT_REAL:
- write_d (f, p, len);
+ write_d (dtp, f, p, len);
break;
default:
bad_type:
- internal_error ("formatted_transfer(): Bad type");
+ internal_error (&dtp->common,
+ "formatted_transfer(): Bad type");
}
break;
case FMT_STRING:
consume_data_flag = 0 ;
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
{
- format_error (f, "Constant string in input format");
+ format_error (dtp, f, "Constant string in input format");
return;
}
- write_constant_string (f);
+ write_constant_string (dtp, f);
break;
/* Format codes that don't transfer data. */
case FMT_TR:
consume_data_flag = 0 ;
- pos = bytes_used + f->u.n + skips;
- skips = f->u.n + skips;
- pending_spaces = pos - max_pos;
+ pos = bytes_used + f->u.n + dtp->u.p.skips;
+ dtp->u.p.skips = f->u.n + dtp->u.p.skips;
+ dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
/* Writes occur just before the switch on f->format, above, so
that trailing blanks are suppressed, unless we are doing a
non-advancing write in which case we want to output the blanks
now. */
- if (g.mode == WRITING && advance_status == ADVANCE_NO)
+ if (dtp->u.p.mode == WRITING
+ && dtp->u.p.advance_status == ADVANCE_NO)
{
- write_x (skips, pending_spaces);
- skips = pending_spaces = 0;
+ write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
- if (g.mode == READING)
- read_x (f->u.n);
+ if (dtp->u.p.mode == READING)
+ read_x (dtp, f->u.n);
break;
bring us back again. */
pos = pos < 0 ? 0 : pos;
- skips = skips + pos - bytes_used;
- pending_spaces = pending_spaces + pos - max_pos;
+ dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+ + pos - dtp->u.p.max_pos;
- if (skips == 0)
+ if (dtp->u.p.skips == 0)
break;
/* Writes occur just before the switch on f->format, above, so that
trailing blanks are suppressed. */
- if (g.mode == READING)
+ if (dtp->u.p.mode == READING)
{
/* Adjust everything for end-of-record condition */
- if (sf_seen_eor && !is_internal_unit())
+ if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
{
- current_unit->bytes_left--;
+ dtp->u.p.current_unit->bytes_left--;
bytes_used = pos;
- sf_seen_eor = 0;
- skips--;
+ dtp->u.p.sf_seen_eor = 0;
+ dtp->u.p.skips--;
}
- if (skips < 0)
+ if (dtp->u.p.skips < 0)
{
- move_pos_offset (current_unit->s, skips);
- current_unit->bytes_left -= (gfc_offset)skips;
- skips = pending_spaces = 0;
+ move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ dtp->u.p.current_unit->bytes_left
+ -= (gfc_offset) dtp->u.p.skips;
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
else
- read_x (skips);
+ read_x (dtp, dtp->u.p.skips);
}
break;
case FMT_S:
consume_data_flag = 0 ;
- g.sign_status = SIGN_S;
+ dtp->u.p.sign_status = SIGN_S;
break;
case FMT_SS:
consume_data_flag = 0 ;
- g.sign_status = SIGN_SS;
+ dtp->u.p.sign_status = SIGN_SS;
break;
case FMT_SP:
consume_data_flag = 0 ;
- g.sign_status = SIGN_SP;
+ dtp->u.p.sign_status = SIGN_SP;
break;
case FMT_BN:
consume_data_flag = 0 ;
- g.blank_status = BLANK_NULL;
+ dtp->u.p.blank_status = BLANK_NULL;
break;
case FMT_BZ:
consume_data_flag = 0 ;
- g.blank_status = BLANK_ZERO;
+ dtp->u.p.blank_status = BLANK_ZERO;
break;
case FMT_P:
consume_data_flag = 0 ;
- g.scale_factor = f->u.k;
+ dtp->u.p.scale_factor = f->u.k;
break;
case FMT_DOLLAR:
consume_data_flag = 0 ;
- g.seen_dollar = 1;
+ dtp->u.p.seen_dollar = 1;
break;
case FMT_SLASH:
consume_data_flag = 0 ;
- skips = pending_spaces = 0;
- next_record (0);
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+ next_record (dtp, 0);
break;
case FMT_COLON:
break;
default:
- internal_error ("Bad format node");
+ internal_error (&dtp->common, "Bad format node");
}
/* Free a buffer that we had to allocate during a sequential
formatted read of a block that was larger than the static
buffer. */
- if (line_buffer != NULL)
+ if (dtp->u.p.line_buffer != scratch)
{
- free_mem (line_buffer);
- line_buffer = NULL;
+ free_mem (dtp->u.p.line_buffer);
+ dtp->u.p.line_buffer = scratch;
}
/* Adjust the item count and data pointer. */
p = ((char *) p) + size;
}
- if (g.mode == READING)
- skips = 0;
+ if (dtp->u.p.mode == READING)
+ dtp->u.p.skips = 0;
- pos = (int)(current_unit->recl - current_unit->bytes_left);
- max_pos = (max_pos > pos) ? max_pos : pos;
+ pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+ dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
}
push the current format node back onto the input, then return and
let the user program call us back with the data. */
need_data:
- unget_format (f);
+ unget_format (dtp, f);
}
static void
-formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems)
+formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size, size_t nelems)
{
size_t elem;
char *tmp;
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
- g.item_count++;
- formatted_transfer_scalar (type, tmp + size*elem, kind, size);
+ dtp->u.p.item_count++;
+ formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
}
}
share a common enum with the compiler. */
void
-transfer_integer (void *p, int kind)
+transfer_integer (st_parameter_dt *dtp, void *p, int kind)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- transfer (BT_INTEGER, p, kind, kind, 1);
+ dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
}
void
-transfer_real (void *p, int kind)
+transfer_real (st_parameter_dt *dtp, void *p, int kind)
{
size_t size;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_real_kind (kind);
- transfer (BT_REAL, p, kind, size, 1);
+ dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
}
void
-transfer_logical (void *p, int kind)
+transfer_logical (st_parameter_dt *dtp, void *p, int kind)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- transfer (BT_LOGICAL, p, kind, kind, 1);
+ dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
}
void
-transfer_character (void *p, int len)
+transfer_character (st_parameter_dt *dtp, void *p, int len)
{
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
/* Currently we support only 1 byte chars, and the library is a bit
confused of character kind vs. length, so we kludge it by setting
kind = length. */
- transfer (BT_CHARACTER, p, len, len, 1);
+ dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
}
void
-transfer_complex (void *p, int kind)
+transfer_complex (st_parameter_dt *dtp, void *p, int kind)
{
size_t size;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_complex_kind (kind);
- transfer (BT_COMPLEX, p, kind, size, 1);
+ dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
}
void
-transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen)
+transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
char *data;
bt iotype;
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
type = GFC_DESCRIPTOR_TYPE (desc);
kind = charlen;
break;
case GFC_DTYPE_DERIVED:
- internal_error ("Derived type I/O should have been handled via the frontend.");
+ internal_error (&dtp->common,
+ "Derived type I/O should have been handled via the frontend.");
break;
default:
- internal_error ("transfer_array(): Bad type");
+ internal_error (&dtp->common, "transfer_array(): Bad type");
}
if (desc->dim[0].stride == 0)
while (data)
{
- transfer (iotype, data, kind, size, tsize);
+ dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
data += stride0 * size * tsize;
count[0] += tsize;
n = 0;
/* Preposition a sequential unformatted file while reading. */
static void
-us_read (void)
+us_read (st_parameter_dt *dtp)
{
char *p;
int n;
gfc_offset i;
n = sizeof (gfc_offset);
- p = salloc_r (current_unit->s, &n);
+ p = salloc_r (dtp->u.p.current_unit->s, &n);
if (n == 0)
return; /* end of file */
if (p == NULL || n != sizeof (gfc_offset))
{
- generate_error (ERROR_BAD_US, NULL);
+ generate_error (&dtp->common, ERROR_BAD_US, NULL);
return;
}
memcpy (&i, p, sizeof (gfc_offset));
- current_unit->bytes_left = i;
+ dtp->u.p.current_unit->bytes_left = i;
}
amount to writing a bogus length that will be filled in later. */
static void
-us_write (void)
+us_write (st_parameter_dt *dtp)
{
char *p;
int length;
length = sizeof (gfc_offset);
- p = salloc_w (current_unit->s, &length);
+ p = salloc_w (dtp->u.p.current_unit->s, &length);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
memset (p, '\0', sizeof (gfc_offset)); /* Bogus value for now. */
- if (sfree (current_unit->s) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
+ generate_error (&dtp->common, ERROR_OS, NULL);
/* For sequential unformatted, we write until we have more bytes than
can fit in the record markers. If disk space runs out first, it will
error on the write. */
- current_unit->recl = g.max_offset;
+ dtp->u.p.current_unit->recl = max_offset;
- current_unit->bytes_left = current_unit->recl;
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
record. */
static void
-pre_position (void)
+pre_position (st_parameter_dt *dtp)
{
- if (current_unit->current_record)
+ if (dtp->u.p.current_unit->current_record)
return; /* Already positioned. */
- switch (current_mode ())
+ switch (current_mode (dtp))
{
case UNFORMATTED_SEQUENTIAL:
- if (g.mode == READING)
- us_read ();
+ if (dtp->u.p.mode == READING)
+ us_read (dtp);
else
- us_write ();
+ us_write (dtp);
break;
case FORMATTED_SEQUENTIAL:
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
- current_unit->bytes_left = current_unit->recl;
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
break;
}
- current_unit->current_record = 1;
+ dtp->u.p.current_unit->current_record = 1;
}
both reading and writing. */
static void
-data_transfer_init (int read_flag)
+data_transfer_init (st_parameter_dt *dtp, int read_flag)
{
unit_flags u_flags; /* Used for creating a unit if needed. */
+ GFC_INTEGER_4 cf = dtp->common.flags;
+ namelist_info *ionml;
- g.mode = read_flag ? READING : WRITING;
+ ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
+ memset (&dtp->u.p, 0, sizeof (dtp->u.p));
+ dtp->u.p.ionml = ionml;
+ dtp->u.p.mode = read_flag ? READING : WRITING;
- if (ioparm.size != NULL)
- *ioparm.size = 0; /* Initialize the count. */
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size = 0; /* Initialize the count. */
- current_unit = get_unit (read_flag);
- if (current_unit == NULL)
+ dtp->u.p.current_unit = get_unit (dtp, 1);
+ if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
- if (ioparm.unit < 0)
+ st_parameter_open opp;
+ if (dtp->common.unit < 0)
{
- generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
- library_end ();
+ close_unit (dtp->u.p.current_unit);
+ dtp->u.p.current_unit = NULL;
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Bad unit number in OPEN statement");
return;
}
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
/* Is it unformatted? */
- if (ioparm.format == NULL && !ioparm.list_format)
+ if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
u_flags.form = FORM_UNFORMATTED;
else
u_flags.form = FORM_UNSPECIFIED;
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
u_flags.status = STATUS_UNKNOWN;
- new_unit(&u_flags);
- current_unit = get_unit (read_flag);
+ opp.common = dtp->common;
+ opp.common.flags &= IOPARM_COMMON_MASK;
+ dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
+ dtp->common.flags &= ~IOPARM_COMMON_MASK;
+ dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
+ if (dtp->u.p.current_unit == NULL)
+ return;
}
- if (current_unit == NULL)
- return;
-
/* Check the action. */
- if (read_flag && current_unit->flags.action == ACTION_WRITE)
- generate_error (ERROR_BAD_ACTION,
+ if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
+ generate_error (&dtp->common, ERROR_BAD_ACTION,
"Cannot read from file opened for WRITE");
- if (!read_flag && current_unit->flags.action == ACTION_READ)
- generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
+ if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
+ generate_error (&dtp->common, ERROR_BAD_ACTION,
+ "Cannot write to file opened for READ");
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
+ dtp->u.p.first_item = 1;
+
/* Check the format. */
- if (ioparm.format)
- parse_format ();
+ if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
+ parse_format (dtp);
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- if (current_unit->flags.form == FORM_UNFORMATTED
- && (ioparm.format != NULL || ioparm.list_format))
- generate_error (ERROR_OPTION_CONFLICT,
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
+ && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
+ != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Format present for UNFORMATTED data transfer");
- if (ioparm.namelist_name != NULL && ionml != NULL)
+ if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
{
- if(ioparm.format != NULL)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"A format cannot be specified with a namelist");
}
- else if (current_unit->flags.form == FORM_FORMATTED &&
- ioparm.format == NULL && !ioparm.list_format)
- generate_error (ERROR_OPTION_CONFLICT,
+ else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+ !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Missing format for FORMATTED data transfer");
- if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
- generate_error (ERROR_OPTION_CONFLICT,
+ if (is_internal_unit (dtp)
+ && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Internal file cannot be accessed by UNFORMATTED data transfer");
/* Check the record number. */
- if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
+ && (cf & IOPARM_DT_HAS_REC) == 0)
{
- generate_error (ERROR_MISSING_OPTION,
+ generate_error (&dtp->common, ERROR_MISSING_OPTION,
"Direct access data transfer requires record number");
return;
}
- if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+ && (cf & IOPARM_DT_HAS_REC) != 0)
{
- generate_error (ERROR_OPTION_CONFLICT,
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Record number not allowed for sequential access data transfer");
return;
}
/* Process the ADVANCE option. */
- advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
- find_option (ioparm.advance, ioparm.advance_len, advance_opt,
- "Bad ADVANCE parameter in data transfer statement");
+ dtp->u.p.advance_status
+ = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
+ find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
+ "Bad ADVANCE parameter in data transfer statement");
- if (advance_status != ADVANCE_UNSPECIFIED)
+ if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
{
- if (current_unit->flags.access == ACCESS_DIRECT)
- generate_error (ERROR_OPTION_CONFLICT,
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with sequential access");
- if (is_internal_unit ())
- generate_error (ERROR_OPTION_CONFLICT,
+ if (is_internal_unit (dtp))
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with internal file");
- if (ioparm.format == NULL || ioparm.list_format)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
+ != IOPARM_DT_HAS_FORMAT)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification requires an explicit format");
}
if (read_flag)
{
- if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
- generate_error (ERROR_MISSING_OPTION,
+ if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+ generate_error (&dtp->common, ERROR_MISSING_OPTION,
"EOR specification requires an ADVANCE specification of NO");
- if (ioparm.size != NULL && advance_status != ADVANCE_NO)
- generate_error (ERROR_MISSING_OPTION,
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+ generate_error (&dtp->common, ERROR_MISSING_OPTION,
"SIZE specification requires an ADVANCE specification of NO");
}
else
{ /* Write constraints. */
- if (ioparm.end != 0)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_END) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"END specification cannot appear in a write statement");
- if (ioparm.eor != 0)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_EOR) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"EOR specification cannot appear in a write statement");
- if (ioparm.size != 0)
- generate_error (ERROR_OPTION_CONFLICT,
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+ generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"SIZE specification cannot appear in a write statement");
}
- if (advance_status == ADVANCE_UNSPECIFIED)
- advance_status = ADVANCE_YES;
- if (ioparm.library_return != LIBRARY_OK)
+ if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
+ dtp->u.p.advance_status = ADVANCE_YES;
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
/* Sanity checks on the record number. */
- if (ioparm.rec)
+ if ((cf & IOPARM_DT_HAS_REC) != 0)
{
- if (ioparm.rec <= 0)
+ if (dtp->rec <= 0)
{
- generate_error (ERROR_BAD_OPTION, "Record number must be positive");
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Record number must be positive");
return;
}
- if (ioparm.rec >= current_unit->maxrec)
+ if (dtp->rec >= dtp->u.p.current_unit->maxrec)
{
- generate_error (ERROR_BAD_OPTION, "Record number too large");
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Record number too large");
return;
}
/* Check to see if we might be reading what we wrote before */
- if (g.mode == READING && current_unit->mode == WRITING)
- flush(current_unit->s);
+ if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode == WRITING)
+ flush(dtp->u.p.current_unit->s);
/* Check whether the record exists to be read. Only
a partial record needs to exist. */
- if (g.mode == READING && (ioparm.rec -1)
- * current_unit->recl >= file_length (current_unit->s))
+ if (dtp->u.p.mode == READING && (dtp->rec -1)
+ * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
{
- generate_error (ERROR_BAD_OPTION, "Non-existing record number");
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
+ "Non-existing record number");
return;
}
/* Position the file. */
- if (sseek (current_unit->s,
- (ioparm.rec - 1) * current_unit->recl) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s,
+ (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
}
/* Overwriting an existing sequential file ?
it is always safe to truncate the file on the first write */
- if (g.mode == WRITING
- && current_unit->flags.access == ACCESS_SEQUENTIAL
- && current_unit->last_record == 0 && !is_preconnected(current_unit->s))
- struncate(current_unit->s);
+ if (dtp->u.p.mode == WRITING
+ && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+ && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s))
+ struncate(dtp->u.p.current_unit->s);
/* Bugware for badly written mixed C-Fortran I/O. */
- flush_if_preconnected(current_unit->s);
+ flush_if_preconnected(dtp->u.p.current_unit->s);
- current_unit->mode = g.mode;
+ dtp->u.p.current_unit->mode = dtp->u.p.mode;
/* Set the initial value of flags. */
- g.blank_status = current_unit->flags.blank;
- g.sign_status = SIGN_S;
- g.scale_factor = 0;
- g.seen_dollar = 0;
- g.first_item = 1;
- g.item_count = 0;
- sf_seen_eor = 0;
- eor_condition = 0;
+ dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+ dtp->u.p.sign_status = SIGN_S;
- pre_position ();
+ pre_position (dtp);
/* Set up the subroutine that will handle the transfers. */
if (read_flag)
{
- if (current_unit->flags.form == FORM_UNFORMATTED)
- transfer = unformatted_read;
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_read;
else
{
- if (ioparm.list_format)
- {
- transfer = list_formatted_read;
- init_at_eol();
- }
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_read;
else
- transfer = formatted_transfer;
+ dtp->u.p.transfer = formatted_transfer;
}
}
else
{
- if (current_unit->flags.form == FORM_UNFORMATTED)
- transfer = unformatted_write;
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_write;
else
{
- if (ioparm.list_format)
- transfer = list_formatted_write;
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_write;
else
- transfer = formatted_transfer;
+ dtp->u.p.transfer = formatted_transfer;
}
}
if (read_flag)
{
- if (current_unit->read_bad)
+ if (dtp->u.p.current_unit->read_bad)
{
- generate_error (ERROR_BAD_OPTION,
+ generate_error (&dtp->common, ERROR_BAD_OPTION,
"Cannot READ after a nonadvancing WRITE");
return;
}
}
else
{
- if (advance_status == ADVANCE_YES && !g.seen_dollar)
- current_unit->read_bad = 1;
+ if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
+ dtp->u.p.current_unit->read_bad = 1;
}
- /* Reset counters for T and X-editing. */
- max_pos = skips = pending_spaces = 0;
-
/* Start the data transfer if we are doing a formatted transfer. */
- if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
- && ioparm.namelist_name == NULL && ionml == NULL)
- formatted_transfer (0, NULL, 0, 0, 1);
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+ && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
+ && dtp->u.p.ionml == NULL)
+ formatted_transfer (dtp, 0, NULL, 0, 0, 1);
}
/* Initialize an array_loop_spec given the array descriptor. The function
negative strides. */
gfc_offset
-next_array_record ( array_loop_spec * ls )
+next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
{
int i, carry;
gfc_offset index;
carry = 1;
index = 0;
- for (i = 0; i < current_unit->rank; i++)
+ for (i = 0; i < dtp->u.p.current_unit->rank; i++)
{
if (carry)
{
#define MAX_READ 4096
static void
-next_record_r (void)
+next_record_r (st_parameter_dt *dtp)
{
gfc_offset new, record;
int bytes_left, rlength, length;
char *p;
- switch (current_mode ())
+ switch (current_mode (dtp))
{
case UNFORMATTED_SEQUENTIAL:
- current_unit->bytes_left += sizeof (gfc_offset); /* Skip over tail */
+ dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset); /* Skip over tail */
/* Fall through... */
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
- if (current_unit->bytes_left == 0)
+ if (dtp->u.p.current_unit->bytes_left == 0)
break;
- if (is_seekable (current_unit->s))
+ if (is_seekable (dtp->u.p.current_unit->s))
{
- new = file_position (current_unit->s) + current_unit->bytes_left;
+ new = file_position (dtp->u.p.current_unit->s) + dtp->u.p.current_unit->bytes_left;
/* Direct access files do not generate END conditions,
only I/O errors. */
- if (sseek (current_unit->s, new) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
+ generate_error (&dtp->common, ERROR_OS, NULL);
}
else
{ /* Seek by reading data. */
- while (current_unit->bytes_left > 0)
+ while (dtp->u.p.current_unit->bytes_left > 0)
{
- rlength = length = (MAX_READ > current_unit->bytes_left) ?
- MAX_READ : current_unit->bytes_left;
+ rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
+ MAX_READ : dtp->u.p.current_unit->bytes_left;
- p = salloc_r (current_unit->s, &rlength);
+ p = salloc_r (dtp->u.p.current_unit->s, &rlength);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
- current_unit->bytes_left -= length;
+ dtp->u.p.current_unit->bytes_left -= length;
}
}
break;
case FORMATTED_SEQUENTIAL:
length = 1;
/* sf_read has already terminated input because of an '\n' */
- if (sf_seen_eor)
+ if (dtp->u.p.sf_seen_eor)
{
- sf_seen_eor=0;
+ dtp->u.p.sf_seen_eor = 0;
break;
}
- if (is_internal_unit())
+ if (is_internal_unit (dtp))
{
- if (is_array_io())
- {
- record = next_array_record (current_unit->ls);
-
- /* Now seek to this record. */
- record = record * current_unit->recl;
- if (sseek (current_unit->s, record) == FAILURE)
- {
- generate_error (ERROR_OS, NULL);
- break;
- }
- current_unit->bytes_left = current_unit->recl;
- }
- else
- {
- bytes_left = (int) current_unit->bytes_left;
- p = salloc_r (current_unit->s, &bytes_left);
- if (p != NULL)
- current_unit->bytes_left = current_unit->recl;
- }
- break;
+ if (is_array_io (dtp))
+ {
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+
+ /* Now seek to this record. */
+ record = record * dtp->u.p.current_unit->recl;
+ if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ break;
+ }
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ }
+ else
+ {
+ bytes_left = (int) dtp->u.p.current_unit->bytes_left;
+ p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
+ if (p != NULL)
+ dtp->u.p.current_unit->bytes_left
+ = dtp->u.p.current_unit->recl;
+ }
+ break;
}
else do
{
- p = salloc_r (current_unit->s, &length);
+ p = salloc_r (dtp->u.p.current_unit->s, &length);
if (p == NULL)
{
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
if (length == 0)
{
- current_unit->endfile = AT_ENDFILE;
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
}
break;
}
- if (current_unit->flags.access == ACCESS_SEQUENTIAL)
- test_endfile (current_unit);
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ test_endfile (dtp->u.p.current_unit);
}
/* Position to the next record in write mode. */
static void
-next_record_w (void)
+next_record_w (st_parameter_dt *dtp)
{
gfc_offset c, m, record;
int bytes_left, length;
char *p;
/* Zero counters for X- and T-editing. */
- max_pos = skips = pending_spaces = 0;
+ dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
- switch (current_mode ())
+ switch (current_mode (dtp))
{
case FORMATTED_DIRECT:
- if (current_unit->bytes_left == 0)
+ if (dtp->u.p.current_unit->bytes_left == 0)
break;
- length = current_unit->bytes_left;
- p = salloc_w (current_unit->s, &length);
+ length = dtp->u.p.current_unit->bytes_left;
+ p = salloc_w (dtp->u.p.current_unit->s, &length);
if (p == NULL)
goto io_error;
- memset (p, ' ', current_unit->bytes_left);
- if (sfree (current_unit->s) == FAILURE)
+ memset (p, ' ', dtp->u.p.current_unit->bytes_left);
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
break;
case UNFORMATTED_DIRECT:
- if (sfree (current_unit->s) == FAILURE)
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
break;
case UNFORMATTED_SEQUENTIAL:
- m = current_unit->recl - current_unit->bytes_left; /* Bytes written. */
- c = file_position (current_unit->s);
+ /* Bytes written. */
+ m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
+ c = file_position (dtp->u.p.current_unit->s);
length = sizeof (gfc_offset);
/* Write the length tail. */
- p = salloc_w (current_unit->s, &length);
+ p = salloc_w (dtp->u.p.current_unit->s, &length);
if (p == NULL)
goto io_error;
memcpy (p, &m, sizeof (gfc_offset));
- if (sfree (current_unit->s) == FAILURE)
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
/* Seek to the head and overwrite the bogus length with the real
length. */
- p = salloc_w_at (current_unit->s, &length, c - m - length);
+ p = salloc_w_at (dtp->u.p.current_unit->s, &length, c - m - length);
if (p == NULL)
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
memcpy (p, &m, sizeof (gfc_offset));
- if (sfree (current_unit->s) == FAILURE)
+ if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
/* Seek past the end of the current record. */
- if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
goto io_error;
break;
case FORMATTED_SEQUENTIAL:
- if (current_unit->bytes_left == 0)
+ if (dtp->u.p.current_unit->bytes_left == 0)
break;
- if (is_internal_unit())
+ if (is_internal_unit (dtp))
{
- if (is_array_io())
+ if (is_array_io (dtp))
{
- bytes_left = (int) current_unit->bytes_left;
- p = salloc_w (current_unit->s, &bytes_left);
+ bytes_left = (int) dtp->u.p.current_unit->bytes_left;
+ p = salloc_w (dtp->u.p.current_unit->s, &bytes_left);
if (p == NULL)
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return;
}
- memset(p, ' ', bytes_left);
-
- /* Now that the current record has been padded out,
- determine where the next record in the array is. */
-
- record = next_array_record (current_unit->ls);
-
- /* Now seek to this record */
- record = record * current_unit->recl;
-
- if (sseek (current_unit->s, record) == FAILURE)
- goto io_error;
-
- current_unit->bytes_left = current_unit->recl;
+ memset(p, ' ', bytes_left);
+
+ /* Now that the current record has been padded out,
+ determine where the next record in the array is. */
+
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+
+ /* Now seek to this record */
+ record = record * dtp->u.p.current_unit->recl;
+
+ if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ goto io_error;
+
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
else
{
length = 1;
- p = salloc_w (current_unit->s, &length);
- if (p==NULL)
- goto io_error;
+ p = salloc_w (dtp->u.p.current_unit->s, &length);
+ if (p == NULL)
+ goto io_error;
}
}
else
#else
length = 1;
#endif
- p = salloc_w (current_unit->s, &length);
+ p = salloc_w (dtp->u.p.current_unit->s, &length);
if (p)
{ /* No new line for internal writes. */
#ifdef HAVE_CRLF
break;
io_error:
- generate_error (ERROR_OS, NULL);
+ generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
}
the next record. */
void
-next_record (int done)
+next_record (st_parameter_dt *dtp, int done)
{
gfc_offset fp; /* File position. */
- current_unit->read_bad = 0;
+ dtp->u.p.current_unit->read_bad = 0;
- if (g.mode == READING)
- next_record_r ();
+ if (dtp->u.p.mode == READING)
+ next_record_r (dtp);
else
- next_record_w ();
+ next_record_w (dtp);
/* keep position up to date for INQUIRE */
- current_unit->flags.position = POSITION_ASIS;
+ dtp->u.p.current_unit->flags.position = POSITION_ASIS;
- current_unit->current_record = 0;
- if (current_unit->flags.access == ACCESS_DIRECT)
+ dtp->u.p.current_unit->current_record = 0;
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- fp = file_position (current_unit->s);
+ fp = file_position (dtp->u.p.current_unit->s);
/* Calculate next record, rounding up partial records. */
- current_unit->last_record = (fp + current_unit->recl - 1)
- / current_unit->recl;
+ dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1)
+ / dtp->u.p.current_unit->recl;
}
else
- current_unit->last_record++;
+ dtp->u.p.current_unit->last_record++;
if (!done)
- pre_position ();
+ pre_position (dtp);
}
stream associated with the unit. */
static void
-finalize_transfer (void)
+finalize_transfer (st_parameter_dt *dtp)
{
+ jmp_buf eof_jump;
+ GFC_INTEGER_4 cf = dtp->common.flags;
- if (eor_condition)
+ if (dtp->u.p.eor_condition)
{
- generate_error (ERROR_EOR, NULL);
+ generate_error (&dtp->common, ERROR_EOR, NULL);
return;
}
- if (ioparm.library_return != LIBRARY_OK)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- if ((ionml != NULL) && (ioparm.namelist_name != NULL))
+ if ((dtp->u.p.ionml != NULL)
+ && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
{
- if (ioparm.namelist_read_mode)
- namelist_read();
+ if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
+ namelist_read (dtp);
else
- namelist_write();
+ namelist_write (dtp);
}
- transfer = NULL;
- if (current_unit == NULL)
+ dtp->u.p.transfer = NULL;
+ if (dtp->u.p.current_unit == NULL)
return;
- if (setjmp (g.eof_jump))
+ dtp->u.p.eof_jump = &eof_jump;
+ if (setjmp (eof_jump))
{
- generate_error (ERROR_END, NULL);
+ generate_error (&dtp->common, ERROR_END, NULL);
return;
}
- if (ioparm.list_format && g.mode == READING)
- finish_list_read ();
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
+ finish_list_read (dtp);
else
{
- free_fnodes ();
-
- if (advance_status == ADVANCE_NO || g.seen_dollar)
+ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
{
/* Most systems buffer lines, so force the partial record
to be written out. */
- flush (current_unit->s);
- g.seen_dollar = 0;
+ flush (dtp->u.p.current_unit->s);
+ dtp->u.p.seen_dollar = 0;
return;
}
- next_record (1);
- current_unit->current_record = 0;
+ next_record (dtp, 1);
+ dtp->u.p.current_unit->current_record = 0;
}
- sfree (current_unit->s);
+ sfree (dtp->u.p.current_unit->s);
- if (is_internal_unit ())
+ if (is_internal_unit (dtp))
{
- if (is_array_io() && current_unit->ls != NULL)
- free_mem (current_unit->ls);
- sclose (current_unit->s);
+ if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
+ free_mem (dtp->u.p.current_unit->ls);
+ sclose (dtp->u.p.current_unit->s);
}
}
data transfer, it just updates the length counter. */
static void
-iolength_transfer (bt type __attribute__((unused)),
+iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
void *dest __attribute__ ((unused)),
int kind __attribute__((unused)),
size_t size, size_t nelems)
{
- if (ioparm.iolength != NULL)
- *ioparm.iolength += (GFC_INTEGER_4) size * nelems;
+ if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
+ *dtp->iolength += (GFC_INTEGER_4) size * nelems;
}
doesn't have to deal with units at all. */
static void
-iolength_transfer_init (void)
+iolength_transfer_init (st_parameter_dt *dtp)
{
- if (ioparm.iolength != NULL)
- *ioparm.iolength = 0;
+ if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
+ *dtp->iolength = 0;
- g.item_count = 0;
+ memset (&dtp->u.p, 0, sizeof (dtp->u.p));
/* Set up the subroutine that will handle the transfers. */
- transfer = iolength_transfer;
+ dtp->u.p.transfer = iolength_transfer;
}
it must still be a runtime library call so that we can determine
the iolength for dynamic arrays and such. */
-extern void st_iolength (void);
+extern void st_iolength (st_parameter_dt *);
export_proto(st_iolength);
void
-st_iolength (void)
+st_iolength (st_parameter_dt *dtp)
{
- library_start ();
- iolength_transfer_init ();
+ library_start (&dtp->common);
+ iolength_transfer_init (dtp);
}
-extern void st_iolength_done (void);
+extern void st_iolength_done (st_parameter_dt *);
export_proto(st_iolength_done);
void
-st_iolength_done (void)
+st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
{
+ free_ionml (dtp);
+ if (dtp->u.p.scratch != NULL)
+ free_mem (dtp->u.p.scratch);
library_end ();
}
/* The READ statement. */
-extern void st_read (void);
+extern void st_read (st_parameter_dt *);
export_proto(st_read);
void
-st_read (void)
+st_read (st_parameter_dt *dtp)
{
- library_start ();
+ library_start (&dtp->common);
- data_transfer_init (1);
+ data_transfer_init (dtp, 1);
/* Handle complications dealing with the endfile record. It is
significant that this is the only place where ERROR_END is
generated. Reading an end of file elsewhere is either end of
record or an I/O error. */
- if (current_unit->flags.access == ACCESS_SEQUENTIAL)
- switch (current_unit->endfile)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ switch (dtp->u.p.current_unit->endfile)
{
case NO_ENDFILE:
break;
case AT_ENDFILE:
- if (!is_internal_unit())
+ if (!is_internal_unit (dtp))
{
- generate_error (ERROR_END, NULL);
- current_unit->endfile = AFTER_ENDFILE;
- current_unit->current_record = 0;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
+ dtp->u.p.current_unit->current_record = 0;
}
break;
case AFTER_ENDFILE:
- generate_error (ERROR_ENDFILE, NULL);
- current_unit->current_record = 0;
+ generate_error (&dtp->common, ERROR_ENDFILE, NULL);
+ dtp->u.p.current_unit->current_record = 0;
break;
}
}
-extern void st_read_done (void);
+extern void st_read_done (st_parameter_dt *);
export_proto(st_read_done);
void
-st_read_done (void)
+st_read_done (st_parameter_dt *dtp)
{
- finalize_transfer ();
+ finalize_transfer (dtp);
+ free_format_data (dtp);
+ free_ionml (dtp);
+ if (dtp->u.p.scratch != NULL)
+ free_mem (dtp->u.p.scratch);
+ if (dtp->u.p.current_unit != NULL)
+ unlock_unit (dtp->u.p.current_unit);
library_end ();
}
-extern void st_write (void);
+extern void st_write (st_parameter_dt *);
export_proto(st_write);
void
-st_write (void)
+st_write (st_parameter_dt *dtp)
{
-
- library_start ();
- data_transfer_init (0);
+ library_start (&dtp->common);
+ data_transfer_init (dtp, 0);
}
-extern void st_write_done (void);
+extern void st_write_done (st_parameter_dt *);
export_proto(st_write_done);
void
-st_write_done (void)
+st_write_done (st_parameter_dt *dtp)
{
- finalize_transfer ();
+ finalize_transfer (dtp);
/* Deal with endfile conditions associated with sequential files. */
- if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
- switch (current_unit->endfile)
+ if (dtp->u.p.current_unit != NULL && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
break;
case AFTER_ENDFILE:
- current_unit->endfile = AT_ENDFILE; /* Just at it now. */
+ dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
break;
case NO_ENDFILE:
- if (current_unit->current_record > current_unit->last_record)
+ if (dtp->u.p.current_unit->current_record > dtp->u.p.current_unit->last_record)
{
/* Get rid of whatever is after this record. */
- if (struncate (current_unit->s) == FAILURE)
- generate_error (ERROR_OS, NULL);
+ if (struncate (dtp->u.p.current_unit->s) == FAILURE)
+ generate_error (&dtp->common, ERROR_OS, NULL);
}
- current_unit->endfile = AT_ENDFILE;
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
+ free_format_data (dtp);
+ free_ionml (dtp);
+ if (dtp->u.p.scratch != NULL)
+ free_mem (dtp->u.p.scratch);
+ if (dtp->u.p.current_unit != NULL)
+ unlock_unit (dtp->u.p.current_unit);
library_end ();
}
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
-extern void st_set_nml_var (void * ,char * ,
- GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
+extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
+ GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
export_proto(st_set_nml_var);
void
-st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
- gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
+st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
+ GFC_INTEGER_4 len, gfc_charlen_type string_length,
+ GFC_INTEGER_4 dtype)
{
namelist_info *t1 = NULL;
namelist_info *nml;
nml->next = NULL;
- if (ionml == NULL)
- ionml = nml;
+ if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
+ {
+ dtp->common.flags |= IOPARM_DT_IONML_SET;
+ dtp->u.p.ionml = nml;
+ }
else
{
- for (t1 = ionml; t1->next; t1 = t1->next);
+ for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
t1->next = nml;
}
- return;
}
/* Store the dimensional information for the namelist object. */
-extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
- GFC_INTEGER_4 ,GFC_INTEGER_4);
+extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
+ GFC_INTEGER_4, GFC_INTEGER_4,
+ GFC_INTEGER_4);
export_proto(st_set_nml_var_dim);
void
-st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
- GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
+st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
+ GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
+ GFC_INTEGER_4 ubound)
{
namelist_info * nml;
int n;
n = (int)n_dim;
- for (nml = ionml; nml->next; nml = nml->next);
+ for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
nml->dim[n].stride = (ssize_t)stride;
nml->dim[n].lbound = (ssize_t)lbound;
#include "io.h"
+/* IO locking rules:
+ UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
+ Concurrent use of different units should be supported, so
+ each unit has its own lock, LOCK.
+ Open should be atomic with its reopening of units and list_read.c
+ in several places needs find_unit another unit while holding stdin
+ unit's lock, so it must be possible to acquire UNIT_LOCK while holding
+ some unit's lock. Therefore to avoid deadlocks, it is forbidden
+ to acquire unit's private locks while holding UNIT_LOCK, except
+ for freshly created units (where no other thread can get at their
+ address yet) or when using just trylock rather than lock operation.
+ In addition to unit's private lock each unit has a WAITERS counter
+ and CLOSED flag. WAITERS counter must be either only
+ atomically incremented/decremented in all places (if atomic builtins
+ are supported), or protected by UNIT_LOCK in all places (otherwise).
+ CLOSED flag must be always protected by unit's LOCK.
+ After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
+ WAITERS must be incremented to avoid concurrent close from freeing
+ the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
+ Unit freeing is always done under UNIT_LOCK. If close_unit sees any
+ WAITERS, it doesn't free the unit but instead sets the CLOSED flag
+ and the thread that decrements WAITERS to zero while CLOSED flag is
+ set is responsible for freeing it (while holding UNIT_LOCK).
+ flush_all_units operation is iterating over the unit tree with
+ increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
+ flush each unit (and therefore needs the unit's LOCK held as well).
+ To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
+ remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
+ unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
+ the smallest UNIT_NUMBER above the last one flushed.
+
+ If find_unit/find_or_create_unit/find_file/get_unit routines return
+ non-NULL, the returned unit has its private lock locked and when the
+ caller is done with it, it must call either unlock_unit or close_unit
+ on it. unlock_unit or close_unit must be always called only with the
+ private lock held. */
+
/* Subroutines related to units */
#define CACHE_SIZE 3
static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
-
+gfc_offset max_offset;
+gfc_unit *unit_root;
+#ifdef __GTHREAD_MUTEX_INIT
+__gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
+#else
+__gthread_mutex_t unit_lock;
+#endif
/* This implementation is based on Stefan Nilsson's article in the
* July 1997 Doctor Dobb's Journal, "Treaps in Java". */
/* insert()-- Recursive insertion function. Returns the updated treap. */
static gfc_unit *
-insert (gfc_unit * new, gfc_unit * t)
+insert (gfc_unit *new, gfc_unit *t)
{
int c;
}
if (c == 0)
- internal_error ("insert(): Duplicate key found!");
+ internal_error (NULL, "insert(): Duplicate key found!");
return t;
}
-/* insert_unit()-- Given a new node, insert it into the treap. It is
- * an error to insert a key that already exists. */
+/* insert_unit()-- Create a new node, insert it into the treap. */
-void
-insert_unit (gfc_unit * new)
+static gfc_unit *
+insert_unit (int n)
{
- new->priority = pseudo_random ();
- g.unit_root = insert (new, g.unit_root);
+ gfc_unit *u = get_mem (sizeof (gfc_unit));
+ memset (u, '\0', sizeof (gfc_unit));
+ u->unit_number = n;
+#ifdef __GTHREAD_MUTEX_INIT
+ {
+ __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
+ u->lock = tmp;
+ }
+#else
+ __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
+#endif
+ __gthread_mutex_lock (&u->lock);
+ u->priority = pseudo_random ();
+ unit_root = insert (u, unit_root);
+ return u;
}
static void
delete_unit (gfc_unit * old)
{
- g.unit_root = delete_treap (old, g.unit_root);
+ unit_root = delete_treap (old, unit_root);
}
/* find_unit()-- Given an integer, return a pointer to the unit
- * structure. Returns NULL if the unit does not exist. */
+ * structure. Returns NULL if the unit does not exist,
+ * otherwise returns a locked unit. */
-gfc_unit *
-find_unit (int n)
+static gfc_unit *
+find_unit_1 (int n, int do_create)
{
gfc_unit *p;
- int c;
+ int c, created = 0;
+ __gthread_mutex_lock (&unit_lock);
+retry:
for (c = 0; c < CACHE_SIZE; c++)
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
{
p = unit_cache[c];
- return p;
+ goto found;
}
- p = g.unit_root;
+ p = unit_root;
while (p != NULL)
{
c = compare (n, p->unit_number);
break;
}
+ if (p == NULL && do_create)
+ {
+ p = insert_unit (n);
+ created = 1;
+ }
+
if (p != NULL)
{
for (c = 0; c < CACHE_SIZE - 1; c++)
unit_cache[CACHE_SIZE - 1] = p;
}
+ if (created)
+ {
+ /* Newly created units have their lock held already
+ from insert_unit. Just unlock UNIT_LOCK and return. */
+ __gthread_mutex_unlock (&unit_lock);
+ return p;
+ }
+
+found:
+ if (p != NULL)
+ {
+ /* Fast path. */
+ if (! __gthread_mutex_trylock (&p->lock))
+ {
+ /* assert (p->closed == 0); */
+ __gthread_mutex_unlock (&unit_lock);
+ return p;
+ }
+
+ inc_waiting_locked (p);
+ }
+
+ __gthread_mutex_unlock (&unit_lock);
+
+ if (p != NULL)
+ {
+ __gthread_mutex_lock (&p->lock);
+ if (p->closed)
+ {
+ __gthread_mutex_lock (&unit_lock);
+ __gthread_mutex_unlock (&p->lock);
+ if (predec_waiting_locked (p) == 0)
+ free_mem (p);
+ goto retry;
+ }
+
+ dec_waiting_unlocked (p);
+ }
return p;
}
+gfc_unit *
+find_unit (int n)
+{
+ return find_unit_1 (n, 0);
+}
+
+gfc_unit *
+find_or_create_unit (int n)
+{
+ return find_unit_1 (n, 1);
+}
+
/* get_unit()-- Returns the unit structure associated with the integer
* unit or the internal file. */
gfc_unit *
-get_unit (int read_flag __attribute__ ((unused)))
+get_unit (st_parameter_dt *dtp, int do_create)
{
- if (ioparm.internal_unit != NULL)
+ if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
{
- internal_unit.recl = ioparm.internal_unit_len;
- if (is_array_io())
- {
- internal_unit.rank = GFC_DESCRIPTOR_RANK(ioparm.internal_unit_desc);
- internal_unit.ls = (array_loop_spec*)
- get_mem (internal_unit.rank * sizeof (array_loop_spec));
- ioparm.internal_unit_len *=
- init_loop_spec (ioparm.internal_unit_desc, internal_unit.ls);
- }
-
+ __gthread_mutex_lock (&internal_unit.lock);
+ internal_unit.recl = dtp->internal_unit_len;
+ if (is_array_io (dtp))
+ {
+ internal_unit.rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
+ internal_unit.ls = (array_loop_spec *)
+ get_mem (internal_unit.rank * sizeof (array_loop_spec));
+ dtp->internal_unit_len *=
+ init_loop_spec (dtp->internal_unit_desc, internal_unit.ls);
+ }
+
internal_unit.s =
- open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
+ open_internal (dtp->internal_unit, dtp->internal_unit_len);
internal_unit.bytes_left = internal_unit.recl;
internal_unit.last_record=0;
internal_unit.maxrec=0;
internal_unit.current_record=0;
- if (g.mode==WRITING && !is_array_io())
+ if (dtp->u.p.mode==WRITING && !is_array_io (dtp))
empty_internal_buffer (internal_unit.s);
/* Set flags for the internal unit */
/* Has to be an external unit */
- return find_unit (ioparm.unit);
+ return find_unit_1 (dtp->common.unit, do_create);
}
/* is_internal_unit()-- Determine if the current unit is internal or not */
int
-is_internal_unit (void)
+is_internal_unit (st_parameter_dt *dtp)
{
- return current_unit == &internal_unit;
+ return dtp->u.p.current_unit == &internal_unit;
}
/* is_array_io ()-- Determine if the I/O is to/from an array */
int
-is_array_io (void)
+is_array_io (st_parameter_dt *dtp)
{
- return (ioparm.internal_unit_desc != NULL);
+ return dtp->internal_unit_desc != NULL;
}
gfc_unit *u;
unsigned int i;
+#ifndef __GTHREAD_MUTEX_INIT
+ __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
+#endif
+
+#ifdef __GTHREAD_MUTEX_INIT
+ {
+ __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
+ internal_unit.lock = tmp;
+ }
+#else
+ __GTHREAD_MUTEX_INIT_FUNCTION (&internal_unit.lock);
+#endif
+
if (options.stdin_unit >= 0)
{ /* STDIN */
- u = get_mem (sizeof (gfc_unit));
- memset (u, '\0', sizeof (gfc_unit));
-
- u->unit_number = options.stdin_unit;
+ u = insert_unit (options.stdin_unit);
u->s = input_stream ();
u->flags.action = ACTION_READ;
u->recl = options.default_recl;
u->endfile = NO_ENDFILE;
- insert_unit (u);
+ __gthread_mutex_unlock (&u->lock);
}
if (options.stdout_unit >= 0)
{ /* STDOUT */
- u = get_mem (sizeof (gfc_unit));
- memset (u, '\0', sizeof (gfc_unit));
-
- u->unit_number = options.stdout_unit;
+ u = insert_unit (options.stdout_unit);
u->s = output_stream ();
u->flags.action = ACTION_WRITE;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
- insert_unit (u);
+ __gthread_mutex_unlock (&u->lock);
}
if (options.stderr_unit >= 0)
{ /* STDERR */
- u = get_mem (sizeof (gfc_unit));
- memset (u, '\0', sizeof (gfc_unit));
-
- u->unit_number = options.stderr_unit;
+ u = insert_unit (options.stderr_unit);
u->s = error_stream ();
u->flags.action = ACTION_WRITE;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
- insert_unit (u);
+ __gthread_mutex_unlock (&u->lock);
}
/* Calculate the maximum file offset in a portable manner.
*
* set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
- g.max_offset = 0;
- for (i = 0; i < sizeof (g.max_offset) * 8 - 1; i++)
- g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
-
+ max_offset = 0;
+ for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
+ max_offset = max_offset + ((gfc_offset) 1 << i);
}
-/* close_unit()-- Close a unit. The stream is closed, and any memory
- * associated with the stream is freed. Returns nonzero on I/O error. */
-
-int
-close_unit (gfc_unit * u)
+static int
+close_unit_1 (gfc_unit *u, int locked)
{
int i, rc;
+ rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
+
+ u->closed = 1;
+ if (!locked)
+ __gthread_mutex_lock (&unit_lock);
+
for (i = 0; i < CACHE_SIZE; i++)
if (unit_cache[i] == u)
unit_cache[i] = NULL;
- rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
-
delete_unit (u);
- free_mem (u);
+
+ if (u->file)
+ free_mem (u->file);
+ u->file = NULL;
+ u->file_len = 0;
+
+ if (!locked)
+ __gthread_mutex_unlock (&u->lock);
+
+ /* If there are any threads waiting in find_unit for this unit,
+ avoid freeing the memory, the last such thread will free it
+ instead. */
+ if (u->waiting == 0)
+ free_mem (u);
+
+ if (!locked)
+ __gthread_mutex_unlock (&unit_lock);
return rc;
}
+void
+unlock_unit (gfc_unit *u)
+{
+ __gthread_mutex_unlock (&u->lock);
+}
+
+/* close_unit()-- Close a unit. The stream is closed, and any memory
+ * associated with the stream is freed. Returns nonzero on I/O error.
+ * Should be called with the u->lock locked. */
+
+int
+close_unit (gfc_unit *u)
+{
+ return close_unit_1 (u, 0);
+}
+
/* close_units()-- Delete units on completion. We just keep deleting
- * the root of the treap until there is nothing left. */
+ * the root of the treap until there is nothing left.
+ * Not sure what to do with locking here. Some other thread might be
+ * holding some unit's lock and perhaps hold it indefinitely
+ * (e.g. waiting for input from some pipe) and close_units shouldn't
+ * delay the program too much. */
void
close_units (void)
{
- while (g.unit_root != NULL)
- close_unit (g.unit_root);
+ __gthread_mutex_lock (&unit_lock);
+ while (unit_root != NULL)
+ close_unit_1 (unit_root, 1);
+ __gthread_mutex_unlock (&unit_lock);
}
#include "libgfortran.h"
#include "io.h"
+#include "unix.h"
#ifndef SSIZE_MAX
#define SSIZE_MAX SHRT_MAX
* 'where' parameter and use the current file pointer. */
-#define BUFFER_SIZE 8192
-
-typedef struct
-{
- stream st;
-
- int fd;
- gfc_offset buffer_offset; /* File offset of the start of the buffer */
- gfc_offset physical_offset; /* Current physical file offset */
- gfc_offset logical_offset; /* Current logical file offset */
- gfc_offset dirty_offset; /* Start of modified bytes in buffer */
- gfc_offset file_length; /* Length of the file, -1 if not seekable. */
-
- char *buffer;
- int len; /* Physical length of the current buffer */
- int active; /* Length of valid bytes in the buffer */
-
- int prot;
- int ndirty; /* Dirty bytes starting at dirty_offset */
-
- int special_file; /* =1 if the fd refers to a special file */
-
- unsigned unbuffered:1;
-
- char small_buffer[BUFFER_SIZE];
-
-}
-unix_stream;
-
/*move_pos_offset()-- Move the record pointer right or left
*relative to current position */
/* Given the Fortran unit number, convert it to a C file descriptor. */
int
-unit_to_fd(int unit)
+unit_to_fd (int unit)
{
gfc_unit *us;
+ int fd;
- us = find_unit(unit);
+ us = find_unit (unit);
if (us == NULL)
return -1;
- return ((unix_stream *) us->s)->fd;
+ fd = ((unix_stream *) us->s)->fd;
+ unlock_unit (us);
+ return fd;
}
* open it. mkstemp() opens the file for reading and writing, but the
* library mode prevents anything that is not allowed. The descriptor
* is returned, which is -1 on error. The template is pointed to by
- * ioparm.file, which is copied into the unit structure
+ * opp->file, which is copied into the unit structure
* and freed later. */
static int
-tempfile (void)
+tempfile (st_parameter_open *opp)
{
const char *tempdir;
char *template;
free_mem (template);
else
{
- ioparm.file = template;
- ioparm.file_len = strlen (template); /* Don't include trailing nul */
+ opp->file = template;
+ opp->file_len = strlen (template); /* Don't include trailing nul */
}
return fd;
* Returns the descriptor, which is less than zero on error. */
static int
-regular_file (unit_flags *flags)
+regular_file (st_parameter_open *opp, unit_flags *flags)
{
char path[PATH_MAX + 1];
int mode;
int crflag;
int fd;
- if (unpack_filename (path, ioparm.file, ioparm.file_len))
+ if (unpack_filename (path, opp->file, opp->file_len))
{
errno = ENOENT; /* Fake an OS error */
return -1;
break;
default:
- internal_error ("regular_file(): Bad action");
+ internal_error (&opp->common, "regular_file(): Bad action");
}
switch (flags->status)
break;
default:
- internal_error ("regular_file(): Bad status");
+ internal_error (&opp->common, "regular_file(): Bad status");
}
/* rwflag |= O_LARGEFILE; */
* Returns NULL on operating system error. */
stream *
-open_external (unit_flags *flags)
+open_external (st_parameter_open *opp, unit_flags *flags)
{
int fd, prot;
if (flags->status == STATUS_SCRATCH)
{
- fd = tempfile ();
+ fd = tempfile (opp);
if (flags->action == ACTION_UNSPECIFIED)
flags->action = ACTION_READWRITE;
#if HAVE_UNLINK_OPEN_FILE
/* We can unlink scratch files now and it will go away when closed. */
- unlink (ioparm.file);
+ if (fd >= 0)
+ unlink (opp->file);
#endif
}
else
{
/* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
* if it succeeds */
- fd = regular_file (flags);
+ fd = regular_file (opp, flags);
}
if (fd < 0)
break;
default:
- internal_error ("open_external(): Bad action");
+ internal_error (&opp->common, "open_external(): Bad action");
}
return fd_to_stream (fd, prot);
* corrupted. */
stream *
-init_error_stream (void)
+init_error_stream (unix_stream *error)
{
- static unix_stream error;
-
- memset (&error, '\0', sizeof (error));
+ memset (error, '\0', sizeof (*error));
- error.fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
+ error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
- error.st.alloc_w_at = (void *) fd_alloc_w_at;
- error.st.sfree = (void *) fd_sfree;
+ error->st.alloc_w_at = (void *) fd_alloc_w_at;
+ error->st.sfree = (void *) fd_sfree;
- error.unbuffered = 1;
- error.buffer = error.small_buffer;
+ error->unbuffered = 1;
+ error->buffer = error->small_buffer;
- return (stream *) & error;
+ return (stream *) error;
}
}
+#ifdef HAVE_WORKING_STAT
+# define FIND_FILE0_DECL struct stat *st
+# define FIND_FILE0_ARGS st
+#else
+# define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
+# define FIND_FILE0_ARGS file, file_len
+#endif
+
/* find_file0()-- Recursive work function for find_file() */
static gfc_unit *
-find_file0 (gfc_unit * u, struct stat *st1)
+find_file0 (gfc_unit *u, FIND_FILE0_DECL)
{
-#ifdef HAVE_WORKING_STAT
- struct stat st2;
-#endif
gfc_unit *v;
if (u == NULL)
return NULL;
#ifdef HAVE_WORKING_STAT
- if (fstat (((unix_stream *) u->s)->fd, &st2) >= 0 &&
- st1->st_dev == st2.st_dev && st1->st_ino == st2.st_ino)
+ if (u->s != NULL
+ && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
+ st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
return u;
#else
- if (compare_string(u->file_len, u->file, ioparm.file_len, ioparm.file) == 0)
+ if (compare_string (u->file_len, u->file, file_len, file) == 0)
return u;
#endif
- v = find_file0 (u->left, st1);
+ v = find_file0 (u->left, FIND_FILE0_ARGS);
if (v != NULL)
return v;
- v = find_file0 (u->right, st1);
+ v = find_file0 (u->right, FIND_FILE0_ARGS);
if (v != NULL)
return v;
* that has the file already open. Returns a pointer to the unit if so. */
gfc_unit *
-find_file (void)
+find_file (const char *file, gfc_charlen_type file_len)
{
char path[PATH_MAX + 1];
- struct stat statbuf;
+ struct stat st[2];
+ gfc_unit *u;
- if (unpack_filename (path, ioparm.file, ioparm.file_len))
+ if (unpack_filename (path, file, file_len))
return NULL;
- if (stat (path, &statbuf) < 0)
+ if (stat (path, &st[0]) < 0)
return NULL;
- return find_file0 (g.unit_root, &statbuf);
+ __gthread_mutex_lock (&unit_lock);
+retry:
+ u = find_file0 (unit_root, FIND_FILE0_ARGS);
+ if (u != NULL)
+ {
+ /* Fast path. */
+ if (! __gthread_mutex_trylock (&u->lock))
+ {
+ /* assert (u->closed == 0); */
+ __gthread_mutex_unlock (&unit_lock);
+ return u;
+ }
+
+ inc_waiting_locked (u);
+ }
+ __gthread_mutex_unlock (&unit_lock);
+ if (u != NULL)
+ {
+ __gthread_mutex_lock (&u->lock);
+ if (u->closed)
+ {
+ __gthread_mutex_lock (&unit_lock);
+ __gthread_mutex_unlock (&u->lock);
+ if (predec_waiting_locked (u) == 0)
+ free_mem (u);
+ goto retry;
+ }
+
+ dec_waiting_unlocked (u);
+ }
+ return u;
+}
+
+static gfc_unit *
+flush_all_units_1 (gfc_unit *u, int min_unit)
+{
+ while (u != NULL)
+ {
+ if (u->unit_number > min_unit)
+ {
+ gfc_unit *r = flush_all_units_1 (u->left, min_unit);
+ if (r != NULL)
+ return r;
+ }
+ if (u->unit_number >= min_unit)
+ {
+ if (__gthread_mutex_trylock (&u->lock))
+ return u;
+ if (u->s)
+ flush (u->s);
+ __gthread_mutex_unlock (&u->lock);
+ }
+ u = u->right;
+ }
+ return NULL;
+}
+
+void
+flush_all_units (void)
+{
+ gfc_unit *u;
+ int min_unit = 0;
+
+ __gthread_mutex_lock (&unit_lock);
+ do
+ {
+ u = flush_all_units_1 (unit_root, min_unit);
+ if (u != NULL)
+ inc_waiting_locked (u);
+ __gthread_mutex_unlock (&unit_lock);
+ if (u == NULL)
+ return;
+
+ __gthread_mutex_lock (&u->lock);
+
+ min_unit = u->unit_number + 1;
+
+ if (u->closed == 0)
+ {
+ flush (u->s);
+ __gthread_mutex_lock (&unit_lock);
+ __gthread_mutex_unlock (&u->lock);
+ (void) predec_waiting_locked (u);
+ }
+ else
+ {
+ __gthread_mutex_lock (&unit_lock);
+ __gthread_mutex_unlock (&u->lock);
+ if (predec_waiting_locked (u) == 0)
+ free_mem (u);
+ }
+ }
+ while (1);
}
* the system */
int
-file_exists (void)
+file_exists (const char *file, gfc_charlen_type file_len)
{
char path[PATH_MAX + 1];
struct stat statbuf;
- if (unpack_filename (path, ioparm.file, ioparm.file_len))
+ if (unpack_filename (path, file, file_len))
return 0;
if (stat (path, &statbuf) < 0)
--- /dev/null
+/* Copyright (C) 2002, 2003, 2004, 2005
+ Free Software Foundation, Inc.
+ Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING. If not, write to
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+/* Unix stream I/O module */
+
+#define BUFFER_SIZE 8192
+
+typedef struct
+{
+ stream st;
+
+ int fd;
+ gfc_offset buffer_offset; /* File offset of the start of the buffer */
+ gfc_offset physical_offset; /* Current physical file offset */
+ gfc_offset logical_offset; /* Current logical file offset */
+ gfc_offset dirty_offset; /* Start of modified bytes in buffer */
+ gfc_offset file_length; /* Length of the file, -1 if not seekable. */
+
+ char *buffer;
+ int len; /* Physical length of the current buffer */
+ int active; /* Length of valid bytes in the buffer */
+
+ int prot;
+ int ndirty; /* Dirty bytes starting at dirty_offset */
+
+ int special_file; /* =1 if the fd refers to a special file */
+
+ unsigned unbuffered:1;
+
+ char small_buffer[BUFFER_SIZE];
+
+}
+unix_stream;
+
+extern stream *init_error_stream (unix_stream *);
+internal_proto(init_error_stream);
sign_t;
-static int no_leading_blank = 0 ;
-
void
-write_a (fnode * f, const char *source, int len)
+write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
int wlen;
char *p;
wlen = f->u.string.length < 0 ? len : f->u.string.length;
- p = write_block (wlen);
+ p = write_block (dtp, wlen);
if (p == NULL)
return;
break;
#endif
default:
- internal_error ("bad integer kind");
+ internal_error (NULL, "bad integer kind");
}
return i;
break;
#endif
default:
- internal_error ("bad integer kind");
+ internal_error (NULL, "bad integer kind");
}
return i;
break;
#endif
default:
- internal_error ("bad real kind");
+ internal_error (NULL, "bad real kind");
}
return i;
}
sign_t that gives the sign that we need to produce. */
static sign_t
-calculate_sign (int negative_flag)
+calculate_sign (st_parameter_dt *dtp, int negative_flag)
{
sign_t s = SIGN_NONE;
if (negative_flag)
s = SIGN_MINUS;
else
- switch (g.sign_status)
+ switch (dtp->u.p.sign_status)
{
case SIGN_SP:
s = SIGN_PLUS;
for Gw.dEe, n' ' means e+2 blanks */
static fnode *
-calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank)
+calculate_G_format (st_parameter_dt *dtp, const fnode *f,
+ GFC_REAL_LARGEST value, int *num_blank)
{
int e = f->u.real.e;
int d = f->u.real.d;
newf->u.real.d = - (mid - d - 1);
/* For F editing, the scale factor is ignored. */
- g.scale_factor = 0;
+ dtp->u.p.scale_factor = 0;
return newf;
}
/* Output a real number according to its format which is FMT_G free. */
static void
-output_float (fnode *f, GFC_REAL_LARGEST value)
+output_float (st_parameter_dt *dtp, const fnode *f, GFC_REAL_LARGEST value)
{
/* This must be large enough to accurately hold any value. */
char buffer[32];
/* We should always know the field width and precision. */
if (d < 0)
- internal_error ("Unspecified precision");
+ internal_error (&dtp->common, "Unspecified precision");
/* Use sprintf to print the number in the format +D.DDDDe+ddd
For an N digit exponent, this gives us (32-6)-N digits after the
decimal point, plus another one before the decimal point. */
- sign = calculate_sign (value < 0.0);
+ sign = calculate_sign (dtp, value < 0.0);
if (value < 0)
value = -value;
}
if (ft == FMT_F || ft == FMT_EN
- || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
+ || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
{
/* Always convert at full precision to avoid double rounding. */
ndigits = 27 - edigits;
/* Check the resulting string has punctuation in the correct places. */
if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
- internal_error ("printf is broken");
+ internal_error (&dtp->common, "printf is broken");
/* Read the exponent back in. */
e = atoi (&buffer[ndigits + 3]) + 1;
switch (ft)
{
case FMT_F:
- nbefore = e + g.scale_factor;
+ nbefore = e + dtp->u.p.scale_factor;
if (nbefore < 0)
{
nzero = -nbefore;
case FMT_E:
case FMT_D:
- i = g.scale_factor;
+ i = dtp->u.p.scale_factor;
if (value != 0.0)
e -= i;
if (i < 0)
default:
/* Should never happen. */
- internal_error ("Unexpected format token");
+ internal_error (&dtp->common, "Unexpected format token");
}
/* Round the value. */
w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
/* Create the ouput buffer. */
- out = write_block (w);
+ out = write_block (dtp, w);
if (out == NULL)
return;
break;
}
if (i == ndigits)
- sign = calculate_sign (0);
+ sign = calculate_sign (dtp, 0);
/* Work out how much padding is needed. */
nblanks = w - (nbefore + nzero + nafter + edigits + 1);
/* Pad to full field width. */
- if ( ( nblanks > 0 ) && !no_leading_blank )
+ if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
{
memset (out, ' ', nblanks);
out += nblanks;
memcpy (out, buffer, edigits);
}
- if ( no_leading_blank )
+ if (dtp->u.p.no_leading_blank)
{
out += edigits;
memset( out , ' ' , nblanks );
- no_leading_blank = 0;
+ dtp->u.p.no_leading_blank = 0;
}
}
void
-write_l (fnode * f, char *source, int len)
+write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
{
char *p;
GFC_INTEGER_LARGEST n;
- p = write_block (f->u.w);
+ p = write_block (dtp, f->u.w);
if (p == NULL)
return;
/* Output a real number according to its format. */
static void
-write_float (fnode *f, const char *source, int len)
+write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
GFC_REAL_LARGEST n;
int nb =0, res, save_scale_factor;
not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
if (nb == 0) nb = 4;
- p = write_block (nb);
+ p = write_block (dtp, nb);
if (p == NULL)
return;
if (nb < 3)
}
if (f->format != FMT_G)
- {
- output_float (f, n);
- }
+ output_float (dtp, f, n);
else
{
- save_scale_factor = g.scale_factor;
- f2 = calculate_G_format(f, n, &nb);
- output_float (f2, n);
- g.scale_factor = save_scale_factor;
+ save_scale_factor = dtp->u.p.scale_factor;
+ f2 = calculate_G_format (dtp, f, n, &nb);
+ output_float (dtp, f2, n);
+ dtp->u.p.scale_factor = save_scale_factor;
if (f2 != NULL)
free_mem(f2);
if (nb > 0)
{
- p = write_block (nb);
+ p = write_block (dtp, nb);
if (p == NULL)
return;
memset (p, ' ', nb);
static void
-write_int (fnode *f, const char *source, int len,
+write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
{
GFC_UINTEGER_LARGEST n = 0;
if (w == 0)
w = 1;
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
if (w == 0)
w = ((digits < m) ? m : digits);
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
}
- if (!no_leading_blank)
+ if (!dtp->u.p.no_leading_blank)
{
- memset (p, ' ', nblank);
- p += nblank;
- memset (p, '0', nzero);
- p += nzero;
- memcpy (p, q, digits);
+ memset (p, ' ', nblank);
+ p += nblank;
+ memset (p, '0', nzero);
+ p += nzero;
+ memcpy (p, q, digits);
}
else
{
memcpy (p, q, digits);
p += digits;
memset (p, ' ', nblank);
- no_leading_blank = 0;
+ dtp->u.p.no_leading_blank = 0;
}
done:
}
static void
-write_decimal (fnode *f, const char *source, int len,
+write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
+ int len,
const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
{
GFC_INTEGER_LARGEST n = 0;
if (w == 0)
w = 1;
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
goto done;
}
- sign = calculate_sign (n < 0);
+ sign = calculate_sign (dtp, n < 0);
if (n < 0)
n = -n;
if (w == 0)
w = ((digits < m) ? m : digits) + nsign;
- p = write_block (w);
+ p = write_block (dtp, w);
if (p == NULL)
return;
void
-write_i (fnode * f, const char *p, int len)
+write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_decimal (f, p, len, (void *) gfc_itoa);
+ write_decimal (dtp, f, p, len, (void *) gfc_itoa);
}
void
-write_b (fnode * f, const char *p, int len)
+write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_int (f, p, len, btoa);
+ write_int (dtp, f, p, len, btoa);
}
void
-write_o (fnode * f, const char *p, int len)
+write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_int (f, p, len, otoa);
+ write_int (dtp, f, p, len, otoa);
}
void
-write_z (fnode * f, const char *p, int len)
+write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_int (f, p, len, xtoa);
+ write_int (dtp, f, p, len, xtoa);
}
void
-write_d (fnode *f, const char *p, int len)
+write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_e (fnode *f, const char *p, int len)
+write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_f (fnode *f, const char *p, int len)
+write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_en (fnode *f, const char *p, int len)
+write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
void
-write_es (fnode *f, const char *p, int len)
+write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (f, p, len);
+ write_float (dtp, f, p, len);
}
/* Take care of the X/TR descriptor. */
void
-write_x (int len, int nspaces)
+write_x (st_parameter_dt *dtp, int len, int nspaces)
{
char *p;
- p = write_block (len);
+ p = write_block (dtp, len);
if (p == NULL)
return;
something goes wrong. */
static int
-write_char (char c)
+write_char (st_parameter_dt *dtp, char c)
{
char *p;
- p = write_block (1);
+ p = write_block (dtp, 1);
if (p == NULL)
return 1;
/* Write a list-directed logical value. */
static void
-write_logical (const char *source, int length)
+write_logical (st_parameter_dt *dtp, const char *source, int length)
{
- write_char (extract_int (source, length) ? 'T' : 'F');
+ write_char (dtp, extract_int (source, length) ? 'T' : 'F');
}
/* Write a list-directed integer value. */
static void
-write_integer (const char *source, int length)
+write_integer (st_parameter_dt *dtp, const char *source, int length)
{
char *p;
const char *q;
digits = strlen (q);
- if(width < digits )
- width = digits ;
- p = write_block (width) ;
+ if (width < digits)
+ width = digits;
+ p = write_block (dtp, width);
if (p == NULL)
return;
- if (no_leading_blank)
+ if (dtp->u.p.no_leading_blank)
{
memcpy (p, q, digits);
- memset(p + digits ,' ', width - digits) ;
+ memset (p + digits, ' ', width - digits);
}
else
{
- memset(p ,' ', width - digits) ;
+ memset (p, ' ', width - digits);
memcpy (p + width - digits, q, digits);
}
}
the strings if the file has been opened in that mode. */
static void
-write_character (const char *source, int length)
+write_character (st_parameter_dt *dtp, const char *source, int length)
{
int i, extra;
char *p, d;
- switch (current_unit->flags.delim)
+ switch (dtp->u.p.current_unit->flags.delim)
{
case DELIM_APOSTROPHE:
d = '\'';
extra++;
}
- p = write_block (length + extra);
+ p = write_block (dtp, length + extra);
if (p == NULL)
return;
1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
static void
-write_real (const char *source, int length)
+write_real (st_parameter_dt *dtp, const char *source, int length)
{
fnode f ;
- int org_scale = g.scale_factor;
+ int org_scale = dtp->u.p.scale_factor;
f.format = FMT_G;
- g.scale_factor = 1;
+ dtp->u.p.scale_factor = 1;
switch (length)
{
case 4:
f.u.real.e = 4;
break;
default:
- internal_error ("bad real kind");
+ internal_error (&dtp->common, "bad real kind");
break;
}
- write_float (&f, source , length);
- g.scale_factor = org_scale;
+ write_float (dtp, &f, source , length);
+ dtp->u.p.scale_factor = org_scale;
}
static void
-write_complex (const char *source, int kind, size_t size)
+write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{
- if (write_char ('('))
+ if (write_char (dtp, '('))
return;
- write_real (source, kind);
+ write_real (dtp, source, kind);
- if (write_char (','))
+ if (write_char (dtp, ','))
return;
- write_real (source + size / 2, kind);
+ write_real (dtp, source + size / 2, kind);
- write_char (')');
+ write_char (dtp, ')');
}
/* Write the separator between items. */
static void
-write_separator (void)
+write_separator (st_parameter_dt *dtp)
{
char *p;
- p = write_block (options.separator_len);
+ p = write_block (dtp, options.separator_len);
if (p == NULL)
return;
with strings. */
static void
-list_formatted_write_scalar (bt type, void *p, int kind, size_t size)
+list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size)
{
- static int char_flag;
-
- if (current_unit == NULL)
+ if (dtp->u.p.current_unit == NULL)
return;
- if (g.first_item)
+ if (dtp->u.p.first_item)
{
- g.first_item = 0;
- char_flag = 0;
- write_char (' ');
+ dtp->u.p.first_item = 0;
+ write_char (dtp, ' ');
}
else
{
- if (type != BT_CHARACTER || !char_flag ||
- current_unit->flags.delim != DELIM_NONE)
- write_separator ();
+ if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
+ dtp->u.p.current_unit->flags.delim != DELIM_NONE)
+ write_separator (dtp);
}
switch (type)
{
case BT_INTEGER:
- write_integer (p, kind);
+ write_integer (dtp, p, kind);
break;
case BT_LOGICAL:
- write_logical (p, kind);
+ write_logical (dtp, p, kind);
break;
case BT_CHARACTER:
- write_character (p, kind);
+ write_character (dtp, p, kind);
break;
case BT_REAL:
- write_real (p, kind);
+ write_real (dtp, p, kind);
break;
case BT_COMPLEX:
- write_complex (p, kind, size);
+ write_complex (dtp, p, kind, size);
break;
default:
- internal_error ("list_formatted_write(): Bad type");
+ internal_error (&dtp->common, "list_formatted_write(): Bad type");
}
- char_flag = (type == BT_CHARACTER);
+ dtp->u.p.char_flag = (type == BT_CHARACTER);
}
void
-list_formatted_write (bt type, void *p, int kind, size_t size, size_t nelems)
+list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size, size_t nelems)
{
size_t elem;
char *tmp;
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
- g.item_count++;
- list_formatted_write_scalar (type, tmp + size*elem, kind, size);
+ dtp->u.p.item_count++;
+ list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
}
}
#define NML_DIGITS 20
-/* Stores the delimiter to be used for character objects. */
-
-static const char * nml_delim;
-
static namelist_info *
-nml_write_obj (namelist_info * obj, index_type offset,
+nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
namelist_info * base, char * base_name)
{
int rep_ctr;
if (obj->type != GFC_DTYPE_DERIVED)
{
- write_character ("\n ", 2);
+ write_character (dtp, "\n ", 2);
len = 0;
if (base)
{
for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
{
cup = toupper (base_name[dim_i]);
- write_character (&cup, 1);
+ write_character (dtp, &cup, 1);
}
}
for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
{
cup = toupper (obj->var_name[dim_i]);
- write_character (&cup, 1);
+ write_character (dtp, &cup, 1);
}
- write_character ("=", 1);
+ write_character (dtp, "=", 1);
}
/* Counts the number of data output on a line, including names. */
if (rep_ctr > 1)
{
st_sprintf(rep_buff, " %d*", rep_ctr);
- write_character (rep_buff, strlen (rep_buff));
- no_leading_blank = 1;
+ write_character (dtp, rep_buff, strlen (rep_buff));
+ dtp->u.p.no_leading_blank = 1;
}
num++;
{
case GFC_DTYPE_INTEGER:
- write_integer (p, len);
+ write_integer (dtp, p, len);
break;
case GFC_DTYPE_LOGICAL:
- write_logical (p, len);
+ write_logical (dtp, p, len);
break;
case GFC_DTYPE_CHARACTER:
- if (nml_delim)
- write_character (nml_delim, 1);
- write_character (p, obj->string_length);
- if (nml_delim)
- write_character (nml_delim, 1);
+ if (dtp->u.p.nml_delim)
+ write_character (dtp, &dtp->u.p.nml_delim, 1);
+ write_character (dtp, p, obj->string_length);
+ if (dtp->u.p.nml_delim)
+ write_character (dtp, &dtp->u.p.nml_delim, 1);
break;
case GFC_DTYPE_REAL:
- write_real (p, len);
+ write_real (dtp, p, len);
break;
case GFC_DTYPE_COMPLEX:
- no_leading_blank = 0;
+ dtp->u.p.no_leading_blank = 0;
num++;
- write_complex (p, len, obj_size);
+ write_complex (dtp, p, len, obj_size);
break;
case GFC_DTYPE_DERIVED:
cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
cmp = retval)
{
- retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
+ retval = nml_write_obj (dtp, cmp,
+ (index_type)(p - obj->mem_pos),
obj, ext_name);
}
goto obj_loop;
default:
- internal_error ("Bad type for namelist write");
+ internal_error (&dtp->common, "Bad type for namelist write");
}
/* Reset the leading blank suppression, write a comma and, if 5
values have been output, write a newline and advance to column
2. Reset the repeat counter. */
- no_leading_blank = 0;
- write_character (",", 1);
+ dtp->u.p.no_leading_blank = 0;
+ write_character (dtp, ",", 1);
if (num > 5)
{
num = 0;
- write_character ("\n ", 2);
+ write_character (dtp, "\n ", 2);
}
rep_ctr = 1;
}
the treatment of derived types. */
void
-namelist_write (void)
+namelist_write (st_parameter_dt *dtp)
{
namelist_info * t1, *t2, *dummy = NULL;
index_type i;
/* Set the delimiter for namelist output. */
- tmp_delim = current_unit->flags.delim;
- current_unit->flags.delim = DELIM_NONE;
+ tmp_delim = dtp->u.p.current_unit->flags.delim;
+ dtp->u.p.current_unit->flags.delim = DELIM_NONE;
switch (tmp_delim)
{
case (DELIM_QUOTE):
- nml_delim = "\"";
+ dtp->u.p.nml_delim = '"';
break;
case (DELIM_APOSTROPHE):
- nml_delim = "'";
+ dtp->u.p.nml_delim = '\'';
break;
default:
- nml_delim = NULL;
+ dtp->u.p.nml_delim = '\0';
+ break;
}
- write_character ("&",1);
+ write_character (dtp, "&", 1);
/* Write namelist name in upper case - f95 std. */
- for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
+ for (i = 0 ;i < dtp->namelist_name_len ;i++ )
{
- c = toupper (ioparm.namelist_name[i]);
- write_character (&c ,1);
- }
+ c = toupper (dtp->namelist_name[i]);
+ write_character (dtp, &c ,1);
+ }
- if (ionml != NULL)
+ if (dtp->u.p.ionml != NULL)
{
- t1 = ionml;
+ t1 = dtp->u.p.ionml;
while (t1 != NULL)
{
t2 = t1;
- t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
+ t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
}
}
- write_character (" /\n", 4);
+ write_character (dtp, " /\n", 4);
/* Recover the original delimiter. */
- current_unit->flags.delim = tmp_delim;
+ dtp->u.p.current_unit->flags.delim = tmp_delim;
}
#undef NML_DIGITS
extern void stupid_function_name_for_static_linking (void);
internal_proto(stupid_function_name_for_static_linking);
-extern void library_start (void);
+struct st_parameter_common;
+extern void library_start (struct st_parameter_common *);
internal_proto(library_start);
-extern void library_end (void);
-internal_proto(library_end);
+#define library_end()
extern void set_args (int, char **);
export_proto(set_args);
extern void os_error (const char *) __attribute__ ((noreturn));
internal_proto(os_error);
-extern void show_locus (void);
+extern void show_locus (struct st_parameter_common *);
internal_proto(show_locus);
extern void runtime_error (const char *) __attribute__ ((noreturn));
iexport_proto(runtime_error);
-extern void internal_error (const char *) __attribute__ ((noreturn));
+extern void internal_error (struct st_parameter_common *, const char *)
+ __attribute__ ((noreturn));
internal_proto(internal_error);
extern const char *get_oserror (void);
extern const char *translate_error (int);
internal_proto(translate_error);
-extern void generate_error (int, const char *);
+extern void generate_error (struct st_parameter_common *, int, const char *);
internal_proto(generate_error);
/* fpu.c */
/* string.c */
-extern int find_option (const char *, int, const st_option *, const char *);
+extern int find_option (struct st_parameter_common *, const char *, int,
+ const st_option *, const char *);
internal_proto(find_option);
extern int fstrlen (const char *, int);
# This is a separate file so that version updates don't involve re-running
# automake.
# CURRENT:REVISION:AGE
-0:0:0
+1:0:0
#include "libgfortran.h"
#include "../io/io.h"
+#include "../io/unix.h"
/* Error conditions. The tricky part here is printing a message when
* it is the I/O subsystem that is severely wounded. Our goal is to
* Other error returns are reserved for the STOP statement with a numeric code.
*/
-/* locus variables. These are optionally set by a caller before a
- * library subroutine is called. They are always cleared on exit so
- * that files that report loci and those that do not can be linked
- * together without reporting an erroneous position. */
-
-char *filename = 0;
-iexport_data(filename);
-
-unsigned line = 0;
-iexport_data(line);
-
/* gfc_itoa()-- Integer to decimal conversion. */
const char *
const char *q;
stream *s;
char itoa_buf[GFC_ITOA_BUF_SIZE];
+ unix_stream err_stream;
total = 0;
- s = init_error_stream ();
+ s = init_error_stream (&err_stream);
va_start (arg, format);
for (;;)
* something went wrong */
void
-show_locus (void)
+show_locus (st_parameter_common *cmp)
{
- if (!options.locus || filename == NULL)
+ if (!options.locus || cmp == NULL || cmp->filename == NULL)
return;
- st_printf ("At line %d of file %s\n", line, filename);
+ st_printf ("At line %d of file %s\n", cmp->line, cmp->filename);
}
os_error (const char *message)
{
recursion_check ();
- show_locus ();
st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
sys_exit (1);
}
runtime_error (const char *message)
{
recursion_check ();
- show_locus ();
st_printf ("Fortran runtime error: %s\n", message);
sys_exit (2);
}
* that indicate something deeply wrong. */
void
-internal_error (const char *message)
+internal_error (st_parameter_common *cmp, const char *message)
{
recursion_check ();
- show_locus ();
+ show_locus (cmp);
st_printf ("Internal Error: %s\n", message);
/* This function call is here to get the main.o object file included
* the most recent operating system error is used. */
void
-generate_error (int family, const char *message)
+generate_error (st_parameter_common *cmp, int family, const char *message)
{
/* Set the error status. */
- if (ioparm.iostat != NULL)
- *ioparm.iostat = family;
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
+ *cmp->iostat = family;
if (message == NULL)
message =
(family == ERROR_OS) ? get_oserror () : translate_error (family);
- if (ioparm.iomsg)
- cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
+ if (cmp->flags & IOPARM_HAS_IOMSG)
+ cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
/* Report status back to the compiler. */
+ cmp->flags &= ~IOPARM_LIBRETURN_MASK;
switch (family)
{
case ERROR_EOR:
- ioparm.library_return = LIBRARY_EOR;
- if (ioparm.eor != 0)
+ cmp->flags |= IOPARM_LIBRETURN_EOR;
+ if ((cmp->flags & IOPARM_EOR))
return;
break;
case ERROR_END:
- ioparm.library_return = LIBRARY_END;
- if (ioparm.end != 0)
+ cmp->flags |= IOPARM_LIBRETURN_END;
+ if ((cmp->flags & IOPARM_END))
return;
break;
default:
- ioparm.library_return = LIBRARY_ERROR;
- if (ioparm.err != 0)
+ cmp->flags |= IOPARM_LIBRETURN_ERROR;
+ if ((cmp->flags & IOPARM_ERR))
return;
break;
}
/* Return if the user supplied an iostat variable. */
- if (ioparm.iostat != NULL)
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
return;
/* Terminate the program */
- runtime_error (message);
+ recursion_check ();
+ show_locus (cmp);
+ st_printf ("Fortran runtime error: %s\n", message);
+ sys_exit (2);
}
if ((compile_options.allow_std & std) != 0 && !warning)
return SUCCESS;
- show_locus ();
if (!warning)
{
st_printf ("Fortran runtime error: %s\n", message);
-/* This is needed for fpu-glibc.h, before all other includes */
-#ifdef HAVE_FENV_H
-#define _GNU_SOURCE
-#endif
-
#include "libgfortran.h"
/* We include the platform-dependent code. */
/* Implementation of the STOP statement.
- Copyright 2002 Free Software Foundation, Inc.
+ Copyright 2002, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
void
pause_numeric (GFC_INTEGER_4 code)
{
- show_locus ();
-
if (code == -1)
st_printf ("PAUSE\n");
else
void
pause_string (char *string, GFC_INTEGER_4 len)
{
- show_locus ();
-
st_printf ("PAUSE ");
while (len--)
st_printf ("%c", *(string++));
/* Implementation of the STOP statement.
- Copyright 2002 Free Software Foundation, Inc.
+ Copyright 2002, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
void
stop_numeric (GFC_INTEGER_4 code)
{
- show_locus ();
-
if (code == -1)
code = 0;
else
void
stop_string (const char *string, GFC_INTEGER_4 len)
{
- show_locus ();
-
st_printf ("STOP ");
while (len--)
st_printf ("%c", *(string++));
#include <string.h>
#include "libgfortran.h"
-
+#include "../io/io.h"
/* Compare a C-style string with a fortran style string in a case-insensitive
manner. Used for decoding string options to various statements. Returns
if no default is provided. */
int
-find_option (const char *s1, int s1_len, const st_option * opts,
- const char *error_message)
+find_option (st_parameter_common *cmp, const char *s1, int s1_len,
+ const st_option * opts, const char *error_message)
{
for (; opts->name; opts++)
if (compare0 (s1, s1_len, opts->name))
return opts->value;
- generate_error (ERROR_BAD_OPTION, error_message);
+ generate_error (cmp, ERROR_BAD_OPTION, error_message);
return -1;
}
OSDN Git Service
