MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/31675 (Fortran front-end and libgfortran should have a common header file)

Browse Source 
PR fortran/31675

	* libgfortran.h: New file.
	* iso-fortran-env.def: Use macros in the new header instead of
	hardcoded integer constants.
	* Make-lang.in (F95_PARSER_OBJS, GFORTRAN_TRANS_DEPS): Add
	fortran/libgfortran.h.
	* gfortran.h (GFC_STD_*, GFC_FPE_*, options_convert,
	ioerror_codes): Remove.
	* trans.c (ERROR_ALLOCATION): Remove.
	(gfc_call_malloc, gfc_allocate_with_status,
	gfc_allocate_array_with_status): Use LIBERROR_ALLOCATION.
	* trans-types.h (GFC_DTYPE_*): Remove.
	* trans-decl.c (gfc_generate_function_code): Use
	GFC_CONVERT_NATIVE instead of CONVERT_NATIVE.
	* trans-io.c (set_parameter_value, set_parameter_ref): Use
	LIBERROR_* macros instead of IOERROR_ macros.
	* trans-intrinsic.c (gfc_conv_intrinsic_function): Use
	LIBERROR_END and LIBERROR_EOR instead of hardcoded constants.
	* options.c (gfc_init_options): Use GFC_CONVERT_NATIVE instead of
	CONVERT_NATIVE.
	(gfc_handle_option): Use GFC_CONVERT_* macros instead of CONVERT_*.

	* libgfortran.h: Include gcc/fortran/libgfortran.h.
	Remove M_PI, GFC_MAX_DIMENSIONS, GFC_DTYPE_*, GFC_NUM_RANK_BITS,
	error_codes, GFC_STD_*, GFC_FPE_* and unit_convert.
	* runtime/environ.c (variable_table): Use GFC_*_UNIT_NUMBER instead
	of hardcoded constants.
	(do_parse, init_unformatted): Use GFC_CONVERT_* macros instead of
	CONVERT_*.
	* runtime/string.c (find_option): Use LIBERROR_BAD_OPTION instead
	of ERROR_BAD_OPTION.
	* runtime/error.c (translate_error, generate_error): Use
	LIBERROR_* macros instead of ERROR_*.
	* io/file_pos.c (formatted_backspace, unformatted_backspace,
	st_backspace, st_rewind, st_flush): Rename macros.
	* io/open.c (convert_opt, edit_modes, new_unit, already_open,
	st_open): Likewise.
	* io/close.c (st_close): Likewise.
	* io/list_read.c (next_char, convert_integer, parse_repeat,
	read_logical, read_integer, read_character, parse_real,
	check_type, list_formatted_read_scalar, namelist_read,
	nml_err_ret): Likewise.
	* io/read.c (convert_real, read_l, read_decimal, read_radix,
	read_f): Likewise.
	* io/inquire.c (inquire_via_unit): Likewise.
	* io/unit.c (get_internal_unit): Likewise.
	* io/transfer.c (read_sf, read_block, read_block_direct,
	write_block, write_buf, unformatted_read, unformatted_write,
	formatted_transfer_scalar, us_read, us_write, data_transfer_init,
	skip_record, next_record_r, write_us_marker, next_record_w_unf,
	next_record_w, finalize_transfer, st_read, st_write_done):
	Likewise.
	* io/format.c (format_error): Likewise.

From-SVN: r128050
This commit is contained in:
Francois-Xavier Coudert 2007-09-03 16:44:15 +00:00 committed by François-Xavier Coudert
parent 4392a547f5
commit d74b97cc7e
25 changed files with 400 additions and 398 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/fortran/ChangeLog
View File

@ -1,3 +1,27 @@
2007-09-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31675
* libgfortran.h: New file.
* iso-fortran-env.def: Use macros in the new header instead of
hardcoded integer constants.
* Make-lang.in (F95_PARSER_OBJS, GFORTRAN_TRANS_DEPS): Add
fortran/libgfortran.h.
* gfortran.h (GFC_STD_*, GFC_FPE_*, options_convert,
ioerror_codes): Remove.
* trans.c (ERROR_ALLOCATION): Remove.
(gfc_call_malloc, gfc_allocate_with_status,
gfc_allocate_array_with_status): Use LIBERROR_ALLOCATION.
* trans-types.h (GFC_DTYPE_*): Remove.
* trans-decl.c (gfc_generate_function_code): Use
GFC_CONVERT_NATIVE instead of CONVERT_NATIVE.
* trans-io.c (set_parameter_value, set_parameter_ref): Use
LIBERROR_* macros instead of IOERROR_ macros.
* trans-intrinsic.c (gfc_conv_intrinsic_function): Use
LIBERROR_END and LIBERROR_EOR instead of hardcoded constants.
* options.c (gfc_init_options): Use GFC_CONVERT_NATIVE instead of
CONVERT_NATIVE.
(gfc_handle_option): Use GFC_CONVERT_* macros instead of CONVERT_*.
2007-09-02 Steven G. Kargl <kargl@gcc.gnu.org> 2007-09-02 Steven G. Kargl <kargl@gcc.gnu.org>
* invoke.texi: Fix the -frange-checking option entry. * invoke.texi: Fix the -frange-checking option entry.

6
gcc/fortran/Make-lang.in
View File

@ -289,14 +289,16 @@ fortran.stagefeedback: stageprofile-start
# which objects depend on what. FIXME # which objects depend on what. FIXME
# TODO: Add dependencies on the backend/tree header files # TODO: Add dependencies on the backend/tree header files
$(F95_PARSER_OBJS): fortran/gfortran.h fortran/intrinsic.h fortran/match.h \ $(F95_PARSER_OBJS): fortran/gfortran.h fortran/libgfortran.h \
fortran/intrinsic.h fortran/match.h \
fortran/parse.h fortran/arith.h fortran/target-memory.h \ fortran/parse.h fortran/arith.h fortran/target-memory.h \
$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \ $(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \ $(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
$(FLAGS_H) output.h $(DIAGNOSTIC_H) errors.h $(FUNCTION_H) $(FLAGS_H) output.h $(DIAGNOSTIC_H) errors.h $(FUNCTION_H)
fortran/openmp.o: pointer-set.h $(TARGET_H) toplev.h fortran/openmp.o: pointer-set.h $(TARGET_H) toplev.h
GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/intrinsic.h fortran/trans-array.h \ GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/libgfortran.h \
fortran/intrinsic.h fortran/trans-array.h \
fortran/trans-const.h fortran/trans-const.h fortran/trans.h \ fortran/trans-const.h fortran/trans-const.h fortran/trans.h \
fortran/trans-stmt.h fortran/trans-types.h \ fortran/trans-stmt.h fortran/trans-types.h \
$(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h $(GGC_H) $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h $(GGC_H)

65
gcc/fortran/gfortran.h
View File

@ -28,6 +28,11 @@ along with GCC; see the file COPYING3. If not see
multiple header files. Besides, Microsoft's winnt.h was 250k last multiple header files. Besides, Microsoft's winnt.h was 250k last
time I looked, so by comparison this is perfectly reasonable. */ time I looked, so by comparison this is perfectly reasonable. */
/* Declarations common to the front-end and library are put in
libgfortran/libgfortran_frontend.h */
#include "libgfortran.h"
#include "system.h" #include "system.h"
#include "intl.h" #include "intl.h"
#include "coretypes.h" #include "coretypes.h"
@ -57,7 +62,6 @@ char *alloca ();
#define GFC_MAX_SYMBOL_LEN 63 /* Must be at least 63 for F2003. */ #define GFC_MAX_SYMBOL_LEN 63 /* Must be at least 63 for F2003. */
#define GFC_MAX_BINDING_LABEL_LEN 126 /* (2 * GFC_MAX_SYMBOL_LEN) */ #define GFC_MAX_BINDING_LABEL_LEN 126 /* (2 * GFC_MAX_SYMBOL_LEN) */
#define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */ #define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */
#define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */
#define GFC_LETTERS 26 /* Number of letters in the alphabet. */ #define GFC_LETTERS 26 /* Number of letters in the alphabet. */
#define MAX_SUBRECORD_LENGTH 2147483639 /* 2**31-9 */ #define MAX_SUBRECORD_LENGTH 2147483639 /* 2**31-9 */
@ -96,33 +100,6 @@ typedef struct
mstring; mstring;
/* Flags to specify which standard/extension contains a feature. */
#define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */
#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */
#define GFC_STD_F2003 (1<<4) /* New in F2003. */
/* Note that no additional features were deleted or made obsolescent
in F2003. */
#define GFC_STD_F95 (1<<3) /* New in F95. */
#define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */
#define GFC_STD_F95_OBS (1<<1) /* Obsolescent in F95. */
#define GFC_STD_F77 (1<<0) /* Included in F77, but not
deleted or obsolescent in
later standards. */
/* Bitmasks for the various FPE that can be enabled. */
#define GFC_FPE_INVALID (1<<0)
#define GFC_FPE_DENORMAL (1<<1)
#define GFC_FPE_ZERO (1<<2)
#define GFC_FPE_OVERFLOW (1<<3)
#define GFC_FPE_UNDERFLOW (1<<4)
#define GFC_FPE_PRECISION (1<<5)
/* Keep this in sync with libgfortran/io/io.h ! */
typedef enum
{ CONVERT_NATIVE=0, CONVERT_SWAP, CONVERT_BIG, CONVERT_LITTLE }
options_convert;
/*************************** Enums *****************************/ /*************************** Enums *****************************/
@ -532,38 +509,6 @@ enum gfc_isym_id
}; };
typedef enum gfc_isym_id gfc_isym_id; typedef enum gfc_isym_id gfc_isym_id;
/* Runtime errors. The EOR and EOF errors are required to be negative.
These codes must be kept synchronized with their equivalents in
libgfortran/libgfortran.h . */
typedef enum
{
IOERROR_FIRST = -3, /* Marker for the first error. */
IOERROR_EOR = -2,
IOERROR_END = -1,
IOERROR_OK = 0, /* Indicates success, must be zero. */
IOERROR_OS = 5000, /* Operating system error, more info in errno. */
IOERROR_OPTION_CONFLICT,
IOERROR_BAD_OPTION,
IOERROR_MISSING_OPTION,
IOERROR_ALREADY_OPEN,
IOERROR_BAD_UNIT,
IOERROR_FORMAT,
IOERROR_BAD_ACTION,
IOERROR_ENDFILE,
IOERROR_BAD_US,
IOERROR_READ_VALUE,
IOERROR_READ_OVERFLOW,
IOERROR_INTERNAL,
IOERROR_INTERNAL_UNIT,
IOERROR_ALLOCATION,
IOERROR_DIRECT_EOR,
IOERROR_SHORT_RECORD,
IOERROR_CORRUPT_FILE,
IOERROR_LAST /* Not a real error, the last error # + 1. */
}
ioerror_codes;
/************************* Structures *****************************/ /************************* Structures *****************************/

10
gcc/fortran/iso-fortran-env.def
View File

@ -26,11 +26,11 @@ along with GCC; see the file COPYING3. If not see
NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \ NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \
gfc_character_storage_size) gfc_character_storage_size)
NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", 0) NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER)
NAMED_INTCST (ISOFORTRANENV_FILE_STORAGE_SIZE, "file_storage_size", 8) NAMED_INTCST (ISOFORTRANENV_FILE_STORAGE_SIZE, "file_storage_size", 8)
NAMED_INTCST (ISOFORTRANENV_INPUT_UNIT, "input_unit", 5) NAMED_INTCST (ISOFORTRANENV_INPUT_UNIT, "input_unit", GFC_STDIN_UNIT_NUMBER)
NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", -1) NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", LIBERROR_END)
NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", -2) NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", LIBERROR_EOR)
NAMED_INTCST (ISOFORTRANENV_NUMERIC_STORAGE_SIZE, "numeric_storage_size", \ NAMED_INTCST (ISOFORTRANENV_NUMERIC_STORAGE_SIZE, "numeric_storage_size", \
gfc_numeric_storage_size) gfc_numeric_storage_size)
NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", 6) NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", GFC_STDOUT_UNIT_NUMBER)

108
gcc/fortran/libgfortran.h Normal file
View File

@ -0,0 +1,108 @@
/* Header file to the Fortran front-end and runtime library
Copyright (C) 2007 Free Software Foundation, Inc.
This file is part of GCC.
GCC 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 3, or (at your option) any later
version.
GCC 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 GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* Flags to specify which standard/extension contains a feature.
Note that no features were obsoleted nor deleted in F2003. */
#define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */
#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */
#define GFC_STD_F2003 (1<<4) /* New in F2003. */
#define GFC_STD_F95 (1<<3) /* New in F95. */
#define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */
#define GFC_STD_F95_OBS (1<<1) /* Obsolescent in F95. */
#define GFC_STD_F77 (1<<0) /* Included in F77, but not deleted or
obsolescent in later standards. */
/* Bitmasks for the various FPE that can be enabled. */
#define GFC_FPE_INVALID (1<<0)
#define GFC_FPE_DENORMAL (1<<1)
#define GFC_FPE_ZERO (1<<2)
#define GFC_FPE_OVERFLOW (1<<3)
#define GFC_FPE_UNDERFLOW (1<<4)
#define GFC_FPE_PRECISION (1<<5)
/* Possible values for the CONVERT I/O specifier. */
typedef enum
{
GFC_CONVERT_NONE = -1,
GFC_CONVERT_NATIVE = 0,
GFC_CONVERT_SWAP,
GFC_CONVERT_BIG,
GFC_CONVERT_LITTLE
}
unit_convert;
/* Runtime errors. */
typedef enum
{
LIBERROR_FIRST = -3, /* Marker for the first error. */
LIBERROR_EOR = -2, /* End of record, must be negative. */
LIBERROR_END = -1, /* End of file, must be negative. */
LIBERROR_OK = 0, /* Indicates success, must be zero. */
LIBERROR_OS = 5000, /* OS error, more info in errno. */
LIBERROR_OPTION_CONFLICT,
LIBERROR_BAD_OPTION,
LIBERROR_MISSING_OPTION,
LIBERROR_ALREADY_OPEN,
LIBERROR_BAD_UNIT,
LIBERROR_FORMAT,
LIBERROR_BAD_ACTION,
LIBERROR_ENDFILE,
LIBERROR_BAD_US,
LIBERROR_READ_VALUE,
LIBERROR_READ_OVERFLOW,
LIBERROR_INTERNAL,
LIBERROR_INTERNAL_UNIT,
LIBERROR_ALLOCATION,
LIBERROR_DIRECT_EOR,
LIBERROR_SHORT_RECORD,
LIBERROR_CORRUPT_FILE,
LIBERROR_LAST /* Not a real error, the last error # + 1. */
}
libgfortran_error_codes;
/* Default unit number for preconnected standard input and output. */
#define GFC_STDIN_UNIT_NUMBER 5
#define GFC_STDOUT_UNIT_NUMBER 6
#define GFC_STDERR_UNIT_NUMBER 0
#define GFC_MAX_DIMENSIONS 7
#define GFC_DTYPE_RANK_MASK 0x07
#define GFC_DTYPE_TYPE_SHIFT 3
#define GFC_DTYPE_TYPE_MASK 0x38
#define GFC_DTYPE_SIZE_SHIFT 6
enum
{
GFC_DTYPE_UNKNOWN = 0,
GFC_DTYPE_INTEGER,
/* TODO: recognize logical types. */
GFC_DTYPE_LOGICAL,
GFC_DTYPE_REAL,
GFC_DTYPE_COMPLEX,
GFC_DTYPE_DERIVED,
GFC_DTYPE_CHARACTER
};

10
gcc/fortran/options.c
View File

@ -62,7 +62,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.max_continue_free = 39; gfc_option.max_continue_free = 39;
gfc_option.max_identifier_length = GFC_MAX_SYMBOL_LEN; gfc_option.max_identifier_length = GFC_MAX_SYMBOL_LEN;
gfc_option.max_subrecord_length = 0; gfc_option.max_subrecord_length = 0;
gfc_option.convert = CONVERT_NATIVE; gfc_option.convert = GFC_CONVERT_NATIVE;
gfc_option.record_marker = 0; gfc_option.record_marker = 0;
gfc_option.verbose = 0; gfc_option.verbose = 0;
@ -704,19 +704,19 @@ gfc_handle_option (size_t scode, const char *arg, int value)
break; break;
case OPT_fconvert_little_endian: case OPT_fconvert_little_endian:
gfc_option.convert = CONVERT_LITTLE; gfc_option.convert = GFC_CONVERT_LITTLE;
break; break;
case OPT_fconvert_big_endian: case OPT_fconvert_big_endian:
gfc_option.convert = CONVERT_BIG; gfc_option.convert = GFC_CONVERT_BIG;
break; break;
case OPT_fconvert_native: case OPT_fconvert_native:
gfc_option.convert = CONVERT_NATIVE; gfc_option.convert = GFC_CONVERT_NATIVE;
break; break;
case OPT_fconvert_swap: case OPT_fconvert_swap:
gfc_option.convert = CONVERT_SWAP; gfc_option.convert = GFC_CONVERT_SWAP;
break; break;
case OPT_frecord_marker_4: case OPT_frecord_marker_4:

2
gcc/fortran/trans-decl.c
View File

@ -3212,7 +3212,7 @@ gfc_generate_function_code (gfc_namespace * ns)
/* If this is the main program and an -fconvert option was provided, /* If this is the main program and an -fconvert option was provided,
add a call to set_convert. */ add a call to set_convert. */
if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE) if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
{ {
tmp = build_call_expr (gfor_fndecl_set_convert, 1, tmp = build_call_expr (gfor_fndecl_set_convert, 1,
build_int_cst (integer_type_node, build_int_cst (integer_type_node,

4
gcc/fortran/trans-intrinsic.c
View File

@ -3928,11 +3928,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break; break;
case GFC_ISYM_IS_IOSTAT_END: case GFC_ISYM_IS_IOSTAT_END:
gfc_conv_has_intvalue (se, expr, -1); gfc_conv_has_intvalue (se, expr, LIBERROR_END);
break; break;
case GFC_ISYM_IS_IOSTAT_EOR: case GFC_ISYM_IS_IOSTAT_EOR:
gfc_conv_has_intvalue (se, expr, -2); gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
break; break;
case GFC_ISYM_ISNAN: case GFC_ISYM_ISNAN:

27
gcc/fortran/trans-io.c
View File

@ -457,18 +457,15 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
if (type == IOPARM_common_unit && e->ts.kind != 4) if (type == IOPARM_common_unit && e->ts.kind != 4)
{ {
tree cond, max; tree cond, max;
ioerror_codes bad_unit;
int i; int i;
bad_unit = IOERROR_BAD_UNIT;
/* Don't evaluate the UNIT number multiple times. */ /* Don't evaluate the UNIT number multiple times. */
se.expr = gfc_evaluate_now (se.expr, &se.pre); se.expr = gfc_evaluate_now (se.expr, &se.pre);
/* UNIT numbers should be nonnegative. */ /* UNIT numbers should be nonnegative. */
cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr, cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
build_int_cst (TREE_TYPE (se.expr),0)); build_int_cst (TREE_TYPE (se.expr),0));
gfc_trans_io_runtime_check (cond, var, bad_unit, gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
"Negative unit number in I/O statement", "Negative unit number in I/O statement",
&se.pre); &se.pre);
@ -477,7 +474,7 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr, cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
fold_convert (TREE_TYPE (se.expr), max)); fold_convert (TREE_TYPE (se.expr), max));
gfc_trans_io_runtime_check (cond, var, bad_unit, gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
"Unit number in I/O statement too large", "Unit number in I/O statement too large",
&se.pre); &se.pre);
@ -519,14 +516,10 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (se.expr)); addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (se.expr));
/* If this is for the iostat variable initialize the /* If this is for the iostat variable initialize the
user variable to IOERROR_OK which is zero. */ user variable to LIBERROR_OK which is zero. */
if (type == IOPARM_common_iostat) if (type == IOPARM_common_iostat)
{ gfc_add_modify_expr (block, se.expr,
ioerror_codes ok; build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
ok = IOERROR_OK;
gfc_add_modify_expr (block, se.expr,
build_int_cst (TREE_TYPE (se.expr), ok));
}
} }
else else
{ {
@ -537,14 +530,10 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
st_parameter_field[type].name); st_parameter_field[type].name);
/* If this is for the iostat variable, initialize the /* If this is for the iostat variable, initialize the
user variable to IOERROR_OK which is zero. */ user variable to LIBERROR_OK which is zero. */
if (type == IOPARM_common_iostat) if (type == IOPARM_common_iostat)
{ gfc_add_modify_expr (block, tmpvar,
ioerror_codes ok; build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
ok = IOERROR_OK;
gfc_add_modify_expr (block, tmpvar,
build_int_cst (TREE_TYPE (tmpvar), ok));
}
addr = build_fold_addr_expr (tmpvar); addr = build_fold_addr_expr (tmpvar);
/* After the I/O operation, we set the variable from the temporary. */ /* After the I/O operation, we set the variable from the temporary. */

16
gcc/fortran/trans-types.h
View File

@ -24,22 +24,6 @@ along with GCC; see the file COPYING3. If not see
#ifndef GFC_BACKEND_H #ifndef GFC_BACKEND_H
#define GFC_BACKEND_H #define GFC_BACKEND_H
#define GFC_DTYPE_RANK_MASK 0x07
#define GFC_DTYPE_TYPE_SHIFT 3
#define GFC_DTYPE_TYPE_MASK 0x38
#define GFC_DTYPE_SIZE_SHIFT 6
enum
{
GFC_DTYPE_UNKNOWN = 0,
GFC_DTYPE_INTEGER,
GFC_DTYPE_LOGICAL,
GFC_DTYPE_REAL,
GFC_DTYPE_COMPLEX,
GFC_DTYPE_DERIVED,
GFC_DTYPE_CHARACTER
};
extern GTY(()) tree gfc_array_index_type; extern GTY(()) tree gfc_array_index_type;
extern GTY(()) tree gfc_array_range_type; extern GTY(()) tree gfc_array_range_type;
extern GTY(()) tree gfc_character1_type_node; extern GTY(()) tree gfc_character1_type_node;

17
gcc/fortran/trans.c
View File

@ -473,11 +473,6 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
return res; return res;
} }
/* The status variable of allocate statement is set to ERROR_ALLOCATION
when the allocation wasn't successful. This value needs to be kept in
sync with libgfortran/libgfortran.h. */
#define ERROR_ALLOCATION 5014
/* Allocate memory, using an optional status argument. /* Allocate memory, using an optional status argument.
This function follows the following pseudo-code: This function follows the following pseudo-code:
@ -495,7 +490,7 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
{ {
if (stat) if (stat)
{ {
*stat = ERROR_ALLOCATION; *stat = LIBERROR_ALLOCATION;
newmem = NULL; newmem = NULL;
} }
else else
@ -508,7 +503,7 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
if (newmem == NULL) if (newmem == NULL)
{ {
if (stat) if (stat)
*stat = ERROR_ALLOCATION; *stat = LIBERROR_ALLOCATION;
else else
runtime_error ("Out of memory"); runtime_error ("Out of memory");
} }
@ -558,7 +553,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
gfc_start_block (&set_status_block); gfc_start_block (&set_status_block);
gfc_add_modify_expr (&set_status_block, gfc_add_modify_expr (&set_status_block,
build1 (INDIRECT_REF, status_type, status), build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, ERROR_ALLOCATION)); build_int_cst (status_type, LIBERROR_ALLOCATION));
gfc_add_modify_expr (&set_status_block, res, gfc_add_modify_expr (&set_status_block, res,
build_int_cst (pvoid_type_node, 0)); build_int_cst (pvoid_type_node, 0));
@ -589,7 +584,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
build_int_cst (status_type, 0)); build_int_cst (status_type, 0));
tmp2 = fold_build2 (MODIFY_EXPR, status_type, tmp2 = fold_build2 (MODIFY_EXPR, status_type,
build1 (INDIRECT_REF, status_type, status), build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, ERROR_ALLOCATION)); build_int_cst (status_type, LIBERROR_ALLOCATION));
tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
tmp2); tmp2);
} }
@ -627,7 +622,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
{ {
free (mem); free (mem);
mem = allocate (size, stat); mem = allocate (size, stat);
*stat = ERROR_ALLOCATION; *stat = LIBERROR_ALLOCATION;
return mem; return mem;
} }
else else
@ -675,7 +670,7 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
gfc_add_modify_expr (&set_status_block, gfc_add_modify_expr (&set_status_block,
build1 (INDIRECT_REF, status_type, status), build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, ERROR_ALLOCATION)); build_int_cst (status_type, LIBERROR_ALLOCATION));
tmp = fold_build2 (EQ_EXPR, boolean_type_node, status, tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
build_int_cst (status_type, 0)); build_int_cst (status_type, 0));

35
libgfortran/ChangeLog
View File

@ -1,3 +1,38 @@
2007-09-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31675
* libgfortran.h: Include gcc/fortran/libgfortran.h.
Remove M_PI, GFC_MAX_DIMENSIONS, GFC_DTYPE_*, GFC_NUM_RANK_BITS,
error_codes, GFC_STD_*, GFC_FPE_* and unit_convert.
* runtime/environ.c (variable_table): Use GFC_*_UNIT_NUMBER instead
of hardcoded constants.
(do_parse, init_unformatted): Use GFC_CONVERT_* macros instead of
CONVERT_*.
* runtime/string.c (find_option): Use LIBERROR_BAD_OPTION instead
of ERROR_BAD_OPTION.
* runtime/error.c (translate_error, generate_error): Use
LIBERROR_* macros instead of ERROR_*.
* io/file_pos.c (formatted_backspace, unformatted_backspace,
st_backspace, st_rewind, st_flush): Rename macros.
* io/open.c (convert_opt, edit_modes, new_unit, already_open,
st_open): Likewise.
* io/close.c (st_close): Likewise.
* io/list_read.c (next_char, convert_integer, parse_repeat,
read_logical, read_integer, read_character, parse_real,
check_type, list_formatted_read_scalar, namelist_read,
nml_err_ret): Likewise.
* io/read.c (convert_real, read_l, read_decimal, read_radix,
read_f): Likewise.
* io/inquire.c (inquire_via_unit): Likewise.
* io/unit.c (get_internal_unit): Likewise.
* io/transfer.c (read_sf, read_block, read_block_direct,
write_block, write_buf, unformatted_read, unformatted_write,
formatted_transfer_scalar, us_read, us_write, data_transfer_init,
skip_record, next_record_r, write_us_marker, next_record_w_unf,
next_record_w, finalize_transfer, st_read, st_write_done):
Likewise.
* io/format.c (format_error): Likewise.
2007-08-31 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> 2007-08-31 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* m4/minloc1.m4: Update copyright year and ajust headers order. * m4/minloc1.m4: Update copyright year and ajust headers order.

2
libgfortran/io/close.c
View File

@ -73,7 +73,7 @@ st_close (st_parameter_close *clp)
if (u->flags.status == STATUS_SCRATCH) if (u->flags.status == STATUS_SCRATCH)
{ {
if (status == CLOSE_KEEP) if (status == CLOSE_KEEP)
generate_error (&clp->common, ERROR_BAD_OPTION, generate_error (&clp->common, LIBERROR_BAD_OPTION,
"Can't KEEP a scratch file on CLOSE"); "Can't KEEP a scratch file on CLOSE");
#if !HAVE_UNLINK_OPEN_FILE #if !HAVE_UNLINK_OPEN_FILE
path = (char *) gfc_alloca (u->file_len + 1); path = (char *) gfc_alloca (u->file_len + 1);

16
libgfortran/io/file_pos.c
View File

@ -90,7 +90,7 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
return; return;
io_error: io_error:
generate_error (&fpp->common, ERROR_OS, NULL); generate_error (&fpp->common, LIBERROR_OS, NULL);
} }
@ -122,8 +122,8 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
if (p == NULL || length_read != length) if (p == NULL || length_read != length)
goto io_error; goto io_error;
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
if (u->flags.convert == CONVERT_NATIVE) if (u->flags.convert == GFC_CONVERT_NATIVE)
{ {
switch (length) switch (length)
{ {
@ -178,7 +178,7 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
return; return;
io_error: io_error:
generate_error (&fpp->common, ERROR_OS, NULL); generate_error (&fpp->common, LIBERROR_OS, NULL);
} }
@ -195,7 +195,7 @@ st_backspace (st_parameter_filepos *fpp)
u = find_unit (fpp->common.unit); u = find_unit (fpp->common.unit);
if (u == NULL) if (u == NULL)
{ {
generate_error (&fpp->common, ERROR_BAD_UNIT, NULL); generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
goto done; goto done;
} }
@ -296,7 +296,7 @@ st_rewind (st_parameter_filepos *fpp)
if (u != NULL) if (u != NULL)
{ {
if (u->flags.access == ACCESS_DIRECT) if (u->flags.access == ACCESS_DIRECT)
generate_error (&fpp->common, ERROR_BAD_OPTION, generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access"); "Cannot REWIND a file opened for DIRECT access");
else else
{ {
@ -312,7 +312,7 @@ st_rewind (st_parameter_filepos *fpp)
u->last_record = 0; u->last_record = 0;
if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE) if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE)
generate_error (&fpp->common, ERROR_OS, NULL); generate_error (&fpp->common, LIBERROR_OS, NULL);
/* Handle special files like /dev/null differently. */ /* Handle special files like /dev/null differently. */
if (!is_special (u->s)) if (!is_special (u->s))
@ -359,7 +359,7 @@ st_flush (st_parameter_filepos *fpp)
} }
else else
/* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
generate_error (&fpp->common, ERROR_BAD_OPTION, generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Specified UNIT in FLUSH is not connected"); "Specified UNIT in FLUSH is not connected");
library_end (); library_end ();

2
libgfortran/io/format.c
View File

@ -942,7 +942,7 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
*p++ = '^'; *p++ = '^';
*p = '\0'; *p = '\0';
generate_error (&dtp->common, ERROR_FORMAT, buffer); generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
} }

4
libgfortran/io/inquire.c
View File

@ -302,11 +302,11 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
switch (u->flags.convert) switch (u->flags.convert)
{ {
/* l8_to_l4_offset is 0 for little-endian, 1 for big-endian. */ /* l8_to_l4_offset is 0 for little-endian, 1 for big-endian. */
case CONVERT_NATIVE: case GFC_CONVERT_NATIVE:
p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN"; p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
break; break;
case CONVERT_SWAP: case GFC_CONVERT_SWAP:
p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN"; p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
break; break;

36
libgfortran/io/list_read.c
View File

@ -207,7 +207,7 @@ next_char (st_parameter_dt *dtp)
check for NULL here is cautionary. */ check for NULL here is cautionary. */
if (p == NULL) if (p == NULL)
{ {
generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return '\0'; return '\0';
} }
@ -228,7 +228,7 @@ next_char (st_parameter_dt *dtp)
{ {
if (p == NULL) if (p == NULL)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return '\0'; return '\0';
} }
if (length == 0) if (length == 0)
@ -465,7 +465,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
sprintf (message, "Zero repeat count in item %d of list input", sprintf (message, "Zero repeat count in item %d of list input",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
m = 1; m = 1;
} }
} }
@ -482,7 +482,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
dtp->u.p.item_count); dtp->u.p.item_count);
free_saved (dtp); free_saved (dtp);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1; return 1;
} }
@ -529,7 +529,7 @@ parse_repeat (st_parameter_dt *dtp)
"Repeat count overflow in item %d of list input", "Repeat count overflow in item %d of list input",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1; return 1;
} }
@ -542,7 +542,7 @@ parse_repeat (st_parameter_dt *dtp)
"Zero repeat count in item %d of list input", "Zero repeat count in item %d of list input",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1; return 1;
} }
@ -563,7 +563,7 @@ parse_repeat (st_parameter_dt *dtp)
free_saved (dtp); free_saved (dtp);
sprintf (message, "Bad repeat count in item %d of list input", sprintf (message, "Bad repeat count in item %d of list input",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1; return 1;
} }
@ -708,7 +708,7 @@ read_logical (st_parameter_dt *dtp, int length)
free_saved (dtp); free_saved (dtp);
sprintf (message, "Bad logical value while reading item %d", sprintf (message, "Bad logical value while reading item %d",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return; return;
logical_done: logical_done:
@ -840,7 +840,7 @@ read_integer (st_parameter_dt *dtp, int length)
free_saved (dtp); free_saved (dtp);
sprintf (message, "Bad integer for item %d in list input", sprintf (message, "Bad integer for item %d in list input",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return; return;
@ -1004,7 +1004,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
free_saved (dtp); free_saved (dtp);
sprintf (message, "Invalid string input in item %d", sprintf (message, "Invalid string input in item %d",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
} }
} }
@ -1123,7 +1123,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
free_saved (dtp); free_saved (dtp);
sprintf (message, "Bad floating point number for item %d", sprintf (message, "Bad floating point number for item %d",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1; return 1;
} }
@ -1206,7 +1206,7 @@ eol_2:
free_saved (dtp); free_saved (dtp);
sprintf (message, "Bad complex value in item %d of list input", sprintf (message, "Bad complex value in item %d of list input",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
} }
@ -1421,7 +1421,7 @@ read_real (st_parameter_dt *dtp, int length)
free_saved (dtp); free_saved (dtp);
sprintf (message, "Bad real number in item %d of list input", sprintf (message, "Bad real number in item %d of list input",
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
} }
@ -1439,7 +1439,7 @@ check_type (st_parameter_dt *dtp, bt type, int len)
type_name (dtp->u.p.saved_type), type_name (type), type_name (dtp->u.p.saved_type), type_name (type),
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1; return 1;
} }
@ -1452,7 +1452,7 @@ check_type (st_parameter_dt *dtp, bt type, int len)
"Read kind %d %s where kind %d is required for item %d", "Read kind %d %s where kind %d is required for item %d",
dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len, dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
dtp->u.p.item_count); dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message); generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1; return 1;
} }
@ -1478,7 +1478,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
dtp->u.p.eof_jump = &eof_jump; dtp->u.p.eof_jump = &eof_jump;
if (setjmp (eof_jump)) if (setjmp (eof_jump))
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
goto cleanup; goto cleanup;
} }
@ -2550,7 +2550,7 @@ namelist_read (st_parameter_dt *dtp)
if (setjmp (eof_jump)) if (setjmp (eof_jump))
{ {
dtp->u.p.eof_jump = NULL; dtp->u.p.eof_jump = NULL;
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return; return;
} }
@ -2634,6 +2634,6 @@ nml_err_ret:
dtp->u.p.eof_jump = NULL; dtp->u.p.eof_jump = NULL;
free_saved (dtp); free_saved (dtp);
free_line (dtp); free_line (dtp);
generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg); generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
return; return;
} }

70
libgfortran/io/open.c
View File

@ -99,10 +99,10 @@ static const st_option pad_opt[] =
static const st_option convert_opt[] = static const st_option convert_opt[] =
{ {
{ "native", CONVERT_NATIVE}, { "native", GFC_CONVERT_NATIVE},
{ "swap", CONVERT_SWAP}, { "swap", GFC_CONVERT_SWAP},
{ "big_endian", CONVERT_BIG}, { "big_endian", GFC_CONVERT_BIG},
{ "little_endian", CONVERT_LITTLE}, { "little_endian", GFC_CONVERT_LITTLE},
{ NULL, 0} { NULL, 0}
}; };
@ -130,24 +130,24 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
u->flags.status != flags->status) u->flags.status != flags->status)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change STATUS parameter in OPEN statement"); "Cannot change STATUS parameter in OPEN statement");
if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access) if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change ACCESS parameter in OPEN statement"); "Cannot change ACCESS parameter in OPEN statement");
if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form) if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change FORM parameter in OPEN statement"); "Cannot change FORM parameter in OPEN statement");
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
&& opp->recl_in != u->recl) && opp->recl_in != u->recl)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change RECL parameter in OPEN statement"); "Cannot change RECL parameter in OPEN statement");
if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action) if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot change ACTION parameter in OPEN statement"); "Cannot change ACTION parameter in OPEN statement");
/* Status must be OLD if present. */ /* Status must be OLD if present. */
@ -159,24 +159,24 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
notify_std (&opp->common, GFC_STD_GNU, notify_std (&opp->common, GFC_STD_GNU,
"OPEN statement must have a STATUS of OLD or UNKNOWN"); "OPEN statement must have a STATUS of OLD or UNKNOWN");
else else
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"OPEN statement must have a STATUS of OLD or UNKNOWN"); "OPEN statement must have a STATUS of OLD or UNKNOWN");
} }
if (u->flags.form == FORM_UNFORMATTED) if (u->flags.form == FORM_UNFORMATTED)
{ {
if (flags->delim != DELIM_UNSPECIFIED) if (flags->delim != DELIM_UNSPECIFIED)
generate_error (&opp->common, ERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in " "DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement"); "OPEN statement");
if (flags->blank != BLANK_UNSPECIFIED) if (flags->blank != BLANK_UNSPECIFIED)
generate_error (&opp->common, ERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in " "BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement"); "OPEN statement");
if (flags->pad != PAD_UNSPECIFIED) if (flags->pad != PAD_UNSPECIFIED)
generate_error (&opp->common, ERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in " "PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement"); "OPEN statement");
} }
@ -221,7 +221,7 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
break; break;
seek_error: seek_error:
generate_error (&opp->common, ERROR_OS, NULL); generate_error (&opp->common, LIBERROR_OS, NULL);
break; break;
} }
@ -256,7 +256,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
{ {
if (flags->form == FORM_UNFORMATTED) if (flags->form == FORM_UNFORMATTED)
{ {
generate_error (&opp->common, ERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in " "DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement"); "OPEN statement");
goto fail; goto fail;
@ -269,7 +269,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
{ {
if (flags->form == FORM_UNFORMATTED) if (flags->form == FORM_UNFORMATTED)
{ {
generate_error (&opp->common, ERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in " "BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement"); "OPEN statement");
goto fail; goto fail;
@ -282,7 +282,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
{ {
if (flags->form == FORM_UNFORMATTED) if (flags->form == FORM_UNFORMATTED)
{ {
generate_error (&opp->common, ERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in " "PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement"); "OPEN statement");
goto fail; goto fail;
@ -291,7 +291,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT) if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
{ {
generate_error (&opp->common, ERROR_OPTION_CONFLICT, generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ACCESS parameter conflicts with SEQUENTIAL access in " "ACCESS parameter conflicts with SEQUENTIAL access in "
"OPEN statement"); "OPEN statement");
goto fail; goto fail;
@ -309,14 +309,14 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
if (flags->access == ACCESS_DIRECT if (flags->access == ACCESS_DIRECT
&& (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0) && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
{ {
generate_error (&opp->common, ERROR_MISSING_OPTION, generate_error (&opp->common, LIBERROR_MISSING_OPTION,
"Missing RECL parameter in OPEN statement"); "Missing RECL parameter in OPEN statement");
goto fail; goto fail;
} }
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0) if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
{ {
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"RECL parameter is non-positive in OPEN statement"); "RECL parameter is non-positive in OPEN statement");
goto fail; goto fail;
} }
@ -330,7 +330,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
break; break;
} }
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"FILE parameter must not be present in OPEN statement"); "FILE parameter must not be present in OPEN statement");
goto fail; goto fail;
@ -366,7 +366,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
&& (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit)) && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
{ {
unlock_unit (u2); unlock_unit (u2);
generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL); generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
goto cleanup; goto cleanup;
} }
@ -405,7 +405,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
msg = NULL; msg = NULL;
} }
generate_error (&opp->common, ERROR_OS, msg); generate_error (&opp->common, LIBERROR_OS, msg);
goto cleanup; goto cleanup;
} }
@ -431,7 +431,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
if (flags->position == POSITION_APPEND) if (flags->position == POSITION_APPEND)
{ {
if (sseek (u->s, file_length (u->s)) == FAILURE) if (sseek (u->s, file_length (u->s)) == FAILURE)
generate_error (&opp->common, ERROR_OS, NULL); generate_error (&opp->common, LIBERROR_OS, NULL);
u->endfile = AT_ENDFILE; u->endfile = AT_ENDFILE;
} }
@ -544,7 +544,7 @@ already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
if (sclose (u->s) == FAILURE) if (sclose (u->s) == FAILURE)
{ {
unlock_unit (u); unlock_unit (u);
generate_error (&opp->common, ERROR_OS, generate_error (&opp->common, LIBERROR_OS,
"Error closing file in OPEN statement"); "Error closing file in OPEN statement");
return; return;
} }
@ -624,7 +624,7 @@ st_open (st_parameter_open *opp)
conv = get_unformatted_convert (opp->common.unit); conv = get_unformatted_convert (opp->common.unit);
if (conv == CONVERT_NONE) if (conv == GFC_CONVERT_NONE)
{ {
/* Nothing has been set by environment variable, check the convert tag. */ /* Nothing has been set by environment variable, check the convert tag. */
if (cf & IOPARM_OPEN_HAS_CONVERT) if (cf & IOPARM_OPEN_HAS_CONVERT)
@ -639,16 +639,16 @@ st_open (st_parameter_open *opp)
and 1 on big-endian machines. */ and 1 on big-endian machines. */
switch (conv) switch (conv)
{ {
case CONVERT_NATIVE: case GFC_CONVERT_NATIVE:
case CONVERT_SWAP: case GFC_CONVERT_SWAP:
break; break;
case CONVERT_BIG: case GFC_CONVERT_BIG:
conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP; conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break; break;
case CONVERT_LITTLE: case GFC_CONVERT_LITTLE:
conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE; conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break; break;
default: default:
@ -659,19 +659,19 @@ st_open (st_parameter_open *opp)
flags.convert = conv; flags.convert = conv;
if (opp->common.unit < 0) if (opp->common.unit < 0)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Bad unit number in OPEN statement"); "Bad unit number in OPEN statement");
if (flags.position != POSITION_UNSPECIFIED if (flags.position != POSITION_UNSPECIFIED
&& flags.access == ACCESS_DIRECT) && flags.access == ACCESS_DIRECT)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Cannot use POSITION with direct access files"); "Cannot use POSITION with direct access files");
if (flags.access == ACCESS_APPEND) if (flags.access == ACCESS_APPEND)
{ {
if (flags.position != POSITION_UNSPECIFIED if (flags.position != POSITION_UNSPECIFIED
&& flags.position != POSITION_APPEND) && flags.position != POSITION_APPEND)
generate_error (&opp->common, ERROR_BAD_OPTION, generate_error (&opp->common, LIBERROR_BAD_OPTION,
"Conflicting ACCESS and POSITION flags in" "Conflicting ACCESS and POSITION flags in"
" OPEN statement"); " OPEN statement");

14
libgfortran/io/read.c
View File

@ -175,7 +175,7 @@ convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
if (errno == EINVAL) if (errno == EINVAL)
{ {
generate_error (&dtp->common, ERROR_READ_VALUE, generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Error during floating point read"); "Error during floating point read");
return 1; return 1;
} }
@ -223,7 +223,7 @@ read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
break; break;
default: default:
bad: bad:
generate_error (&dtp->common, ERROR_READ_VALUE, generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value on logical read"); "Bad value on logical read");
break; break;
} }
@ -393,12 +393,12 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
return; return;
bad: bad:
generate_error (&dtp->common, ERROR_READ_VALUE, generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during integer read"); "Bad value during integer read");
return; return;
overflow: overflow:
generate_error (&dtp->common, ERROR_READ_OVERFLOW, generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
"Value overflowed during integer read"); "Value overflowed during integer read");
return; return;
} }
@ -537,12 +537,12 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
return; return;
bad: bad:
generate_error (&dtp->common, ERROR_READ_VALUE, generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during integer read"); "Bad value during integer read");
return; return;
overflow: overflow:
generate_error (&dtp->common, ERROR_READ_OVERFLOW, generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
"Value overflowed during integer read"); "Value overflowed during integer read");
return; return;
} }
@ -657,7 +657,7 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
goto done; goto done;
bad_float: bad_float:
generate_error (&dtp->common, ERROR_READ_VALUE, generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during floating point read"); "Bad value during floating point read");
return; return;

156
libgfortran/io/transfer.c
View File

@ -185,7 +185,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
{ {
if (no_error) if (no_error)
break; break;
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL; return NULL;
} }
@ -218,7 +218,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
{ {
if (no_error) if (no_error)
break; break;
generate_error (&dtp->common, ERROR_EOR, NULL); generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL; return NULL;
} }
@ -275,7 +275,7 @@ read_block (st_parameter_dt *dtp, int *length)
if (sseek (dtp->u.p.current_unit->s, if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->strm_pos - 1) == FAILURE) dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL; return NULL;
} }
} }
@ -293,7 +293,7 @@ read_block (st_parameter_dt *dtp, int *length)
if (dtp->u.p.current_unit->flags.pad == PAD_NO) if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{ {
/* Not enough data left. */ /* Not enough data left. */
generate_error (&dtp->common, ERROR_EOR, NULL); generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL; return NULL;
} }
} }
@ -301,7 +301,7 @@ read_block (st_parameter_dt *dtp, int *length)
if (dtp->u.p.current_unit->bytes_left == 0) if (dtp->u.p.current_unit->bytes_left == 0)
{ {
dtp->u.p.current_unit->endfile = AT_ENDFILE; dtp->u.p.current_unit->endfile = AT_ENDFILE;
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL; return NULL;
} }
@ -332,7 +332,7 @@ read_block (st_parameter_dt *dtp, int *length)
*length = nread; *length = nread;
else else
{ {
generate_error (&dtp->common, ERROR_EOR, NULL); generate_error (&dtp->common, LIBERROR_EOR, NULL);
source = NULL; source = NULL;
} }
} }
@ -360,7 +360,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (sseek (dtp->u.p.current_unit->s, if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->strm_pos - 1) == FAILURE) dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return; return;
} }
@ -368,7 +368,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
have_read_record = to_read_record; have_read_record = to_read_record;
if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0) if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return; return;
} }
@ -378,7 +378,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{ {
/* Short read, e.g. if we hit EOF. For stream files, /* Short read, e.g. if we hit EOF. For stream files,
we have to set the end-of-file condition. */ we have to set the end-of-file condition. */
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return; return;
} }
return; return;
@ -403,7 +403,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0) if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return; return;
} }
@ -417,7 +417,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (short_record) if (short_record)
{ {
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
return; return;
} }
return; return;
@ -429,7 +429,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (dtp->u.p.current_unit->endfile == AT_ENDFILE) if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return; return;
} }
@ -468,7 +468,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
if (sread (dtp->u.p.current_unit->s, buf + have_read_record, if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
&have_read_subrecord) != 0) &have_read_subrecord) != 0)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return; return;
} }
@ -482,7 +482,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
marker would still be present. */ marker would still be present. */
*nbytes = have_read_record; *nbytes = have_read_record;
generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL); generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
return; return;
} }
@ -500,7 +500,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
dtp->u.p.current_unit->current_record = 0; dtp->u.p.current_unit->current_record = 0;
next_record_r_unf (dtp, 0); next_record_r_unf (dtp, 0);
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
return; return;
} }
} }
@ -514,7 +514,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
dtp->u.p.current_unit->bytes_left -= have_read_record; dtp->u.p.current_unit->bytes_left -= have_read_record;
if (short_record) if (short_record)
{ {
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
return; return;
} }
return; return;
@ -536,7 +536,7 @@ write_block (st_parameter_dt *dtp, int length)
if (sseek (dtp->u.p.current_unit->s, if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->strm_pos - 1) == FAILURE) dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return NULL; return NULL;
} }
} }
@ -552,7 +552,7 @@ write_block (st_parameter_dt *dtp, int length)
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else else
{ {
generate_error (&dtp->common, ERROR_EOR, NULL); generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL; return NULL;
} }
} }
@ -564,12 +564,12 @@ write_block (st_parameter_dt *dtp, int length)
if (dest == NULL) if (dest == NULL)
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL; return NULL;
} }
if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE) if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (gfc_offset) length; dtp->u.p.size_used += (gfc_offset) length;
@ -599,13 +599,13 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
if (sseek (dtp->u.p.current_unit->s, if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->strm_pos - 1) == FAILURE) dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE; return FAILURE;
} }
if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0) if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE; return FAILURE;
} }
@ -620,13 +620,13 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{ {
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes) if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
{ {
generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL); generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
return FAILURE; return FAILURE;
} }
if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0) if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE; return FAILURE;
} }
@ -665,7 +665,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
if (swrite (dtp->u.p.current_unit->s, buf + have_written, if (swrite (dtp->u.p.current_unit->s, buf + have_written,
&to_write_subrecord) != 0) &to_write_subrecord) != 0)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE; return FAILURE;
} }
@ -682,7 +682,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
dtp->u.p.current_unit->bytes_left -= have_written; dtp->u.p.current_unit->bytes_left -= have_written;
if (short_record) if (short_record)
{ {
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
return FAILURE; return FAILURE;
} }
return SUCCESS; return SUCCESS;
@ -699,7 +699,7 @@ unformatted_read (st_parameter_dt *dtp, bt type,
size_t i, sz; size_t i, sz;
/* Currently, character implies size=1. */ /* Currently, character implies size=1. */
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE
|| size == 1 || type == BT_CHARACTER) || size == 1 || type == BT_CHARACTER)
{ {
sz = size * nelems; sz = size * nelems;
@ -741,7 +741,7 @@ unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind __attribute__((unused)), void *source, int kind __attribute__((unused)),
size_t size, size_t nelems) size_t size, size_t nelems)
{ {
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE || if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE ||
size == 1 || type == BT_CHARACTER) size == 1 || type == BT_CHARACTER)
{ {
size *= nelems; size *= nelems;
@ -916,7 +916,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
{ {
/* No data descriptors left. */ /* No data descriptors left. */
if (n > 0) if (n > 0)
generate_error (&dtp->common, ERROR_FORMAT, generate_error (&dtp->common, LIBERROR_FORMAT,
"Insufficient data descriptors in format after reversion"); "Insufficient data descriptors in format after reversion");
return; return;
} }
@ -1564,12 +1564,12 @@ us_read (st_parameter_dt *dtp, int continued)
if (p == NULL || n != nr) if (p == NULL || n != nr)
{ {
generate_error (&dtp->common, ERROR_BAD_US, NULL); generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return; return;
} }
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE) if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
{ {
switch (nr) switch (nr)
{ {
@ -1639,7 +1639,7 @@ us_write (st_parameter_dt *dtp, int continued)
nbytes = compile_options.record_marker ; nbytes = compile_options.record_marker ;
if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0) if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
/* For sequential unformatted, if RECL= was not specified in the OPEN /* For sequential unformatted, if RECL= was not specified in the OPEN
we write until we have more bytes than can fit in the subrecord we write until we have more bytes than can fit in the subrecord
@ -1721,7 +1721,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{ {
close_unit (dtp->u.p.current_unit); close_unit (dtp->u.p.current_unit);
dtp->u.p.current_unit = NULL; dtp->u.p.current_unit = NULL;
generate_error (&dtp->common, ERROR_BAD_OPTION, generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Bad unit number in OPEN statement"); "Bad unit number in OPEN statement");
return; return;
} }
@ -1743,23 +1743,23 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
conv = get_unformatted_convert (dtp->common.unit); conv = get_unformatted_convert (dtp->common.unit);
if (conv == CONVERT_NONE) if (conv == GFC_CONVERT_NONE)
conv = compile_options.convert; conv = compile_options.convert;
/* We use l8_to_l4_offset, which is 0 on little-endian machines /* We use l8_to_l4_offset, which is 0 on little-endian machines
and 1 on big-endian machines. */ and 1 on big-endian machines. */
switch (conv) switch (conv)
{ {
case CONVERT_NATIVE: case GFC_CONVERT_NATIVE:
case CONVERT_SWAP: case GFC_CONVERT_SWAP:
break; break;
case CONVERT_BIG: case GFC_CONVERT_BIG:
conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP; conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break; break;
case CONVERT_LITTLE: case GFC_CONVERT_LITTLE:
conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE; conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break; break;
default: default:
@ -1782,14 +1782,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
{ {
generate_error (&dtp->common, ERROR_BAD_ACTION, generate_error (&dtp->common, LIBERROR_BAD_ACTION,
"Cannot read from file opened for WRITE"); "Cannot read from file opened for WRITE");
return; return;
} }
if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ) if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
{ {
generate_error (&dtp->common, ERROR_BAD_ACTION, generate_error (&dtp->common, LIBERROR_BAD_ACTION,
"Cannot write to file opened for READ"); "Cannot write to file opened for READ");
return; return;
} }
@ -1805,7 +1805,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
&& (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
!= 0) != 0)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Format present for UNFORMATTED data transfer"); "Format present for UNFORMATTED data transfer");
return; return;
} }
@ -1813,20 +1813,20 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL) if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
{ {
if ((cf & IOPARM_DT_HAS_FORMAT) != 0) if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"A format cannot be specified with a namelist"); "A format cannot be specified with a namelist");
} }
else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))) !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Missing format for FORMATTED data transfer"); "Missing format for FORMATTED data transfer");
} }
if (is_internal_unit (dtp) if (is_internal_unit (dtp)
&& dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Internal file cannot be accessed by UNFORMATTED " "Internal file cannot be accessed by UNFORMATTED "
"data transfer"); "data transfer");
return; return;
@ -1837,7 +1837,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0) && (cf & IOPARM_DT_HAS_REC) == 0)
{ {
generate_error (&dtp->common, ERROR_MISSING_OPTION, generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
"Direct access data transfer requires record number"); "Direct access data transfer requires record number");
return; return;
} }
@ -1845,7 +1845,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
&& (cf & IOPARM_DT_HAS_REC) != 0) && (cf & IOPARM_DT_HAS_REC) != 0)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Record number not allowed for sequential access data transfer"); "Record number not allowed for sequential access data transfer");
return; return;
} }
@ -1861,14 +1861,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{ {
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with sequential access"); "ADVANCE specification conflicts with sequential access");
return; return;
} }
if (is_internal_unit (dtp)) if (is_internal_unit (dtp))
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with internal file"); "ADVANCE specification conflicts with internal file");
return; return;
} }
@ -1876,7 +1876,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
!= IOPARM_DT_HAS_FORMAT) != IOPARM_DT_HAS_FORMAT)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"ADVANCE specification requires an explicit format"); "ADVANCE specification requires an explicit format");
return; return;
} }
@ -1886,7 +1886,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{ {
if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO) if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
{ {
generate_error (&dtp->common, ERROR_MISSING_OPTION, generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
"EOR specification requires an ADVANCE specification " "EOR specification requires an ADVANCE specification "
"of NO"); "of NO");
return; return;
@ -1894,7 +1894,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO) if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
{ {
generate_error (&dtp->common, ERROR_MISSING_OPTION, generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
"SIZE specification requires an ADVANCE specification of NO"); "SIZE specification requires an ADVANCE specification of NO");
return; return;
} }
@ -1903,21 +1903,21 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{ /* Write constraints. */ { /* Write constraints. */
if ((cf & IOPARM_END) != 0) if ((cf & IOPARM_END) != 0)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"END specification cannot appear in a write statement"); "END specification cannot appear in a write statement");
return; return;
} }
if ((cf & IOPARM_EOR) != 0) if ((cf & IOPARM_EOR) != 0)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"EOR specification cannot appear in a write statement"); "EOR specification cannot appear in a write statement");
return; return;
} }
if ((cf & IOPARM_DT_HAS_SIZE) != 0) if ((cf & IOPARM_DT_HAS_SIZE) != 0)
{ {
generate_error (&dtp->common, ERROR_OPTION_CONFLICT, generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"SIZE specification cannot appear in a write statement"); "SIZE specification cannot appear in a write statement");
return; return;
} }
@ -1931,14 +1931,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{ {
if (dtp->rec <= 0) if (dtp->rec <= 0)
{ {
generate_error (&dtp->common, ERROR_BAD_OPTION, generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Record number must be positive"); "Record number must be positive");
return; return;
} }
if (dtp->rec >= dtp->u.p.current_unit->maxrec) if (dtp->rec >= dtp->u.p.current_unit->maxrec)
{ {
generate_error (&dtp->common, ERROR_BAD_OPTION, generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Record number too large"); "Record number too large");
return; return;
} }
@ -1956,7 +1956,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.mode == READING && (dtp->rec -1) if (dtp->u.p.mode == READING && (dtp->rec -1)
* dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s)) * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
{ {
generate_error (&dtp->common, ERROR_BAD_OPTION, generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Non-existing record number"); "Non-existing record number");
return; return;
} }
@ -1967,7 +1967,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
* dtp->u.p.current_unit->recl) == FAILURE) * dtp->u.p.current_unit->recl) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return; return;
} }
} }
@ -2033,7 +2033,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{ {
if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp)) if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
{ {
generate_error (&dtp->common, ERROR_BAD_OPTION, generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Cannot READ after a nonadvancing WRITE"); "Cannot READ after a nonadvancing WRITE");
return; return;
} }
@ -2135,7 +2135,7 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
/* Direct access files do not generate END conditions, /* Direct access files do not generate END conditions,
only I/O errors. */ only I/O errors. */
if (sseek (dtp->u.p.current_unit->s, new) == FAILURE) if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
} }
else else
{ /* Seek by reading data. */ { /* Seek by reading data. */
@ -2148,7 +2148,7 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
p = salloc_r (dtp->u.p.current_unit->s, &rlength); p = salloc_r (dtp->u.p.current_unit->s, &rlength);
if (p == NULL) if (p == NULL)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return; return;
} }
@ -2231,7 +2231,7 @@ next_record_r (st_parameter_dt *dtp)
record = record * dtp->u.p.current_unit->recl; record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
break; break;
} }
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
@ -2252,7 +2252,7 @@ next_record_r (st_parameter_dt *dtp)
if (p == NULL) if (p == NULL)
{ {
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
break; break;
} }
@ -2296,8 +2296,8 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
else else
len = compile_options.record_marker; len = compile_options.record_marker;
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */ /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE) if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
{ {
switch (len) switch (len)
{ {
@ -2393,7 +2393,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
return; return;
io_error: io_error:
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
return; return;
} }
@ -2461,7 +2461,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return; return;
} }
@ -2476,7 +2476,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return; return;
} }
@ -2505,7 +2505,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return; return;
} }
} }
@ -2542,7 +2542,7 @@ next_record_w (st_parameter_dt *dtp, int done)
break; break;
io_error: io_error:
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
break; break;
} }
} }
@ -2603,7 +2603,7 @@ finalize_transfer (st_parameter_dt *dtp)
if (dtp->u.p.eor_condition) if (dtp->u.p.eor_condition)
{ {
generate_error (&dtp->common, ERROR_EOR, NULL); generate_error (&dtp->common, LIBERROR_EOR, NULL);
return; return;
} }
@ -2626,7 +2626,7 @@ finalize_transfer (st_parameter_dt *dtp)
dtp->u.p.eof_jump = &eof_jump; dtp->u.p.eof_jump = &eof_jump;
if (setjmp (eof_jump)) if (setjmp (eof_jump))
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
return; return;
} }
@ -2756,14 +2756,14 @@ st_read (st_parameter_dt *dtp)
case AT_ENDFILE: case AT_ENDFILE:
if (!is_internal_unit (dtp)) if (!is_internal_unit (dtp))
{ {
generate_error (&dtp->common, ERROR_END, NULL); generate_error (&dtp->common, LIBERROR_END, NULL);
dtp->u.p.current_unit->endfile = AFTER_ENDFILE; dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
dtp->u.p.current_unit->current_record = 0; dtp->u.p.current_unit->current_record = 0;
} }
break; break;
case AFTER_ENDFILE: case AFTER_ENDFILE:
generate_error (&dtp->common, ERROR_ENDFILE, NULL); generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0; dtp->u.p.current_unit->current_record = 0;
break; break;
} }
@ -2825,7 +2825,7 @@ st_write_done (st_parameter_dt *dtp)
{ {
flush (dtp->u.p.current_unit->s); flush (dtp->u.p.current_unit->s);
if (struncate (dtp->u.p.current_unit->s) == FAILURE) if (struncate (dtp->u.p.current_unit->s) == FAILURE)
generate_error (&dtp->common, ERROR_OS, NULL); generate_error (&dtp->common, LIBERROR_OS, NULL);
} }
dtp->u.p.current_unit->endfile = AT_ENDFILE; dtp->u.p.current_unit->endfile = AT_ENDFILE;
break; break;

2
libgfortran/io/unit.c
View File

@ -375,7 +375,7 @@ get_internal_unit (st_parameter_dt *dtp)
iunit = get_mem (sizeof (gfc_unit)); iunit = get_mem (sizeof (gfc_unit));
if (iunit == NULL) if (iunit == NULL)
{ {
generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return NULL; return NULL;
} }

89
libgfortran/libgfortran.h
View File

@ -37,16 +37,14 @@ Boston, MA 02110-1301, USA. */
#include <float.h> #include <float.h>
#include <stdarg.h> #include <stdarg.h>
#ifndef M_PI
#define M_PI 3.14159265358979323846264338327
#endif
#if HAVE_COMPLEX_H #if HAVE_COMPLEX_H
# include <complex.h> # include <complex.h>
#else #else
#define complex __complex__ #define complex __complex__
#endif #endif
#include "../gcc/fortran/libgfortran.h"
#include "config.h" #include "config.h"
#include "c99_protos.h" #include "c99_protos.h"
@ -276,9 +274,6 @@ internal_proto(l8_to_l4_offset);
#define GFC_REAL_16_RADIX FLT_RADIX #define GFC_REAL_16_RADIX FLT_RADIX
#endif #endif
#ifndef GFC_MAX_DIMENSIONS
#define GFC_MAX_DIMENSIONS 7
#endif
typedef struct descriptor_dimension typedef struct descriptor_dimension
{ {
@ -330,25 +325,6 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_8) gfc_array_l8;
typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16; typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16;
#endif #endif
#define GFC_DTYPE_RANK_MASK 0x07
#define GFC_DTYPE_TYPE_SHIFT 3
#define GFC_DTYPE_TYPE_MASK 0x38
#define GFC_DTYPE_SIZE_SHIFT 6
/* added for f03. --Rickett, 02.28.06 */
#define GFC_NUM_RANK_BITS 3
enum
{
GFC_DTYPE_UNKNOWN = 0,
GFC_DTYPE_INTEGER,
/* TODO: recognize logical types. */
GFC_DTYPE_LOGICAL,
GFC_DTYPE_REAL,
GFC_DTYPE_COMPLEX,
GFC_DTYPE_DERIVED,
GFC_DTYPE_CHARACTER
};
#define GFC_DESCRIPTOR_RANK(desc) ((desc)->dtype & GFC_DTYPE_RANK_MASK) #define GFC_DESCRIPTOR_RANK(desc) ((desc)->dtype & GFC_DTYPE_RANK_MASK)
#define GFC_DESCRIPTOR_TYPE(desc) (((desc)->dtype & GFC_DTYPE_TYPE_MASK) \ #define GFC_DESCRIPTOR_TYPE(desc) (((desc)->dtype & GFC_DTYPE_TYPE_MASK) \
@ -423,60 +399,6 @@ typedef struct
} }
st_option; st_option;
/* Runtime errors. The EOR and EOF errors are required to be negative.
These codes must be kept sychronized with their equivalents in
gcc/fortran/gfortran.h . */
typedef enum
{
ERROR_FIRST = -3, /* Marker for the first error. */
ERROR_EOR = -2,
ERROR_END = -1,
ERROR_OK = 0, /* Indicates success, must be zero. */
ERROR_OS = 5000, /* Operating system error, more info in errno. */
ERROR_OPTION_CONFLICT,
ERROR_BAD_OPTION,
ERROR_MISSING_OPTION,
ERROR_ALREADY_OPEN,
ERROR_BAD_UNIT,
ERROR_FORMAT,
ERROR_BAD_ACTION,
ERROR_ENDFILE,
ERROR_BAD_US,
ERROR_READ_VALUE,
ERROR_READ_OVERFLOW,
ERROR_INTERNAL,
ERROR_INTERNAL_UNIT,
ERROR_ALLOCATION, /* Keep in sync with value used in
gcc/fortran/trans.c
(gfc_allocate_array_with_status). */
ERROR_DIRECT_EOR,
ERROR_SHORT_RECORD,
ERROR_CORRUPT_FILE,
ERROR_LAST /* Not a real error, the last error # + 1. */
}
error_codes;
/* Flags to specify which standard/extension contains a feature.
Keep them in sync with their counterparts in gcc/fortran/gfortran.h. */
#define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */
#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */
#define GFC_STD_F2003 (1<<4) /* New in F2003. */
/* Note that no features were obsoleted nor deleted in F2003. */
#define GFC_STD_F95 (1<<3) /* New in F95. */
#define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */
#define GFC_STD_F95_OBS (1<<1) /* Obsoleted in F95. */
#define GFC_STD_F77 (1<<0) /* Up to and including F77. */
/* Bitmasks for the various FPE that can be enabled.
Keep them in sync with their counterparts in gcc/fortran/gfortran.h. */
#define GFC_FPE_INVALID (1<<0)
#define GFC_FPE_DENORMAL (1<<1)
#define GFC_FPE_ZERO (1<<2)
#define GFC_FPE_OVERFLOW (1<<3)
#define GFC_FPE_UNDERFLOW (1<<4)
#define GFC_FPE_PRECISION (1<<5)
/* This is returned by notification_std to know if, given the flags /* This is returned by notification_std to know if, given the flags
that were given (-std=, -pedantic) we should issue an error, a warning that were given (-std=, -pedantic) we should issue an error, a warning
@ -505,8 +427,8 @@ iexport_data_proto(filename);
#define gfc_alloca(x) __builtin_alloca(x) #define gfc_alloca(x) __builtin_alloca(x)
/* Various I/O stuff also used in other parts of the library. */ /* Directory for creating temporary files. Only used when none of the
following environment variables exist: GFORTRAN_TMPDIR, TMP and TEMP. */
#define DEFAULT_TEMPDIR "/tmp" #define DEFAULT_TEMPDIR "/tmp"
/* The default value of record length for preconnected units is defined /* The default value of record length for preconnected units is defined
@ -514,9 +436,6 @@ iexport_data_proto(filename);
Default value is 1 Gb. */ Default value is 1 Gb. */
#define DEFAULT_RECL 1073741824 #define DEFAULT_RECL 1073741824
typedef enum
{ CONVERT_NONE=-1, CONVERT_NATIVE, CONVERT_SWAP, CONVERT_BIG, CONVERT_LITTLE }
unit_convert;
#define CHARACTER2(name) \ #define CHARACTER2(name) \
gfc_charlen_type name ## _len; \ gfc_charlen_type name ## _len; \

33
libgfortran/runtime/environ.c
View File

@ -460,17 +460,18 @@ show_signal (variable * v)
static variable variable_table[] = { static variable variable_table[] = {
{"GFORTRAN_STDIN_UNIT", 5, &options.stdin_unit, init_integer, show_integer, {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
init_integer, show_integer,
"Unit number that will be preconnected to standard input\n" "Unit number that will be preconnected to standard input\n"
"(No preconnection if negative)", 0}, "(No preconnection if negative)", 0},
{"GFORTRAN_STDOUT_UNIT", 6, &options.stdout_unit, init_integer, {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
show_integer, init_integer, show_integer,
"Unit number that will be preconnected to standard output\n" "Unit number that will be preconnected to standard output\n"
"(No preconnection if negative)", 0}, "(No preconnection if negative)", 0},
{"GFORTRAN_STDERR_UNIT", 0, &options.stderr_unit, init_integer, {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
show_integer, init_integer, show_integer,
"Unit number that will be preconnected to standard error\n" "Unit number that will be preconnected to standard error\n"
"(No preconnection if negative)", 0}, "(No preconnection if negative)", 0},
@ -622,7 +623,7 @@ show_variables (void)
st_printf ("\nRuntime error codes:"); st_printf ("\nRuntime error codes:");
st_printf ("\n--------------------\n"); st_printf ("\n--------------------\n");
for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++) for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++)
if (n < 0 || n > 9) if (n < 0 || n > 9)
st_printf ("%d %s\n", n, translate_error (n)); st_printf ("%d %s\n", n, translate_error (n));
else else
@ -881,19 +882,19 @@ do_parse (void)
switch (tok) switch (tok)
{ {
case NATIVE: case NATIVE:
endian = CONVERT_NATIVE; endian = GFC_CONVERT_NATIVE;
break; break;
case SWAP: case SWAP:
endian = CONVERT_SWAP; endian = GFC_CONVERT_SWAP;
break; break;
case BIG: case BIG:
endian = CONVERT_BIG; endian = GFC_CONVERT_BIG;
break; break;
case LITTLE: case LITTLE:
endian = CONVERT_LITTLE; endian = GFC_CONVERT_LITTLE;
break; break;
case INTEGER: case INTEGER:
@ -948,25 +949,25 @@ do_parse (void)
case NATIVE: case NATIVE:
if (next_token () != ':') if (next_token () != ':')
goto error; goto error;
endian = CONVERT_NATIVE; endian = GFC_CONVERT_NATIVE;
break; break;
case SWAP: case SWAP:
if (next_token () != ':') if (next_token () != ':')
goto error; goto error;
endian = CONVERT_SWAP; endian = GFC_CONVERT_SWAP;
break; break;
case LITTLE: case LITTLE:
if (next_token () != ':') if (next_token () != ':')
goto error; goto error;
endian = CONVERT_LITTLE; endian = GFC_CONVERT_LITTLE;
break; break;
case BIG: case BIG:
if (next_token () != ':') if (next_token () != ':')
goto error; goto error;
endian = CONVERT_BIG; endian = GFC_CONVERT_BIG;
break; break;
case INTEGER: case INTEGER:
@ -1034,7 +1035,7 @@ do_parse (void)
end: end:
return 0; return 0;
error: error:
def = CONVERT_NONE; def = GFC_CONVERT_NONE;
return -1; return -1;
} }
@ -1042,7 +1043,7 @@ void init_unformatted (variable * v)
{ {
char *val; char *val;
val = getenv (v->name); val = getenv (v->name);
def = CONVERT_NONE; def = GFC_CONVERT_NONE;
n_elist = 0; n_elist = 0;
if (val == NULL) if (val == NULL)

48
libgfortran/runtime/error.c
View File

@ -310,83 +310,83 @@ translate_error (int code)
switch (code) switch (code)
{ {
case ERROR_EOR: case LIBERROR_EOR:
p = "End of record"; p = "End of record";
break; break;
case ERROR_END: case LIBERROR_END:
p = "End of file"; p = "End of file";
break; break;
case ERROR_OK: case LIBERROR_OK:
p = "Successful return"; p = "Successful return";
break; break;
case ERROR_OS: case LIBERROR_OS:
p = "Operating system error"; p = "Operating system error";
break; break;
case ERROR_BAD_OPTION: case LIBERROR_BAD_OPTION:
p = "Bad statement option"; p = "Bad statement option";
break; break;
case ERROR_MISSING_OPTION: case LIBERROR_MISSING_OPTION:
p = "Missing statement option"; p = "Missing statement option";
break; break;
case ERROR_OPTION_CONFLICT: case LIBERROR_OPTION_CONFLICT:
p = "Conflicting statement options"; p = "Conflicting statement options";
break; break;
case ERROR_ALREADY_OPEN: case LIBERROR_ALREADY_OPEN:
p = "File already opened in another unit"; p = "File already opened in another unit";
break; break;
case ERROR_BAD_UNIT: case LIBERROR_BAD_UNIT:
p = "Unattached unit"; p = "Unattached unit";
break; break;
case ERROR_FORMAT: case LIBERROR_FORMAT:
p = "FORMAT error"; p = "FORMAT error";
break; break;
case ERROR_BAD_ACTION: case LIBERROR_BAD_ACTION:
p = "Incorrect ACTION specified"; p = "Incorrect ACTION specified";
break; break;
case ERROR_ENDFILE: case LIBERROR_ENDFILE:
p = "Read past ENDFILE record"; p = "Read past ENDFILE record";
break; break;
case ERROR_BAD_US: case LIBERROR_BAD_US:
p = "Corrupt unformatted sequential file"; p = "Corrupt unformatted sequential file";
break; break;
case ERROR_READ_VALUE: case LIBERROR_READ_VALUE:
p = "Bad value during read"; p = "Bad value during read";
break; break;
case ERROR_READ_OVERFLOW: case LIBERROR_READ_OVERFLOW:
p = "Numeric overflow on read"; p = "Numeric overflow on read";
break; break;
case ERROR_INTERNAL: case LIBERROR_INTERNAL:
p = "Internal error in run-time library"; p = "Internal error in run-time library";
break; break;
case ERROR_INTERNAL_UNIT: case LIBERROR_INTERNAL_UNIT:
p = "Internal unit I/O error"; p = "Internal unit I/O error";
break; break;
case ERROR_DIRECT_EOR: case LIBERROR_DIRECT_EOR:
p = "Write exceeds length of DIRECT access record"; p = "Write exceeds length of DIRECT access record";
break; break;
case ERROR_SHORT_RECORD: case LIBERROR_SHORT_RECORD:
p = "I/O past end of record on unformatted file"; p = "I/O past end of record on unformatted file";
break; break;
case ERROR_CORRUPT_FILE: case LIBERROR_CORRUPT_FILE:
p = "Unformatted file structure has been corrupted"; p = "Unformatted file structure has been corrupted";
break; break;
@ -412,11 +412,11 @@ generate_error (st_parameter_common *cmp, int family, const char *message)
{ {
/* Set the error status. */ /* Set the error status. */
if ((cmp->flags & IOPARM_HAS_IOSTAT)) if ((cmp->flags & IOPARM_HAS_IOSTAT))
*cmp->iostat = (family == ERROR_OS) ? errno : family; *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
if (message == NULL) if (message == NULL)
message = message =
(family == ERROR_OS) ? get_oserror () : translate_error (family); (family == LIBERROR_OS) ? get_oserror () : translate_error (family);
if (cmp->flags & IOPARM_HAS_IOMSG) if (cmp->flags & IOPARM_HAS_IOMSG)
cf_strcpy (cmp->iomsg, cmp->iomsg_len, message); cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
@ -425,13 +425,13 @@ generate_error (st_parameter_common *cmp, int family, const char *message)
cmp->flags &= ~IOPARM_LIBRETURN_MASK; cmp->flags &= ~IOPARM_LIBRETURN_MASK;
switch (family) switch (family)
{ {
case ERROR_EOR: case LIBERROR_EOR:
cmp->flags |= IOPARM_LIBRETURN_EOR; cmp->flags |= IOPARM_LIBRETURN_EOR;
if ((cmp->flags & IOPARM_EOR)) if ((cmp->flags & IOPARM_EOR))
return; return;
break; break;
case ERROR_END: case LIBERROR_END:
cmp->flags |= IOPARM_LIBRETURN_END; cmp->flags |= IOPARM_LIBRETURN_END;
if ((cmp->flags & IOPARM_END)) if ((cmp->flags & IOPARM_END))
return; return;

2
libgfortran/runtime/string.c
View File

@ -122,7 +122,7 @@ find_option (st_parameter_common *cmp, const char *s1, gfc_charlen_type s1_len,
if (compare0 (s1, s1_len, opts->name)) if (compare0 (s1, s1_len, opts->name))
return opts->value; return opts->value;
generate_error (cmp, ERROR_BAD_OPTION, error_message); generate_error (cmp, LIBERROR_BAD_OPTION, error_message);
return -1; return -1;
} }