diff options
| author | hjl <hjl@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-07-01 22:22:57 +0000 |
|---|---|---|
| committer | hjl <hjl@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-07-01 22:22:57 +0000 |
| commit | 9e169c4bf36a38689550c059570c57efbf00a6fb (patch) | |
| tree | 95e6800f7ac2a49ff7f799d96f04172320e70ac0 /gcc/fortran | |
| parent | 6170dfb6edfb7b19f8ae5209b8f948fe0076a4ad (diff) | |
| download | gcc-vect256.tar.gz | |
Merged trunk at revision 161680 into branch.vect256
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/vect256@161681 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
48 files changed, 2593 insertions, 959 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0db8ce51016..18509132034 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,482 @@ +2010-06-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44718 + * resolve.c (is_external_proc): Prevent procedure pointers from being + regarded as external procedures. + +2010-06-29 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44696 + * trans-intrinsic.c (gfc_conv_associated): Handle polymorphic variables + passed as second argument of ASSOCIATED. + +2010-06-29 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44582 + * trans-expr.c (arrayfunc_assign_needs_temporary): New function + to determine if a function assignment can be made without a + temporary. + (gfc_trans_arrayfunc_assign): Move all the conditions that + suppress the direct function call to the above new functon and + call it. + +2010-06-28 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/40158 + * interface.c (argument_rank_mismatch): New function. + (compare_parameter): Call new function instead of generating + the error directly. + +2010-06-28 Nathan Froyd <froydnj@codesourcery.com> + + * trans-openmp.c (dovar_init): Define. Define VECs containing it. + (gfc_trans_omp_do): Use a VEC to accumulate variables and their + initializers. + +2010-06-28 Steven Bosscher <steven@gcc.gnu.org> + + * Make-lang.in: Update dependencies. + +2010-06-27 Nathan Froyd <froydnj@codesourcery.com> + + * gfortran.h (gfc_code): Split backend_decl field into cycle_label + and exit_label fields. + * trans-openmp.c (gfc_trans_omp_do): Assign to new fields + individually. + * trans-stmt.c (gfc_trans_simple_do): Likewise. + (gfc_trans_do): Likewise. + (gfc_trans_do_while): Likewise. + (gfc_trans_cycle): Use cycle_label directly. + (gfc_trans_exit): Use exit_label directly. + +2010-06-27 Daniel Kraft <d@domob.eu> + + * dump-parse-tree.c (show_symbol): Dump target-expression for + associate names. + (show_code_node): Make distinction between BLOCK and ASSOCIATE. + (show_namespace): Use show_level for correct indentation of + "inner namespaces" (contained procedures or BLOCK). + +2010-06-27 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/44678 + * dump-parse-tree.c (show_code_node): Show namespace for + EXEC_BLOCK. + +2010-06-26 Tobias Burnus <burnus@net-b.de> + + * decl.c (gfc_match_decl_type_spec): Support + TYPE(intrinsic-type-spec). + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * intrinsic.h (gfc_check_selected_real_kind, + gfc_simplify_selected_real_kind): Update prototypes. + * intrinsic.c (add_functions): Add radix support to + selected_real_kind. + * check.c (gfc_check_selected_real_kind): Ditto. + * simplify.c (gfc_simplify_selected_real_kind): Ditto. + * trans-decl.c (gfc_build_intrinsic_function_decls): + Change call from selected_real_kind to selected_real_kind2008. + * intrinsic.texi (SELECTED_REAL_KIND): Update for radix. + (PRECISION, RANGE, RADIX): Add cross @refs. + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * decl.c (gfc_match_entry): Mark ENTRY as GFC_STD_F2008_OBS. + * gfortran.texi (_gfortran_set_options): Update for + GFC_STD_F2008_OBS addition. + * libgfortran.h: Add GFC_STD_F2008_OBS. + * options.c (set_default_std_flags, gfc_handle_option): Handle + GFC_STD_F2008_OBS. + io.c (check_format): Fix allow_std check. + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * decl.c (gfc_match_entry): Allow END besides + END SUBROUTINE/END FUNCTION for contained procedures. + +2010-06-25 Tobias Burnus <burnus@net-b.de> + + * parse.c (next_free, next_fixed): Allow ";" as first character. + +2010-06-24 Tobias Burnus <burnus@net-b.de> + + PR fortran/44614 + * decl.c (variable_decl): Fix IMPORT diagnostic for CLASS. + +2010-06-22 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44616 + * resolve.c (resolve_fl_derived): Avoid checking for abstract on class + containers. + +2010-06-21 Tobias Burnus <burnus@net-b.de> + + PR fortran/40632 + * interface.c (compare_parameter): Add gfc_is_simply_contiguous + checks. + * symbol.c (gfc_add_contiguous): New function. + (gfc_copy_attr, check_conflict): Handle contiguous attribute. + * decl.c (match_attr_spec): Ditto. + (gfc_match_contiguous): New function. + * resolve.c (resolve_fl_derived, resolve_symbol): Handle + contiguous. + * gfortran.h (symbol_attribute): Add contiguous. + (gfc_is_simply_contiguous): Add prototype. + (gfc_add_contiguous): Add prototype. + * match.h (gfc_match_contiguous): Add prototype. + * parse.c (decode_specification_statement, + decode_statement): Handle contiguous attribute. + * expr.c (gfc_is_simply_contiguous): New function. + * dump-parse-tree.c (show_attr): Handle contiguous. + * module.c (ab_attribute, attr_bits, mio_symbol_attribute): + Ditto. + * trans-expr.c (gfc_add_interface_mapping): Copy + attr.contiguous. + * trans-array.c (gfc_conv_descriptor_stride_get, + gfc_conv_array_parameter): Handle contiguous arrays. + * trans-types.c (gfc_build_array_type, gfc_build_array_type, + gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info): + Ditto. + * trans.h (gfc_array_kind): Ditto. + * trans-decl.c (gfc_get_symbol_decl): Ditto. + +2010-06-20 Joseph Myers <joseph@codesourcery.com> + + * options.c (gfc_handle_option): Don't handle N_OPTS. + +2010-06-19 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44584 + * resolve.c (resolve_fl_derived): Reverse ordering of conditions + to avoid ICE. + +2010-06-18 Tobias Burnus <burnus@net-b.de> + + PR fortran/44556 + * resolve.c (resolve_allocate_deallocate): Properly check + part-refs in stat=/errmsg= for invalid use. + +2010-06-17 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44558 + * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): + Return directly in case of an error. + +2010-06-16 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44549 + * gfortran.h (gfc_get_typebound_proc): Modified Prototype. + * decl.c (match_procedure_in_type): Give a unique gfc_typebound_proc + structure to each procedure in a procedure list. + * module.c (mio_typebound_proc): Add NULL argument to + 'gfc_get_typebound_proc'. + * symbol.c (gfc_get_typebound_proc): Add a new argument, which is used + to initialize the new structure. + +2010-06-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/43388 + * gfortran.h (gfc_expr): Add new member 'mold'. + * match.c (gfc_match_allocate): Implement the MOLD tag. + * resolve.c (resolve_allocate_expr): Ditto. + * trans-stmt.c (gfc_trans_allocate): Ditto. + +2010-06-15 Jakub Jelinek <jakub@redhat.com> + + PR fortran/44536 + * trans-openmp.c (gfc_omp_predetermined_sharing): Don't return + OMP_CLAUSE_DEFAULT_SHARED for artificial vars with + GFC_DECL_SAVED_DESCRIPTOR set. + (gfc_omp_report_decl): New function. + * trans.h (gfc_omp_report_decl): New prototype. + * f95-lang.c (LANG_HOOKS_OMP_REPORT_DECL): Redefine. + +2010-06-13 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/31588 + PR fortran/43954 + * gfortranspec.c (lang_specific_driver): Removed deprecation + warning for -M. + * lang.opt: Add options -M, -MM, -MD, -MMD, -MF, -MG, -MP, -MT, -MQ. + * lang-specs.h (CPP_FORWARD_OPTIONS): Add -M* options. + * cpp.h (gfc_cpp_makedep): New. + (gfc_cpp_add_dep): New. + (gfc_cpp_add_target): New. + * cpp.c (gfc_cpp_option): Add deps* members. + (gfc_cpp_makedep): New. + (gfc_cpp_add_dep): New. + (gfc_cpp_add_target): New. + (gfc_cpp_init_options): Initialize new options. + (gfc_cpp_handle_option): Handle new options. + (gfc_cpp_post_options): Map new options to libcpp-options. + (gfc_cpp_init): Handle deferred -MQ and -MT options. + (gfc_cpp_done): If requested, write dependencies to file. + * module.c (gfc_dump_module): Add a module filename as target. + * scanner.c (open_included_file): New parameter system; add the + included file as dependency. + (gfc_open_included_file): Add the included file as dependency. + (gfc_open_intrinsic_module): Likewise. + * invoke.texi: Removed deprecation warning for -M. + * gfortran.texi: Removed Makefile-dependencies project. + +2010-06-12 Daniel Franke <franke.daniel@gmail.com> + + * resolve.c (resolve_global_procedure): Improved checking if an + explicit interface is required. + +2010-06-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-decl.c (gfc_build_intrinsic_function_decls): Fix + return type. + * trans-intrinsic.c (gfc_conv_intrinsic_fdate): Fix argument type. + (gfc_conv_intrinsic_ttynam): Likewise. + (gfc_conv_intrinsic_trim): Likewise. + +2010-06-12 Janus Weil <janus@gcc.gnu.org> + + PR fortran/40117 + * decl.c (match_procedure_in_type): Allow procedure lists (F08). + +2010-06-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment. + +2010-06-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * mathbuiltins.def: Add builtins that do not directly correspond + to a Fortran intrinsic, with new macro OTHER_BUILTIN. + * f95-lang.c (gfc_init_builtin_functions): Define OTHER_BUILTIN. + * trans-intrinsic.c (gfc_intrinsic_map_t): Remove + code_{r,c}{4,8,10,16} fields. Add + {,complex}{float,double,long_double}_built_in fields. + (gfc_intrinsic_map): Adjust definitions of DEFINE_MATH_BUILTIN, + DEFINE_MATH_BUILTIN_C and LIB_FUNCTION accordingly. Add + definition of OTHER_BUILTIN. + (real_compnt_info): Remove unused struct. + (builtin_decl_for_precision, builtin_decl_for_float_kind): New + functions. + (build_round_expr): Call builtin_decl_for_precision instead of + series of if-else. + (gfc_conv_intrinsic_aint): Call builtin_decl_for_float_kind + instead of a switch. + (gfc_build_intrinsic_lib_fndecls): Match + {real,complex}{4,8,10,16}decl into the C-style built_in_decls. + (gfc_get_intrinsic_lib_fndecl): Do not hardcode floating-point + kinds. + (gfc_conv_intrinsic_lib_function): Go through all the extended + gfc_intrinsic_map. + (gfc_trans_same_strlen_check): Call builtin_decl_for_float_kind + instead of a switch. + (gfc_conv_intrinsic_abs): Likewise. + (gfc_conv_intrinsic_mod): Likewise. + (gfc_conv_intrinsic_sign): Likewise. + (gfc_conv_intrinsic_fraction): Likewise. + (gfc_conv_intrinsic_nearest): Likewise. + (gfc_conv_intrinsic_spacing): Likewise. + (gfc_conv_intrinsic_rrspacing): Likewise. + (gfc_conv_intrinsic_scale): Likewise. + (gfc_conv_intrinsic_set_exponent): Likewise. + +2010-06-11 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/42051 + PR fortran/43896 + * trans-expr.c (gfc_conv_derived_to_class): Handle array-valued + functions with CLASS formal arguments. + +2010-06-10 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44207 + * resolve.c (conformable_arrays): Handle allocatable components. + +2010-06-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/38273 + * gfortran.texi: Document that Cray pointers cannot be function + results. + +2010-06-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/36234 + * gfortran.texi: Document lack of support for syntax + "complex FUNCTION name*16()", and existence of alternative + legacy syntax "complex*16 FUNCTION name()". + +2010-06-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/43032 + * intrinsic.texi (FLUSH): Note the difference between FLUSH and + POSIX's fsync(), and how to call the latter from Fortran code. + +2010-06-10 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/44457 + * interface.c (compare_actual_formal): Reject actual arguments with + array subscript passed to ASYNCHRONOUS dummys. + +2010-06-10 Daniel Kraft <d@domob.eu> + + PR fortran/38936 + * gfortran.h (enum gfc_statement): Add ST_ASSOCIATE, ST_END_ASSOCIATE. + (struct gfc_symbol): New field `assoc'. + (struct gfc_association_list): New struct. + (struct gfc_code): New struct `block' in union, move `ns' there + and add association list. + (gfc_free_association_list): New method. + (gfc_has_vector_subscript): Made public; + * match.h (gfc_match_associate): New method. + * parse.h (enum gfc_compile_state): Add COMP_ASSOCIATE. + * decl.c (gfc_match_end): Handle ST_END_ASSOCIATE. + * interface.c (gfc_has_vector_subscript): Made public. + (compare_actual_formal): Rename `has_vector_subscript' accordingly. + * match.c (gfc_match_associate): New method. + (gfc_match_select_type): Change reference to gfc_code's `ns' field. + * primary.c (match_variable): Don't allow names associated to expr here. + * parse.c (decode_statement): Try matching ASSOCIATE statement. + (case_exec_markers, case_end): Add ASSOCIATE statement. + (gfc_ascii_statement): Hande ST_ASSOCIATE and ST_END_ASSOCIATE. + (parse_associate): New method. + (parse_executable): Handle ST_ASSOCIATE. + (parse_block_construct): Change reference to gfc_code's `ns' field. + * resolve.c (resolve_select_type): Ditto. + (resolve_code): Ditto. + (resolve_block_construct): Ditto and add comment. + (resolve_select_type): Set association list in generated BLOCK to NULL. + (resolve_symbol): Resolve associate names. + * st.c (gfc_free_statement): Change reference to gfc_code's `ns' field + and free association list. + (gfc_free_association_list): New method. + * symbol.c (gfc_new_symbol): NULL new field `assoc'. + * trans-stmt.c (gfc_trans_block_construct): Change reference to + gfc_code's `ns' field. + +2010-06-10 Kai Tietz <kai.tietz@onevision.com> + + * error.c (error_print): Pre-initialize loc by NULL. + * openmp.c (resolve_omp_clauses): Add explicit + braces to avoid ambigous else. + * array.c (match_subscript): Pre-initialize m to MATCH_ERROR. + +2010-06-10 Gerald Pfeifer <gerald@pfeifer.com> + + * gfc-internals.texi: Move to GFDL 1.3. + * gfortran.texi: Ditto. + * intrinsic.texi: Ditto. + * invoke.texi: Ditto. + +2010-06-09 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/44347 + * check.c (gfc_check_selected_real_kind): Verify that the + actual arguments are scalar. + +2010-06-09 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/44359 + * intrinsic.c (gfc_convert_type_warn): Further improve -Wconversion. + +2010-06-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44430 + * dump-parse-tree.c (show_symbol): Avoid infinite loop. + +2010-06-09 Steven G. Kargl <kargl@gcc.gnu.org> + + * fortran/symbol.c (check_conflict): Remove an invalid conflict check. + +2010-06-09 Steven G. Kargl <kargl@gcc.gnu.org> + + * fortran/intrinsic.c (add_functions): Change gfc_check_btest, + gfc_check_ibclr, and gfc_check_ibset to gfc_check_bitfcn. + * fortran/intrinsic.h: Remove prototypes for gfc_check_btest, + gfc_check_ibclr, and gfc_check_ibset. Add prototype for + gfc_check_bitfcn. + * fortran/check.c (nonnegative_check, less_than_bitsize1, + less_than_bitsize2): New functions. + (gfc_check_btest): Renamed to gfc_check_bitfcn. Use + nonnegative_check and less_than_bitsize1. + (gfc_check_ibclr, gfc_check_ibset): Removed. + (gfc_check_ibits,gfc_check_mvbits): Use nonnegative_check and + less_than_bitsize1. + +2010-06-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44211 + * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): + Resolve references. + +2010-06-09 Kai Tietz <kai.tietz@onevision.com> + + * resolve.c (resolve_deallocate_expr): Avoid warning + about possible use of iunitialized sym. + (resolve_allocate_expr): Pre-initialize sym by NULL. + +2010-06-09 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/43040 + * f95-lang.c (gfc_init_builtin_functions): Remove comment. + +2010-06-08 Laurynas Biveinis <laurynas.biveinis@gmail.com> + + * trans-types.c (gfc_get_nodesc_array_type): Use typed GC + allocation. + (gfc_get_array_type_bounds): Likewise. + + * trans-decl.c (gfc_allocate_lang_decl): Likewise. + (gfc_find_module): Likewise. + + * f95-lang.c (pushlevel): Likewise. + + * trans.h (struct lang_type): Add variable_size GTY option. + (struct lang_decl): Likewise. + +2010-06-08 Tobias Burnus <burnus@net-b.de> + + PR fortran/44446 + * symbol.c (check_conflict): Move protected--external/procedure check ... + * resolve.c (resolve_select_type): ... to the resolution stage. + +2010-06-07 Tobias Burnus <burnus@net-b.de> + + * options.c (gfc_handle_option): Fix -fno-recursive. + +2010-06-07 Tobias Burnus <burnus@net-b.de> + + * gfc-internals.texi (copyrights-gfortran): Fix copyright year format. + * gfortran.texi (copyrights-gfortran): Ditto. + +2010-06-07 Joseph Myers <joseph@codesourcery.com> + + * lang.opt (fshort-enums): Define using Var and VarExists. + * options.c (gfc_handle_option): Don't set flag_short_enums here. + +2010-06-05 Paul Thomas <pault@gcc.gnu.org> + Janus Weil <janus@gcc.gnu.org> + + PR fortran/43945 + * resolve.c (get_declared_from_expr): Move to before + resolve_typebound_generic_call. Make new_ref and class_ref + ignorable if set to NULL. + (resolve_typebound_generic_call): Once we have resolved the + generic call, check that the specific instance is that which + is bound to the declared type. + (resolve_typebound_function,resolve_typebound_subroutine): Avoid + freeing 'class_ref->next' twice. + +2010-06-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/43895 + * trans-array.c (structure_alloc_comps): Dereference scalar + 'decl' if it is a REFERENCE_TYPE. Tidy expressions containing + TREE_TYPE (decl). + +2010-06-04 Joseph Myers <joseph@codesourcery.com> + + * gfortranspec.c (append_arg, lang_specific_driver): Use + GCC-specific formats in diagnostics. + 2010-06-02 Tobias Burnus <burnus@net-b.de> PR fortran/44360 diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index b74f9e99d0b..2a8c791c445 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -336,7 +336,7 @@ GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/libgfortran.h \ fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ gt-fortran-f95-lang.h gtype-fortran.h $(CGRAPH_H) $(TARGET_H) fortran/cpp.h \ $(BUILTINS_DEF) fortran/types.def \ - libfuncs.h expr.h except.h + libfuncs.h expr.h fortran/scanner.o: toplev.h fortran/cpp.h fortran/convert.o: $(GFORTRAN_TRANS_DEPS) fortran/trans.o: $(GFORTRAN_TRANS_DEPS) tree-iterator.h diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 3ffc39714da..64816f28abb 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -64,7 +64,7 @@ gfc_copy_array_ref (gfc_array_ref *src) static match match_subscript (gfc_array_ref *ar, int init, bool match_star) { - match m; + match m = MATCH_ERROR; bool star = false; int i; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 3a68c29b543..34527172431 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -241,6 +241,80 @@ array_check (gfc_expr *e, int n) } +/* If expr is a constant, then check to ensure that it is greater than + of equal to zero. */ + +static gfc_try +nonnegative_check (const char *arg, gfc_expr *expr) +{ + int i; + + if (expr->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr, &i); + if (i < 0) + { + gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* If expr2 is constant, then check that the value is less than + bit_size(expr1). */ + +static gfc_try +less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + if (i2 >= gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", + arg2, &expr2->where, arg1); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* If expr2 and expr3 are constants, then check that the value is less than + or equal to bit_size(expr1). */ + +static gfc_try +less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2, const char *arg3, gfc_expr *expr3) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + gfc_extract_int (expr3, &i3); + i2 += i3; + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s + %s' at %L must be less than or equal " + "to BIT_SIZE('%s')", + arg2, arg3, &expr2->where, arg1); + return FAILURE; + } + } + + return SUCCESS; +} + /* Make sure two expressions have the same type. */ static gfc_try @@ -766,13 +840,20 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x) gfc_try -gfc_check_btest (gfc_expr *i, gfc_expr *pos) +gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) return FAILURE; + if (type_check (pos, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (nonnegative_check ("pos", pos) == FAILURE) + return FAILURE; + + if (less_than_bitsize1 ("i", i, "pos", pos) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -1389,19 +1470,6 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j) gfc_try -gfc_check_ibclr (gfc_expr *i, gfc_expr *pos) -{ - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; - - if (type_check (pos, 1, BT_INTEGER) == FAILURE) - return FAILURE; - - return SUCCESS; -} - - -gfc_try gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) { if (type_check (i, 0, BT_INTEGER) == FAILURE) @@ -1413,17 +1481,13 @@ gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) if (type_check (len, 2, BT_INTEGER) == FAILURE) return FAILURE; - return SUCCESS; -} - + if (nonnegative_check ("pos", pos) == FAILURE) + return FAILURE; -gfc_try -gfc_check_ibset (gfc_expr *i, gfc_expr *pos) -{ - if (type_check (i, 0, BT_INTEGER) == FAILURE) + if (nonnegative_check ("len", len) == FAILURE) return FAILURE; - if (type_check (pos, 1, BT_INTEGER) == FAILURE) + if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE) return FAILURE; return SUCCESS; @@ -2856,21 +2920,45 @@ gfc_check_selected_int_kind (gfc_expr *r) gfc_try -gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) +gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) { - if (p == NULL && r == NULL) + if (p == NULL && r == NULL + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with" + " neither 'P' nor 'R' argument at %L", + gfc_current_intrinsic_where) == FAILURE) + return FAILURE; + + if (p) { - gfc_error ("Missing arguments to %s intrinsic at %L", - gfc_current_intrinsic, gfc_current_intrinsic_where); + if (type_check (p, 0, BT_INTEGER) == FAILURE) + return FAILURE; - return FAILURE; + if (scalar_check (p, 0) == FAILURE) + return FAILURE; } - if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (r) + { + if (type_check (r, 1, BT_INTEGER) == FAILURE) + return FAILURE; - if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (scalar_check (r, 1) == FAILURE) + return FAILURE; + } + + if (radix) + { + if (type_check (radix, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (radix, 1) == FAILURE) + return FAILURE; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with " + "RADIX argument at %L", gfc_current_intrinsic, + &radix->where) == FAILURE) + return FAILURE; + } return SUCCESS; } @@ -3646,6 +3734,22 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, if (type_check (topos, 4, BT_INTEGER) == FAILURE) return FAILURE; + if (nonnegative_check ("frompos", frompos) == FAILURE) + return FAILURE; + + if (nonnegative_check ("topos", topos) == FAILURE) + return FAILURE; + + if (nonnegative_check ("len", len) == FAILURE) + return FAILURE; + + if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len) + == FAILURE) + return FAILURE; + + if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE) + return FAILURE; + return SUCCESS; } diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c index 8dbd157deaa..7f960f5e557 100644 --- a/gcc/fortran/cpp.c +++ b/gcc/fortran/cpp.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "../../libcpp/internal.h" #include "cpp.h" #include "incpath.h" +#include "mkdeps.h" #ifndef TARGET_OS_CPP_BUILTINS # define TARGET_OS_CPP_BUILTINS() @@ -84,6 +85,12 @@ struct gfc_cpp_option_data int no_predefined; /* -undef */ int standard_include_paths; /* -nostdinc */ int verbose; /* -v */ + int deps; /* -M */ + int deps_skip_system; /* -MM */ + const char *deps_filename; /* -M[M]D */ + const char *deps_filename_user; /* -MF <arg> */ + int deps_missing_are_generated; /* -MG */ + int deps_phony; /* -MP */ const char *multilib; /* -imultilib <dir> */ const char *prefix; /* -iprefix <dir> */ @@ -270,6 +277,26 @@ gfc_cpp_preprocess_only (void) return gfc_cpp_option.preprocess_only; } +bool +gfc_cpp_makedep (void) +{ + return gfc_cpp_option.deps; +} + +void +gfc_cpp_add_dep (const char *name, bool system) +{ + if (!gfc_cpp_option.deps_skip_system || !system) + deps_add_dep (cpp_get_deps (cpp_in), name); +} + +void +gfc_cpp_add_target (const char *name) +{ + deps_add_target (cpp_get_deps (cpp_in), name, 0); +} + + const char * gfc_cpp_temporary_file (void) { @@ -299,6 +326,12 @@ gfc_cpp_init_options (unsigned int argc, gfc_cpp_option.no_predefined = 0; gfc_cpp_option.standard_include_paths = 1; gfc_cpp_option.verbose = 0; + gfc_cpp_option.deps = 0; + gfc_cpp_option.deps_skip_system = 0; + gfc_cpp_option.deps_phony = 0; + gfc_cpp_option.deps_missing_are_generated = 0; + gfc_cpp_option.deps_filename = NULL; + gfc_cpp_option.deps_filename_user = NULL; gfc_cpp_option.multilib = NULL; gfc_cpp_option.prefix = NULL; @@ -414,6 +447,43 @@ gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED gfc_cpp_option.print_include_names = 1; break; + case OPT_MM: + gfc_cpp_option.deps_skip_system = 1; + /* fall through */ + + case OPT_M: + gfc_cpp_option.deps = 1; + break; + + case OPT_MMD: + gfc_cpp_option.deps_skip_system = 1; + /* fall through */ + + case OPT_MD: + gfc_cpp_option.deps = 1; + gfc_cpp_option.deps_filename = arg; + break; + + case OPT_MF: + /* If specified multiple times, last one wins. */ + gfc_cpp_option.deps_filename_user = arg; + break; + + case OPT_MG: + gfc_cpp_option.deps_missing_are_generated = 1; + break; + + case OPT_MP: + gfc_cpp_option.deps_phony = 1; + break; + + case OPT_MQ: + case OPT_MT: + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; + gfc_cpp_option.deferred_opt_count++; + break; + case OPT_P: gfc_cpp_option.no_line_commands = 1; break; @@ -430,16 +500,17 @@ gfc_cpp_post_options (void) an error. */ if (!gfc_cpp_enabled () && (gfc_cpp_preprocess_only () - || !gfc_cpp_option.discard_comments - || !gfc_cpp_option.discard_comments_in_macro_exp - || gfc_cpp_option.print_include_names - || gfc_cpp_option.no_line_commands - || gfc_cpp_option.dump_macros - || gfc_cpp_option.dump_includes)) + || gfc_cpp_makedep () + || !gfc_cpp_option.discard_comments + || !gfc_cpp_option.discard_comments_in_macro_exp + || gfc_cpp_option.print_include_names + || gfc_cpp_option.no_line_commands + || gfc_cpp_option.dump_macros + || gfc_cpp_option.dump_includes)) gfc_fatal_error("To enable preprocessing, use -cpp"); cpp_in = cpp_create_reader (CLK_GNUC89, NULL, line_table); - if (!gfc_cpp_enabled()) + if (!gfc_cpp_enabled ()) return; gcc_assert (cpp_in); @@ -462,6 +533,17 @@ gfc_cpp_post_options (void) cpp_option->print_include_names = gfc_cpp_option.print_include_names; cpp_option->preprocessed = gfc_option.flag_preprocessed; + if (gfc_cpp_makedep ()) + { + cpp_option->deps.style = DEPS_USER; + cpp_option->deps.phony_targets = gfc_cpp_option.deps_phony; + cpp_option->deps.missing_files = gfc_cpp_option.deps_missing_are_generated; + + /* -MF <arg> overrides -M[M]D. */ + if (gfc_cpp_option.deps_filename_user) + gfc_cpp_option.deps_filename = gfc_cpp_option.deps_filename_user; + } + if (gfc_cpp_option.working_directory == -1) gfc_cpp_option.working_directory = (debug_info_level != DINFO_LEVEL_NONE); @@ -572,6 +654,9 @@ gfc_cpp_init (void) else cpp_assert (cpp_in, opt->arg); } + else if (opt->code == OPT_MT || opt->code == OPT_MQ) + deps_add_target (cpp_get_deps (cpp_in), + opt->arg, opt->code == OPT_MQ); } if (gfc_cpp_option.working_directory @@ -615,14 +700,27 @@ gfc_cpp_done (void) if (!gfc_cpp_enabled ()) return; - /* TODO: if dependency tracking was enabled, call - cpp_finish() here to write dependencies. + gcc_assert (cpp_in); - Use cpp_get_deps() to access the current source's - dependencies during parsing. Add dependencies using - the mkdeps-interface (defined in libcpp). */ + if (gfc_cpp_makedep ()) + { + if (gfc_cpp_option.deps_filename) + { + FILE *f = fopen (gfc_cpp_option.deps_filename, "w"); + if (f) + { + cpp_finish (cpp_in, f); + fclose (f); + } + else + gfc_fatal_error ("opening output file %s: %s", + gfc_cpp_option.deps_filename, + xstrerror (errno)); + } + else + cpp_finish (cpp_in, stdout); + } - gcc_assert (cpp_in); cpp_undef_all (cpp_in); cpp_clear_file_cache (cpp_in); } diff --git a/gcc/fortran/cpp.h b/gcc/fortran/cpp.h index 54a899f6a8e..556eecbc099 100644 --- a/gcc/fortran/cpp.h +++ b/gcc/fortran/cpp.h @@ -24,6 +24,12 @@ bool gfc_cpp_enabled (void); bool gfc_cpp_preprocess_only (void); +bool gfc_cpp_makedep (void); + +void gfc_cpp_add_dep (const char *name, bool system); + +void gfc_cpp_add_target (const char *name); + const char *gfc_cpp_temporary_file (void); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 9786a860bae..07c3acb9467 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1764,7 +1764,7 @@ variable_decl (int elem) specified in the procedure definition, except that the interface may specify a procedure that is not pure if the procedure is defined to be pure(12.3.2). */ - if (current_ts.type == BT_DERIVED + if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) && gfc_current_ns->proc_name && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY && current_ts.u.derived->ns != gfc_current_ns) @@ -2342,7 +2342,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_symbol *sym; match m; char c; - bool seen_deferred_kind; + bool seen_deferred_kind, matched_type; /* A belt and braces check that the typespec is correctly being treated as a deferred characteristic association. */ @@ -2374,47 +2374,88 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; } - if (gfc_match (" integer") == MATCH_YES) + + m = gfc_match (" type ( %n", name); + matched_type = (m == MATCH_YES); + + if ((matched_type && strcmp ("integer", name) == 0) + || (!matched_type && gfc_match (" integer") == MATCH_YES)) { ts->type = BT_INTEGER; ts->kind = gfc_default_integer_kind; goto get_kind; } - if (gfc_match (" character") == MATCH_YES) + if ((matched_type && strcmp ("character", name) == 0) + || (!matched_type && gfc_match (" character") == MATCH_YES)) { + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + ts->type = BT_CHARACTER; if (implicit_flag == 0) - return gfc_match_char_spec (ts); + m = gfc_match_char_spec (ts); else - return MATCH_YES; + m = MATCH_YES; + + if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) + m = MATCH_ERROR; + + return m; } - if (gfc_match (" real") == MATCH_YES) + if ((matched_type && strcmp ("real", name) == 0) + || (!matched_type && gfc_match (" real") == MATCH_YES)) { ts->type = BT_REAL; ts->kind = gfc_default_real_kind; goto get_kind; } - if (gfc_match (" double precision") == MATCH_YES) + if ((matched_type + && (strcmp ("doubleprecision", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" precision") == MATCH_YES))) + || (!matched_type && gfc_match (" double precision") == MATCH_YES)) { + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + ts->type = BT_REAL; ts->kind = gfc_default_double_kind; return MATCH_YES; } - if (gfc_match (" complex") == MATCH_YES) + if ((matched_type && strcmp ("complex", name) == 0) + || (!matched_type && gfc_match (" complex") == MATCH_YES)) { ts->type = BT_COMPLEX; ts->kind = gfc_default_complex_kind; goto get_kind; } - if (gfc_match (" double complex") == MATCH_YES) + if ((matched_type + && (strcmp ("doublecomplex", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" complex") == MATCH_YES))) + || (!matched_type && gfc_match (" double complex") == MATCH_YES)) { - if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not " - "conform to the Fortran 95 standard") == FAILURE) + if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C") + == FAILURE) + return MATCH_ERROR; + + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + + if (matched_type && gfc_match_char (')') != MATCH_YES) return MATCH_ERROR; ts->type = BT_COMPLEX; @@ -2422,14 +2463,17 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; } - if (gfc_match (" logical") == MATCH_YES) + if ((matched_type && strcmp ("logical", name) == 0) + || (!matched_type && gfc_match (" logical") == MATCH_YES)) { ts->type = BT_LOGICAL; ts->kind = gfc_default_logical_kind; goto get_kind; } - m = gfc_match (" type ( %n )", name); + if (matched_type) + m = gfc_match_char (')'); + if (m == MATCH_YES) ts->type = BT_DERIVED; else @@ -2490,23 +2534,43 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; get_kind: + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + /* For all types except double, derived and character, look for an optional kind specifier. MATCH_NO is actually OK at this point. */ if (implicit_flag == 1) - return MATCH_YES; + { + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + + return MATCH_YES; + } if (gfc_current_form == FORM_FREE) { c = gfc_peek_ascii_char (); if (!gfc_is_whitespace (c) && c != '*' && c != '(' && c != ':' && c != ',') - return MATCH_NO; + { + if (matched_type && c == ')') + { + gfc_next_ascii_char (); + return MATCH_YES; + } + return MATCH_NO; + } } m = gfc_match_kind_spec (ts, false); if (m == MATCH_NO && ts->type != BT_CHARACTER) m = gfc_match_old_kind_spec (ts); + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + /* Defer association of the KIND expression of function results until after USE and IMPORT statements. */ if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) @@ -2875,8 +2939,8 @@ match_attr_spec (void) DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, - DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE, - GFC_DECL_END /* Sentinel */ + DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, + DECL_NONE, GFC_DECL_END /* Sentinel */ } decl_types; @@ -2939,6 +3003,7 @@ match_attr_spec (void) } break; } + break; case 'b': /* Try and match the bind(c). */ @@ -2950,8 +3015,24 @@ match_attr_spec (void) break; case 'c': - if (match_string_p ("codimension")) - d = DECL_CODIMENSION; + gfc_next_ascii_char (); + if ('o' != gfc_next_ascii_char ()) + break; + switch (gfc_next_ascii_char ()) + { + case 'd': + if (match_string_p ("imension")) + { + d = DECL_CODIMENSION; + break; + } + case 'n': + if (match_string_p ("tiguous")) + { + d = DECL_CONTIGUOUS; + break; + } + } break; case 'd': @@ -3144,6 +3225,9 @@ match_attr_spec (void) case DECL_CODIMENSION: attr = "CODIMENSION"; break; + case DECL_CONTIGUOUS: + attr = "CONTIGUOUS"; + break; case DECL_DIMENSION: attr = "DIMENSION"; break; @@ -3214,7 +3298,7 @@ match_attr_spec (void) if (gfc_current_state () == COMP_DERIVED && d != DECL_DIMENSION && d != DECL_CODIMENSION && d != DECL_POINTER && d != DECL_PRIVATE - && d != DECL_PUBLIC && d != DECL_NONE) + && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) { if (d == DECL_ALLOCATABLE) { @@ -3283,6 +3367,15 @@ match_attr_spec (void) t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); break; + case DECL_CONTIGUOUS: + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: CONTIGUOUS attribute at %C") + == FAILURE) + t = FAILURE; + else + t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]); + break; + case DECL_DIMENSION: t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); break; @@ -4934,6 +5027,10 @@ gfc_match_entry (void) if (m != MATCH_YES) return m; + if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: " + "ENTRY statement at %C") == FAILURE) + return MATCH_ERROR; + state = gfc_current_state (); if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) { @@ -5483,14 +5580,23 @@ gfc_match_end (gfc_statement *st) block_name = gfc_current_block () == NULL ? NULL : gfc_current_block ()->name; - if (state == COMP_BLOCK && !strcmp (block_name, "block@")) - block_name = NULL; - - if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS) + switch (state) { + case COMP_ASSOCIATE: + case COMP_BLOCK: + if (!strcmp (block_name, "block@")) + block_name = NULL; + break; + + case COMP_CONTAINS: + case COMP_DERIVED_CONTAINS: state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL ? NULL : gfc_state_stack->previous->sym->name; + break; + + default: + break; } switch (state) @@ -5539,6 +5645,12 @@ gfc_match_end (gfc_statement *st) eos_ok = 0; break; + case COMP_ASSOCIATE: + *st = ST_END_ASSOCIATE; + target = " associate"; + eos_ok = 0; + break; + case COMP_BLOCK: *st = ST_END_BLOCK; target = " block"; @@ -5598,7 +5710,14 @@ gfc_match_end (gfc_statement *st) if (gfc_match_eos () == MATCH_YES) { - if (!eos_ok) + if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement " + "instead of %s statement at %L", + gfc_ascii_statement (*st), &old_loc) == FAILURE) + goto cleanup; + } + else if (!eos_ok) { /* We would have required END [something]. */ gfc_error ("%s statement expected at %L", @@ -5622,7 +5741,7 @@ gfc_match_end (gfc_statement *st) if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK - && *st != ST_END_CRITICAL) + && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) return MATCH_YES; if (!block_name) @@ -6106,6 +6225,20 @@ gfc_match_codimension (void) match +gfc_match_contiguous (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C") + == FAILURE) + return MATCH_ERROR; + + gfc_clear_attr (¤t_attr); + current_attr.contiguous = 1; + + return attr_decl (); +} + + +match gfc_match_dimension (void) { gfc_clear_attr (¤t_attr); @@ -7527,14 +7660,15 @@ match_procedure_in_type (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; char target_buf[GFC_MAX_SYMBOL_LEN + 1]; - char* target = NULL; - gfc_typebound_proc* tb; + char* target = NULL, *ifc = NULL; + gfc_typebound_proc tb; bool seen_colons; bool seen_attrs; match m; gfc_symtree* stree; gfc_namespace* ns; gfc_symbol* block; + int num; /* Check current state. */ gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); @@ -7559,28 +7693,26 @@ match_procedure_in_type (void) return MATCH_ERROR; } - target = target_buf; + ifc = target_buf; } /* Construct the data structure. */ - tb = gfc_get_typebound_proc (); - tb->where = gfc_current_locus; - tb->is_generic = 0; + tb.where = gfc_current_locus; + tb.is_generic = 0; /* Match binding attributes. */ - m = match_binding_attributes (tb, false, false); + m = match_binding_attributes (&tb, false, false); if (m == MATCH_ERROR) return m; seen_attrs = (m == MATCH_YES); - /* Check that attribute DEFERRED is given iff an interface is specified, which - means target != NULL. */ - if (tb->deferred && !target) + /* Check that attribute DEFERRED is given if an interface is specified. */ + if (tb.deferred && !ifc) { gfc_error ("Interface must be specified for DEFERRED binding at %C"); return MATCH_ERROR; } - if (target && !tb->deferred) + if (ifc && !tb.deferred) { gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED"); return MATCH_ERROR; @@ -7597,97 +7729,103 @@ match_procedure_in_type (void) return MATCH_ERROR; } - /* Match the binding name. */ - m = gfc_match_name (name); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_NO) - { - gfc_error ("Expected binding name at %C"); - return MATCH_ERROR; - } - - /* Try to match the '=> target', if it's there. */ - m = gfc_match (" =>"); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_YES) + /* Match the binding names. */ + for(num=1;;num++) { - if (tb->deferred) + m = gfc_match_name (name); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) { - gfc_error ("'=> target' is invalid for DEFERRED binding at %C"); + gfc_error ("Expected binding name at %C"); return MATCH_ERROR; } - if (!seen_colons) - { - gfc_error ("'::' needed in PROCEDURE binding with explicit target" - " at %C"); - return MATCH_ERROR; - } + if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list" + " at %C") == FAILURE) + return MATCH_ERROR; - m = gfc_match_name (target_buf); + /* Try to match the '=> target', if it's there. */ + target = ifc; + m = gfc_match (" =>"); if (m == MATCH_ERROR) return m; - if (m == MATCH_NO) + if (m == MATCH_YES) { - gfc_error ("Expected binding target after '=>' at %C"); - return MATCH_ERROR; + if (tb.deferred) + { + gfc_error ("'=> target' is invalid for DEFERRED binding at %C"); + return MATCH_ERROR; + } + + if (!seen_colons) + { + gfc_error ("'::' needed in PROCEDURE binding with explicit target" + " at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (target_buf); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding target after '=>' at %C"); + return MATCH_ERROR; + } + target = target_buf; } - target = target_buf; - } - /* Now we should have the end. */ - m = gfc_match_eos (); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_NO) - { - gfc_error ("Junk after PROCEDURE declaration at %C"); - return MATCH_ERROR; - } + /* If no target was found, it has the same name as the binding. */ + if (!target) + target = name; - /* If no target was found, it has the same name as the binding. */ - if (!target) - target = name; + /* Get the namespace to insert the symbols into. */ + ns = block->f2k_derived; + gcc_assert (ns); - /* Get the namespace to insert the symbols into. */ - ns = block->f2k_derived; - gcc_assert (ns); + /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ + if (tb.deferred && !block->attr.abstract) + { + gfc_error ("Type '%s' containing DEFERRED binding at %C " + "is not ABSTRACT", block->name); + return MATCH_ERROR; + } - /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ - if (tb->deferred && !block->attr.abstract) - { - gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT", - block->name); - return MATCH_ERROR; - } + /* See if we already have a binding with this name in the symtree which + would be an error. If a GENERIC already targetted this binding, it may + be already there but then typebound is still NULL. */ + stree = gfc_find_symtree (ns->tb_sym_root, name); + if (stree && stree->n.tb) + { + gfc_error ("There is already a procedure with binding name '%s' for " + "the derived type '%s' at %C", name, block->name); + return MATCH_ERROR; + } - /* See if we already have a binding with this name in the symtree which would - be an error. If a GENERIC already targetted this binding, it may be - already there but then typebound is still NULL. */ - stree = gfc_find_symtree (ns->tb_sym_root, name); - if (stree && stree->n.tb) - { - gfc_error ("There's already a procedure with binding name '%s' for the" - " derived type '%s' at %C", name, block->name); - return MATCH_ERROR; - } + /* Insert it and set attributes. */ - /* Insert it and set attributes. */ + if (!stree) + { + stree = gfc_new_symtree (&ns->tb_sym_root, name); + gcc_assert (stree); + } + stree->n.tb = gfc_get_typebound_proc (&tb); - if (!stree) - { - stree = gfc_new_symtree (&ns->tb_sym_root, name); - gcc_assert (stree); + if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific, + false)) + return MATCH_ERROR; + gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; } - stree->n.tb = tb; - - if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false)) - return MATCH_ERROR; - gfc_set_sym_referenced (tb->u.specific->n.sym); - return MATCH_YES; +syntax: + gfc_error ("Syntax error in PROCEDURE statement at %C"); + return MATCH_ERROR; } @@ -7821,7 +7959,7 @@ gfc_match_generic (void) } else { - tb = gfc_get_typebound_proc (); + tb = gfc_get_typebound_proc (NULL); tb->where = gfc_current_locus; tb->access = tbattr.access; tb->is_generic = 1; diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index 87f60df8e2a..fcf5b25d350 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -1588,4 +1588,3 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref) return fin_dep == GFC_DEP_OVERLAP; } - diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index 6fa0416e2a7..dd786bedaba 100644 --- a/gcc/fortran/dependency.h +++ b/gcc/fortran/dependency.h @@ -43,3 +43,4 @@ int gfc_expr_is_one (gfc_expr *, int); int gfc_dep_resolver(gfc_ref *, gfc_ref *); int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); + diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index e90b0941885..1a649106f15 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -598,6 +598,8 @@ show_attr (symbol_attribute *attr) fputs (" CODIMENSION", dumpfile); if (attr->dimension) fputs (" DIMENSION", dumpfile); + if (attr->contiguous) + fputs (" CONTIGUOUS", dumpfile); if (attr->external) fputs (" EXTERNAL", dumpfile); if (attr->intrinsic) @@ -794,6 +796,15 @@ show_symbol (gfc_symbol *sym) fprintf (dumpfile, "symbol %s ", sym->name); show_typespec (&sym->ts); + + /* If this symbol is an associate-name, show its target expression. */ + if (sym->assoc) + { + fputs (" => ", dumpfile); + show_expr (sym->assoc->target); + fputs (" ", dumpfile); + } + show_attr (&sym->attr); if (sym->value) @@ -853,7 +864,7 @@ show_symbol (gfc_symbol *sym) } } - if (sym->formal_ns) + if (sym->formal_ns && (sym->formal_ns->proc_name != sym)) { show_indent (); fputs ("Formal namespace", dumpfile); @@ -1175,6 +1186,7 @@ show_code_node (int level, gfc_code *c) gfc_filepos *fp; gfc_inquire *i; gfc_dt *dt; + gfc_namespace *ns; code_indent (level, c->here); @@ -1374,6 +1386,22 @@ show_code_node (int level, gfc_code *c) fputs ("ENDIF", dumpfile); break; + case EXEC_BLOCK: + { + const char* blocktype; + if (c->ext.block.assoc) + blocktype = "ASSOCIATE"; + else + blocktype = "BLOCK"; + show_indent (); + fprintf (dumpfile, "%s ", blocktype); + ns = c->ext.block.ns; + show_namespace (ns); + show_indent (); + fprintf (dumpfile, "END %s ", blocktype); + break; + } + case EXEC_SELECT: d = c->block; fputs ("SELECT CASE ", dumpfile); @@ -2144,7 +2172,7 @@ show_namespace (gfc_namespace *ns) fputc ('\n', dumpfile); fputc ('\n', dumpfile); - show_code (0, ns->code); + show_code (show_level, ns->code); for (ns = ns->contained; ns; ns = ns->sibling) { diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index b05e669c370..30928286c98 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -471,7 +471,7 @@ error_print (const char *type, const char *format0, va_list argp) locus *l1, *l2, *loc; const char *format; - l1 = l2 = NULL; + loc = l1 = l2 = NULL; have_l1 = 0; pos = -1; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b6452054b11..c876fdd7740 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4080,3 +4080,105 @@ gfc_has_ultimate_pointer (gfc_expr *e) else return false; } + + +/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. + Note: A scalar is not regarded as "simply contiguous" by the standard. + if bool is not strict, some futher checks are done - for instance, + a "(::1)" is accepted. */ + +bool +gfc_is_simply_contiguous (gfc_expr *expr, bool strict) +{ + bool colon; + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref, *part_ref = NULL; + + if (expr->expr_type == EXPR_FUNCTION) + return expr->value.function.esym + ? expr->value.function.esym->result->attr.contiguous : false; + else if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (expr->rank == 0) + return false; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ar) + return false; /* Array shall be last part-ref. */ + + if (ref->type == REF_COMPONENT) + part_ref = ref; + else if (ref->type == REF_SUBSTRING) + return false; + else if (ref->u.ar.type != AR_ELEMENT) + ar = &ref->u.ar; + } + + if ((part_ref && !part_ref->u.c.component->attr.contiguous + && part_ref->u.c.component->attr.pointer) + || (!part_ref && !expr->symtree->n.sym->attr.contiguous + && (expr->symtree->n.sym->attr.pointer + || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))) + return false; + + if (!ar || ar->type == AR_FULL) + return true; + + gcc_assert (ar->type == AR_SECTION); + + /* Check for simply contiguous array */ + colon = true; + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_VECTOR) + return false; + + if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + colon = false; + continue; + } + + gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); + + + /* If the previous section was not contiguous, that's an error, + unless we have effective only one element and checking is not + strict. */ + if (!colon && (strict || !ar->start[i] || !ar->end[i] + || ar->start[i]->expr_type != EXPR_CONSTANT + || ar->end[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->end[i]->value.integer) != 0)) + return false; + + /* Following the standard, "(::1)" or - if known at compile time - + "(lbound:ubound)" are not simply contigous; if strict + is false, they are regarded as simply contiguous. */ + if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT + || ar->stride[i]->ts.type != BT_INTEGER + || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) + return false; + + if (ar->start[i] + && (strict || ar->start[i]->expr_type != EXPR_CONSTANT + || !ar->as->lower[i] + || ar->as->lower[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->as->lower[i]->value.integer) != 0)) + colon = false; + + if (ar->end[i] + && (strict || ar->end[i]->expr_type != EXPR_CONSTANT + || !ar->as->upper[i] + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->end[i]->value.integer, + ar->as->upper[i]->value.integer) != 0)) + colon = false; + } + + return true; +} diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 14525dc2552..c6af0026ba8 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -111,6 +111,7 @@ static void gfc_init_ts (void); #undef LANG_HOOKS_INIT_TS #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING +#undef LANG_HOOKS_OMP_REPORT_DECL #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR #undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR #undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP @@ -137,6 +138,7 @@ static void gfc_init_ts (void); #define LANG_HOOKS_INIT_TS gfc_init_ts #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference #define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing +#define LANG_HOOKS_OMP_REPORT_DECL gfc_omp_report_decl #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor #define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor #define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP gfc_omp_clause_assign_op @@ -350,8 +352,7 @@ getdecls (void) void pushlevel (int ignore ATTRIBUTE_UNUSED) { - struct binding_level *newlevel - = (struct binding_level *) ggc_alloc (sizeof (struct binding_level)); + struct binding_level *newlevel = ggc_alloc_binding_level (); *newlevel = clear_binding_level; @@ -754,10 +755,11 @@ gfc_init_builtin_functions (void) func_longdouble_longdoublep_longdoublep = build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); +/* Non-math builtins are defined manually, so they're not included here. */ +#define OTHER_BUILTIN(ID,NAME,TYPE) + #include "mathbuiltins.def" - /* We define these separately as the fortran versions have different - semantics (they return an integer type) */ gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0], BUILT_IN_ROUNDL, "roundl", true); gfc_define_builtin ("__builtin_round", mfunc_double[0], diff --git a/gcc/fortran/gfc-internals.texi b/gcc/fortran/gfc-internals.texi index f01393e3d68..90f90fdac5d 100644 --- a/gcc/fortran/gfc-internals.texi +++ b/gcc/fortran/gfc-internals.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfc-internals.info -@set copyrights-gfortran 2007-2010 +@set copyrights-gfortran 2007, 2008, 2009, 2010 @include gcc-common.texi @@ -35,7 +35,7 @@ Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9762cddfaa8..0c96bf40e6e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -205,11 +205,12 @@ arith; /* Statements. */ typedef enum { - ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE, - ST_BLOCK, ST_BLOCK_DATA, + ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_ASSOCIATE, + ST_BACKSPACE, ST_BLOCK, ST_BLOCK_DATA, ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE, ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF, - ST_ELSEWHERE, ST_END_BLOCK, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO, + ST_ELSEWHERE, ST_END_ASSOCIATE, ST_END_BLOCK, ST_END_BLOCK_DATA, + ST_ENDDO, ST_IMPLIED_ENDDO, ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, @@ -664,7 +665,8 @@ typedef struct unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1, optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, - implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1; + implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1, + contiguous:1; /* For CLASS containers, the pointer attribute is sometimes set internally even though it was not directly specified. In this case, keep the @@ -1201,6 +1203,9 @@ typedef struct gfc_symbol char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; /* Store a reference to the common_block, if this symbol is in one. */ struct gfc_common_head *common_block; + + /* Link to corresponding association-list if this is an associate name. */ + struct gfc_association_list *assoc; } gfc_symbol; @@ -1665,10 +1670,13 @@ typedef struct gfc_expr it from recurring. */ unsigned int error : 1; - /* Mark and expression where a user operator has been substituted by + /* Mark an expression where a user operator has been substituted by a function call in interface.c(gfc_extend_expr). */ unsigned int user_operator : 1; + /* Mark an expression as being a MOLD argument of ALLOCATE. */ + unsigned int mold : 1; + /* If an expression comes from a Hollerith constant or compile-time evaluation of a transfer statement, it may have a prescribed target- memory representation, and these cannot always be backformed from @@ -1974,6 +1982,25 @@ typedef struct gfc_forall_iterator gfc_forall_iterator; +/* Linked list to store associations in an ASSOCIATE statement. */ + +typedef struct gfc_association_list +{ + struct gfc_association_list *next; + + /* Whether this is association to a variable that can be changed; otherwise, + it's association to an expression and the name may not be used as + lvalue. */ + unsigned variable:1; + + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree *st; /* Symtree corresponding to name. */ + gfc_expr *target; +} +gfc_association_list; +#define gfc_get_association_list() XCNEW (gfc_association_list) + + /* Executable statements that fill gfc_code structures. */ typedef enum { @@ -2026,6 +2053,13 @@ typedef struct gfc_code } alloc; + struct + { + gfc_namespace *ns; + gfc_association_list *assoc; + } + block; + gfc_open *open; gfc_close *close; gfc_filepos *filepos; @@ -2040,13 +2074,12 @@ typedef struct gfc_code const char *omp_name; gfc_namelist *omp_namelist; bool omp_bool; - gfc_namespace *ns; } ext; /* Points to additional structures required by statement */ - /* Backend_decl is used for cycle and break labels in do loops, and - probably for other constructs as well, once we translate them. */ - tree backend_decl; + /* Cycle and break labels in do loops. */ + tree cycle_label; + tree exit_label; } gfc_code; @@ -2405,6 +2438,7 @@ gfc_try gfc_add_attribute (symbol_attribute *, locus *); gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *); gfc_try gfc_add_allocatable (symbol_attribute *, locus *); gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *); +gfc_try gfc_add_contiguous (symbol_attribute *, const char *, locus *); gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *); gfc_try gfc_add_external (symbol_attribute *, locus *); gfc_try gfc_add_intrinsic (symbol_attribute *, locus *); @@ -2513,7 +2547,7 @@ void gfc_free_dt_list (void); gfc_gsymbol *gfc_get_gsymbol (const char *); gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); -gfc_typebound_proc* gfc_get_typebound_proc (void); +gfc_typebound_proc* gfc_get_typebound_proc (gfc_typebound_proc*); gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*); bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *); @@ -2582,6 +2616,7 @@ void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); const char *gfc_extract_int (gfc_expr *, int *); bool is_subref_array (gfc_expr *); +bool gfc_is_simply_contiguous (gfc_expr *, bool); gfc_expr *gfc_build_conversion (gfc_expr *); void gfc_free_ref_list (gfc_ref *); @@ -2647,6 +2682,7 @@ gfc_code *gfc_get_code (void); gfc_code *gfc_append_code (gfc_code *, gfc_code *); void gfc_free_statement (gfc_code *); void gfc_free_statements (gfc_code *); +void gfc_free_association_list (gfc_association_list *); /* resolve.c */ gfc_try gfc_resolve_expr (gfc_expr *); @@ -2719,6 +2755,7 @@ void gfc_set_current_interface_head (gfc_interface *); gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus); +int gfc_has_vector_subscript (gfc_expr*); /* io.c */ extern gfc_st_label format_asterisk; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index a7f6fbac220..8d43c8bf8a4 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1,7 +1,7 @@ \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfortran.info -@set copyrights-gfortran 1999-2010 +@set copyrights-gfortran 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 @include gcc-common.texi @@ -80,7 +80,7 @@ Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) @@ -1515,10 +1515,10 @@ to Cray pointers and pointees. Pointees may not have the @code{ALLOCATABLE}, @code{INTENT}, @code{OPTIONAL}, @code{DUMMY}, @code{TARGET}, @code{INTRINSIC}, or @code{POINTER} attributes. Pointers may not have the @code{DIMENSION}, @code{POINTER}, @code{TARGET}, -@code{ALLOCATABLE}, @code{EXTERNAL}, or @code{INTRINSIC} attributes. -Pointees may not occur in more than one pointer statement. A pointee -cannot be a pointer. Pointees cannot occur in equivalence, common, or -data statements. +@code{ALLOCATABLE}, @code{EXTERNAL}, or @code{INTRINSIC} attributes, nor +may they be function results. Pointees may not occur in more than one +pointer statement. A pointee cannot be a pointer. Pointees cannot occur +in equivalence, common, or data statements. A Cray pointer may also point to a function or a subroutine. For example, the following excerpt is valid: @@ -1719,7 +1719,8 @@ code that uses them running with the GNU Fortran compiler. @c * TYPE and ACCEPT I/O Statements:: @c * .XOR. operator:: @c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers:: -@c * Omitted arguments in procedure call: +@c * Omitted arguments in procedure call:: +* Alternate complex function syntax:: @end menu @@ -1894,6 +1895,18 @@ c @end smallexample +@node Alternate complex function syntax +@subsection Alternate complex function syntax +@cindex Complex function + +Some Fortran compilers, including @command{g77}, let the user declare +complex functions with the syntax @code{COMPLEX FUNCTION name*16()}, as +well as @code{COMPLEX*16 FUNCTION name()}. Both are non-standard, legacy +extensions. @command{gfortran} accepts the latter form, which is more +common, but not the former. + + + @c --------------------------------------------------------------------- @c Mixed-Language Programming @c --------------------------------------------------------------------- @@ -2322,9 +2335,10 @@ if e.g. an input-output edit descriptor is invalid in a given standard. Possible values are (bitwise or-ed) @code{GFC_STD_F77} (1), @code{GFC_STD_F95_OBS} (2), @code{GFC_STD_F95_DEL} (4), @code{GFC_STD_F95} (8), @code{GFC_STD_F2003} (16), @code{GFC_STD_GNU} (32), -@code{GFC_STD_LEGACY} (64), and @code{GFC_STD_F2008} (128). -Default: @code{GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F2003 -| GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY}. +@code{GFC_STD_LEGACY} (64), @code{GFC_STD_F2008} (128), and +@code{GFC_STD_F2008_OBS} (256). Default: @code{GFC_STD_F95_OBS +| GFC_STD_F95_DEL | GFC_STD_F95 | GFC_STD_F2003 | GFC_STD_F2008 +| GFC_STD_F2008_OBS | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY}. @item @var{option}[1] @tab Standard-warning flag; prints a warning to standard error. Default: @code{GFC_STD_F95_DEL | GFC_STD_LEGACY}. @item @var{option}[2] @tab If non zero, enable pedantic checking. @@ -2639,9 +2653,6 @@ J3 Fortran 95 standard. User-specified alignment rules for structures. @item -Flag to generate @code{Makefile} info. - -@item Automatically extend single precision constants to double. @item diff --git a/gcc/fortran/gfortranspec.c b/gcc/fortran/gfortranspec.c index 1f67acc1513..61f1547c87c 100644 --- a/gcc/fortran/gfortranspec.c +++ b/gcc/fortran/gfortranspec.c @@ -244,7 +244,7 @@ append_arg (const char *arg) } if (g77_newargc == newargsize) - fatal_error ("overflowed output arg list for '%s'", arg); + fatal_error ("overflowed output arg list for %qs", arg); g77_newargv[g77_newargc++] = arg; } @@ -402,7 +402,7 @@ For more information about these matters, see the file named COPYING\n\n")); if (i + skip < argc) i += skip; else - fatal_error ("argument to '%s' missing", argv[i]); + fatal_error ("argument to %qs missing", argv[i]); } if ((n_outfiles != 0) && (n_infiles == 0)) @@ -424,35 +424,6 @@ For more information about these matters, see the file named COPYING\n\n")); continue; } - if ((argv[i][0] == '-') && (argv[i][1] == 'M')) - { - char *p; - - warning (0, "using -M <directory> is deprecated, use -J instead"); - if (argv[i][2] == '\0') - { - if (i+1 < argc) - { - p = XNEWVEC (char, strlen (argv[i + 1]) + 3); - p[0] = '-'; - p[1] = 'J'; - strcpy (&p[2], argv[i + 1]); - i++; - } - else - fatal_error ("argument to '%s' missing", argv[i]); - } - else - { - p = XNEWVEC (char, strlen (argv[i]) + 1); - p[0] = '-'; - p[1] = 'J'; - strcpy (&p[2], argv[i] + 2); - } - append_arg (p); - continue; - } - if ((argv[i][0] == '-') && (argv[i][1] != 'l')) { /* Not a filename or library. */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 99ade9d273d..587b09cdf8c 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1376,6 +1376,30 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual) } +/* Emit clear error messages for rank mismatch. */ + +static void +argument_rank_mismatch (const char *name, locus *where, + int rank1, int rank2) +{ + if (rank1 == 0) + { + gfc_error ("Rank mismatch in argument '%s' at %L " + "(scalar and rank-%d)", name, where, rank2); + } + else if (rank2 == 0) + { + gfc_error ("Rank mismatch in argument '%s' at %L " + "(rank-%d and scalar)", name, where, rank1); + } + else + { + gfc_error ("Rank mismatch in argument '%s' at %L " + "(rank-%d and rank-%d)", name, where, rank1, rank2); + } +} + + /* Given a symbol of a formal argument list and an expression, see if the two are compatible as arguments. Returns nonzero if compatible, zero if not compatible. */ @@ -1435,6 +1459,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 1; } + /* F2008, C1241. */ + if (formal->attr.pointer && formal->attr.contiguous + && !gfc_is_simply_contiguous (actual, true)) + { + if (where) + gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L " + "must be simply contigous", formal->name, &actual->where); + return 0; + } + if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && !gfc_compare_types (&formal->ts, &actual->ts)) { @@ -1502,6 +1536,34 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, : actual->symtree->n.sym->as->corank); return 0; } + + /* F2008, 12.5.2.8. */ + if (formal->attr.dimension + && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) + && !gfc_is_simply_contiguous (actual, true)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be simply " + "contiguous", formal->name, &actual->where); + return 0; + } + } + + /* F2008, C1239/C1240. */ + if (actual->expr_type == EXPR_VARIABLE + && (actual->symtree->n.sym->attr.asynchronous + || actual->symtree->n.sym->attr.volatile_) + && (formal->attr.asynchronous || formal->attr.volatile_) + && actual->rank && !gfc_is_simply_contiguous (actual, true) + && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer) + || formal->attr.contiguous)) + { + if (where) + gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape " + "array without CONTIGUOUS attribute - as actual argument at" + " %L is not simply contiguous and both are ASYNCHRONOUS " + "or VOLATILE", formal->name, &actual->where); + return 0; } if (symbol_rank (formal) == actual->rank) @@ -1521,9 +1583,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && gfc_is_coindexed (actual))) { if (where) - gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)", - formal->name, &actual->where, symbol_rank (formal), - actual->rank); + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank); return 0; } else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) @@ -1562,9 +1623,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, else if (ref == NULL && actual->expr_type != EXPR_NULL) { if (where) - gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)", - formal->name, &actual->where, symbol_rank (formal), - actual->rank); + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank); return 0; } @@ -1821,8 +1881,8 @@ get_expr_storage_size (gfc_expr *e) which has a vector subscript. If it has, one is returned, otherwise zero. */ -static int -has_vector_subscript (gfc_expr *e) +int +gfc_has_vector_subscript (gfc_expr *e) { int i; gfc_ref *ref; @@ -2133,13 +2193,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if ((f->sym->attr.intent == INTENT_OUT || f->sym->attr.intent == INTENT_INOUT - || f->sym->attr.volatile_) - && has_vector_subscript (a->expr)) + || f->sym->attr.volatile_ + || f->sym->attr.asynchronous) + && gfc_has_vector_subscript (a->expr)) { if (where) - gfc_error ("Array-section actual argument with vector subscripts " - "at %L is incompatible with INTENT(OUT), INTENT(INOUT) " - "or VOLATILE attribute of the dummy argument '%s'", + gfc_error ("Array-section actual argument with vector " + "subscripts at %L is incompatible with INTENT(OUT), " + "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " + "of the dummy argument '%s'", &a->expr->where, f->sym->name); return 0; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index a92b5b54519..833fd30beb1 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1354,7 +1354,7 @@ add_functions (void) make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95); add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest, + gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest, i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95); @@ -1738,7 +1738,7 @@ add_functions (void) make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU); add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr, + gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr, i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95); @@ -1751,7 +1751,7 @@ add_functions (void) make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95); add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset, + gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset, i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95); @@ -2375,10 +2375,11 @@ add_functions (void) make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); - add_sym_2 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, + add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_selected_real_kind, gfc_simplify_selected_real_kind, NULL, - p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL); + p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL, + "radix", BT_INTEGER, di, OPTIONAL); make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95); @@ -4022,58 +4023,67 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) } else if (wflag) { - /* Two modes of warning: - - gfc_option.warn_conversion tries to be more intelligent - about the warnings raised and omits those where smaller - kinds are promoted to larger ones without change in the - value - - gfc_option.warn_conversion_extra does not take the kinds - into account and also warns for coversions like - REAL(4) -> REAL(8) - - NOTE: Possible enhancement for warn_conversion - If converting from a smaller to a larger kind, check if the - value is constant and if yes, whether the value still fits - in the smaller kind. If yes, omit the warning. - */ - - /* If the types are the same (but not LOGICAL), and if from-kind - is larger than to-kind, this may indicate a loss of precision. - The same holds for conversions from REAL to COMPLEX. */ - if (((from_ts.type == ts->type && from_ts.type != BT_LOGICAL) - && ((gfc_option.warn_conversion && from_ts.kind > ts->kind) - || gfc_option.warn_conversion_extra)) - || ((from_ts.type == BT_REAL && ts->type == BT_COMPLEX) - && ((gfc_option.warn_conversion && from_ts.kind > ts->kind) - || gfc_option.warn_conversion_extra))) - gfc_warning_now ("Possible change of value in conversion " - "from %s to %s at %L", gfc_typename (&from_ts), - gfc_typename (ts), &expr->where); - - /* If INTEGER is converted to REAL/COMPLEX, this is generally ok if - the kind of the INTEGER value is less or equal to the kind of the - REAL/COMPLEX one. Otherwise the value may not fit. - Assignment of an overly large integer constant also generates - an overflow error with range checking. */ - else if (from_ts.type == BT_INTEGER - && (ts->type == BT_REAL || ts->type == BT_COMPLEX) - && ((gfc_option.warn_conversion && from_ts.kind > ts->kind) - || gfc_option.warn_conversion_extra)) - gfc_warning_now ("Possible change of value in conversion " - "from %s to %s at %L", gfc_typename (&from_ts), - gfc_typename (ts), &expr->where); - - /* If REAL/COMPLEX is converted to INTEGER, or COMPLEX is converted - to REAL we almost certainly have a loss of digits, regardless of - the respective kinds. */ - else if ((((from_ts.type == BT_REAL || from_ts.type == BT_COMPLEX) - && ts->type == BT_INTEGER) - || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL)) - && (gfc_option.warn_conversion - || gfc_option.warn_conversion_extra)) - gfc_warning_now ("Possible change of value in conversion from " - "%s to %s at %L", gfc_typename (&from_ts), - gfc_typename (ts), &expr->where); + if (gfc_option.flag_range_check + && expr->expr_type == EXPR_CONSTANT + && from_ts.type == ts->type) + { + /* Do nothing. Constants of the same type are range-checked + elsewhere. If a value too large for the target type is + assigned, an error is generated. Not checking here avoids + duplications of warnings/errors. + If range checking was disabled, but -Wconversion enabled, + a non range checked warning is generated below. */ + } + else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL) + { + /* Do nothing. This block exists only to simplify the other + else-if expressions. + LOGICAL <> LOGICAL no warning, independent of kind values + LOGICAL <> INTEGER extension, warned elsewhere + LOGICAL <> REAL invalid, error generated elsewhere + LOGICAL <> COMPLEX invalid, error generated elsewhere */ + } + else if (from_ts.type == ts->type + || (from_ts.type == BT_INTEGER && ts->type == BT_REAL) + || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX) + || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)) + { + /* Larger kinds can hold values of smaller kinds without problems. + Hence, only warn if target kind is smaller than the source + kind - or if -Wconversion-extra is specified. */ + if (gfc_option.warn_conversion_extra) + gfc_warning_now ("Conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + else if (gfc_option.warn_conversion + && from_ts.kind > ts->kind) + gfc_warning_now ("Possible change of value in conversion " + "from %s to %s at %L", gfc_typename (&from_ts), + gfc_typename (ts), &expr->where); + } + else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER) + || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER) + || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL)) + { + /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL + usually comes with a loss of information, regardless of kinds. */ + if (gfc_option.warn_conversion_extra + || gfc_option.warn_conversion) + gfc_warning_now ("Possible change of value in conversion " + "from %s to %s at %L", gfc_typename (&from_ts), + gfc_typename (ts), &expr->where); + } + else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH) + { + /* If HOLLERITH is involved, all bets are off. */ + if (gfc_option.warn_conversion_extra + || gfc_option.warn_conversion) + gfc_warning_now ("Conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + } + else + gcc_unreachable (); } /* Insert a pre-resolved function call to the right function. */ diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 2e1b95eb375..919f09e90b4 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -40,7 +40,7 @@ gfc_try gfc_check_associated (gfc_expr *, gfc_expr *); gfc_try gfc_check_atan_2 (gfc_expr *, gfc_expr *); gfc_try gfc_check_atan2 (gfc_expr *, gfc_expr *); gfc_try gfc_check_besn (gfc_expr *, gfc_expr *); -gfc_try gfc_check_btest (gfc_expr *, gfc_expr *); +gfc_try gfc_check_bitfcn (gfc_expr *, gfc_expr *); gfc_try gfc_check_char (gfc_expr *, gfc_expr *); gfc_try gfc_check_chdir (gfc_expr *); gfc_try gfc_check_chmod (gfc_expr *, gfc_expr *); @@ -74,9 +74,7 @@ gfc_try gfc_check_hypot (gfc_expr *, gfc_expr *); gfc_try gfc_check_i (gfc_expr *); gfc_try gfc_check_iand (gfc_expr *, gfc_expr *); gfc_try gfc_check_and (gfc_expr *, gfc_expr *); -gfc_try gfc_check_ibclr (gfc_expr *, gfc_expr *); gfc_try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *); -gfc_try gfc_check_ibset (gfc_expr *, gfc_expr *); gfc_try gfc_check_ichar_iachar (gfc_expr *, gfc_expr *); gfc_try gfc_check_idnint (gfc_expr *); gfc_try gfc_check_ieor (gfc_expr *, gfc_expr *); @@ -128,7 +126,7 @@ gfc_try gfc_check_second_sub (gfc_expr *); gfc_try gfc_check_secnds (gfc_expr *); gfc_try gfc_check_selected_char_kind (gfc_expr *); gfc_try gfc_check_selected_int_kind (gfc_expr *); -gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *); +gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_set_exponent (gfc_expr *, gfc_expr *); gfc_try gfc_check_shape (gfc_expr *); gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *); @@ -324,7 +322,7 @@ gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *); gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *); -gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_shape (gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index bc0ea8dce3a..06c6793b2c4 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -5,7 +5,7 @@ This is part of the GNU Fortran manual. For copying conditions, see the file gfortran.texi. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) @@ -4185,6 +4185,44 @@ Subroutine Beginning with the Fortran 2003 standard, there is a @code{FLUSH} statement that should be preferred over the @code{FLUSH} intrinsic. +The @code{FLUSH} intrinsic and the Fortran 2003 @code{FLUSH} statement +have identical effect: they flush the runtime library's I/O buffer so +that the data becomes visible to other processes. This does not guarantee +that the data is committed to disk. + +On POSIX systems, you can request that all data is transferred to the +storage device by calling the @code{fsync} function, with the POSIX file +descriptor of the I/O unit as argument (retrieved with GNU intrinsic +@code{FNUM}). The following example shows how: + +@smallexample + ! Declare the interface for POSIX fsync function + interface + function fsync (fd) bind(c,name="fsync") + use iso_c_binding, only: c_int + integer(c_int), value :: fd + integer(c_int) :: fsync + end function fsync + end interface + + ! Variable declaration + integer :: ret + + ! Opening unit 10 + open (10,file="foo") + + ! ... + ! Perform I/O on unit 10 + ! ... + + ! Flush and sync + flush(10) + ret = fsync(fnum(10)) + + ! Handle possible error + if (ret /= 0) stop "Error calling FSYNC" +@end smallexample + @end table @@ -8678,6 +8716,9 @@ Inquiry function The return value is of type @code{INTEGER} and of the default integer kind. +@item @emph{See also}: +@ref{SELECTED_REAL_KIND}, @ref{RANGE} + @item @emph{Example}: @smallexample program prec_and_range @@ -8823,6 +8864,9 @@ Inquiry function The return value is a scalar of type @code{INTEGER} and of the default integer kind. +@item @emph{See also}: +@ref{SELECTED_REAL_KIND} + @item @emph{Example}: @smallexample program test_radix @@ -9060,6 +9104,9 @@ or @code{COMPLEX}. The return value is of type @code{INTEGER} and of the default integer kind. +@item @emph{See also}: +@ref{SELECTED_REAL_KIND}, @ref{PRECISION} + @item @emph{Example}: See @code{PRECISION} for an example. @end table @@ -9638,45 +9685,58 @@ end program large_integers @fnindex SELECTED_REAL_KIND @cindex real kind @cindex kind, real +@cindex radix, real @table @asis @item @emph{Description}: @code{SELECTED_REAL_KIND(P,R)} returns the kind value of a real data type -with decimal precision of at least @code{P} digits and exponent -range greater at least @code{R}. +with decimal precision of at least @code{P} digits, exponent range of +at least @code{R}, and with a radix of @code{RADIX}. @item @emph{Standard}: -Fortran 95 and later +Fortran 95 and later, with @code{RADIX} Fortran 2008 or later @item @emph{Class}: Transformational function @item @emph{Syntax}: -@code{RESULT = SELECTED_REAL_KIND([P, R])} +@code{RESULT = SELECTED_REAL_KIND([P, R, RADIX])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{P} @tab (Optional) shall be a scalar and of type @code{INTEGER}. @item @var{R} @tab (Optional) shall be a scalar and of type @code{INTEGER}. +@item @var{RADIX} @tab (Optional) shall be a scalar and of type @code{INTEGER}. @end multitable -At least one argument shall be present. +Before Fortran 2008, at least one of the arguments @var{R} or @var{P} shall +be present; since Fortran 2008, they are assumed to be zero if absent. @item @emph{Return value}: @code{SELECTED_REAL_KIND} returns the value of the kind type parameter of -a real data type with decimal precision of at least @code{P} digits and a -decimal exponent range of at least @code{R}. If more than one real data -type meet the criteria, the kind of the data type with the smallest -decimal precision is returned. If no real data type matches the criteria, -the result is +a real data type with decimal precision of at least @code{P} digits, a +decimal exponent range of at least @code{R}, and with the requested +@code{RADIX}. If the @code{RADIX} parameter is absent, real kinds with +any radix can be returned. If more than one real data type meet the +criteria, the kind of the data type with the smallest decimal precision +is returned. If no real data type matches the criteria, the result is @table @asis @item -1 if the processor does not support a real data type with a -precision greater than or equal to @code{P} +precision greater than or equal to @code{P}, but the @code{R} and +@code{RADIX} requirements can be fulfilled @item -2 if the processor does not support a real type with an exponent -range greater than or equal to @code{R} -@item -3 if neither is supported. +range greater than or equal to @code{R}, but @code{P} and @code{RADIX} +are fulfillable +@item -3 if @code{RADIX} but not @code{P} and @code{R} requirements +are fulfillable +@item -4 if @code{RADIX} and either @code{P} or @code{R} requirements +are fulfillable +@item -5 if there is no real type with the given @code{RADIX} @end table +@item @emph{See also}: +@ref{PRECISION}, @ref{RANGE}, @ref{RADIX} + @item @emph{Example}: @smallexample program real_kinds diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 78c1c436561..1dfd3bdd920 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -9,7 +9,7 @@ Copyright @copyright{} 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.2 or +under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with the Invariant Sections being ``Funding Free Software'', the Front-Cover Texts being (a) (see below), and with the Back-Cover Texts being (b) @@ -148,8 +148,7 @@ and warnings}. @item Directory Options @xref{Directory Options,,Options for directory search}. -@gccoptlist{-I@var{dir} -J@var{dir} -M@var{dir} @gol --fintrinsic-modules-path @var{dir}} +@gccoptlist{-I@var{dir} -J@var{dir} -fintrinsic-modules-path @var{dir}} @item Link Options @xref{Link Options,,Options for influencing the linking step}. @@ -964,7 +963,6 @@ gcc,Using the GNU Compiler Collection (GCC)}, for information on the @option{-I} option. @item -J@var{dir} -@item -M@var{dir} @opindex @code{J}@var{dir} @opindex @code{M}@var{dir} @cindex paths, search @@ -975,8 +973,6 @@ statement. The default is the current directory. -@option{-M} is deprecated to avoid conflicts with existing GCC options. - @item -fintrinsic-modules-path @var{dir} @opindex @code{fintrinsic-modules-path} @var{dir} @cindex paths, search diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index dc20bc2ffb6..f9a6d7b1240 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -730,7 +730,7 @@ data_desc: t = format_lex (); if (t == FMT_ERROR) goto fail; - if (gfc_option.allow_std < GFC_STD_F2003 && t != FMT_COMMA + if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) { diff --git a/gcc/fortran/lang-specs.h b/gcc/fortran/lang-specs.h index a622dcb1a6a..4fe24de1927 100644 --- a/gcc/fortran/lang-specs.h +++ b/gcc/fortran/lang-specs.h @@ -28,7 +28,7 @@ %{O*} %{undef}" /* Options that f951 should know about, even if not preprocessing. */ -#define CPP_FORWARD_OPTIONS "%{i*} %{I*}" +#define CPP_FORWARD_OPTIONS "%{i*} %{I*} %{M*}" #define F951_CPP_OPTIONS "%{!nocpp: -cpp %g.f90 %{E} %(cpp_unique_options) \ %{E|M|MM:%(cpp_debug_options) " CPP_ONLY_OPTIONS \ diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index c1a86ddab08..1f3ef9d0574 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -56,6 +56,42 @@ J Fortran Joined Separate -J<directory> Put MODULE files in 'directory' +M +Fortran +; Documented in C + +MD +Fortran Separate +; Documented in C + +MF +Fortran Joined Separate +; Documented in C + +MG +Fortran +; Documented in C + +MM +Fortran +; Documented in C + +MMD +Fortran Separate +; Documented in C + +MP +Fortran +; Documented in C + +MT +Fortran Joined Separate +; Documented in C + +MQ +Fortran Joined Separate +; Documented in C + P Fortran ; Documented in C @@ -369,7 +405,7 @@ Fortran Append a second underscore if the name already contains an underscore fshort-enums -Fortran +Fortran Var(flag_short_enums) VarExists ; Documented in C fsign-zero diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 85bd43df98c..d9216d30149 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -23,15 +23,16 @@ along with GCC; see the file COPYING3. If not see Note that no features were obsoleted nor deleted in F2003. Please remember to keep those definitions in sync with gfortran.texi. */ -#define GFC_STD_F2008 (1<<7) /* New in F2008. */ -#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. */ +#define GFC_STD_F2008_OBS (1<<8) /* Obsolescent in F2008. */ +#define GFC_STD_F2008 (1<<7) /* New in F2008. */ +#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. */ diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 2cbac0200fd..92c4da0a4b5 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1797,6 +1797,98 @@ gfc_match_block (void) } +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + new_st.ext.block.assoc = NULL; + while (true) + { + gfc_association_list* newAssoc = gfc_get_association_list (); + gfc_association_list* a; + + /* Match the next association. */ + if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target) + != MATCH_YES) + { + gfc_error ("Expected association at %C"); + goto assocListError; + } + + /* Check that the current name is not yet in the list. */ + for (a = new_st.ext.block.assoc; a; a = a->next) + if (!strcmp (a->name, newAssoc->name)) + { + gfc_error ("Duplicate name '%s' in association at %C", + newAssoc->name); + goto assocListError; + } + + /* The target expression must not be coindexed. */ + if (gfc_is_coindexed (newAssoc->target)) + { + gfc_error ("Association target at %C must not be coindexed"); + goto assocListError; + } + + /* The target is a variable (and may be used as lvalue) if it's an + EXPR_VARIABLE and does not have vector-subscripts. */ + newAssoc->variable = (newAssoc->target->expr_type == EXPR_VARIABLE + && !gfc_has_vector_subscript (newAssoc->target)); + + /* Put it into the list. */ + newAssoc->next = new_st.ext.block.assoc; + new_st.ext.block.assoc = newAssoc; + + /* Try next one or end if closing parenthesis is found. */ + gfc_gobble_whitespace (); + if (gfc_peek_char () == ')') + break; + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected ')' or ',' at %C"); + return MATCH_ERROR; + } + + continue; + +assocListError: + gfc_free (newAssoc); + goto error; + } + if (gfc_match_char (')') != MATCH_YES) + { + /* This should never happen as we peek above. */ + gcc_unreachable (); + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after ASSOCIATE statement at %C"); + goto error; + } + + return MATCH_YES; + +error: + gfc_free_association_list (new_st.ext.block.assoc); + return MATCH_ERROR; +} + + /* Match a DO statement. */ match @@ -2693,16 +2785,16 @@ match gfc_match_allocate (void) { gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp, *source; + gfc_expr *stat, *errmsg, *tmp, *source, *mold; gfc_typespec ts; gfc_symbol *sym; match m; locus old_locus; - bool saw_stat, saw_errmsg, saw_source, b1, b2, b3; + bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3; head = tail = NULL; - stat = errmsg = source = tmp = NULL; - saw_stat = saw_errmsg = saw_source = false; + stat = errmsg = source = mold = tmp = NULL; + saw_stat = saw_errmsg = saw_source = saw_mold = false; if (gfc_match_char ('(') != MATCH_YES) goto syntax; @@ -2895,6 +2987,38 @@ alloc_opt_list: goto alloc_opt_list; } + m = gfc_match (" mold = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Check F08:C636. */ + if (saw_mold) + { + gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); + goto cleanup; + } + + /* Check F08:C637. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + mold = tmp; + saw_mold = true; + mold->mold = 1; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + gfc_gobble_whitespace (); if (gfc_peek_char () == ')') @@ -2905,10 +3029,21 @@ alloc_opt_list: if (gfc_match (" )%t") != MATCH_YES) goto syntax; + /* Check F08:C637. */ + if (source && mold) + { + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); + goto cleanup; + } + new_st.op = EXEC_ALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; - new_st.expr3 = source; + if (source) + new_st.expr3 = source; + else + new_st.expr3 = mold; new_st.ext.alloc.list = head; new_st.ext.alloc.ts = ts; @@ -2921,7 +3056,8 @@ cleanup: gfc_free_expr (errmsg); gfc_free_expr (source); gfc_free_expr (stat); - gfc_free_expr (tmp); + gfc_free_expr (mold); + if (tmp && tmp->expr_type) gfc_free_expr (tmp); gfc_free_alloc_list (head); return MATCH_ERROR; } @@ -4361,7 +4497,7 @@ gfc_match_select_type (void) new_st.op = EXEC_SELECT_TYPE; new_st.expr1 = expr1; new_st.expr2 = expr2; - new_st.ext.ns = gfc_current_ns; + new_st.ext.block.ns = gfc_current_ns; select_type_push (expr1->symtree->n.sym); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 049f3d3285c..501049e1220 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -69,6 +69,7 @@ match gfc_match_else (void); match gfc_match_elseif (void); match gfc_match_critical (void); match gfc_match_block (void); +match gfc_match_associate (void); match gfc_match_do (void); match gfc_match_cycle (void); match gfc_match_exit (void); @@ -167,6 +168,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int); match gfc_match_allocatable (void); match gfc_match_asynchronous (void); match gfc_match_codimension (void); +match gfc_match_contiguous (void); match gfc_match_dimension (void); match gfc_match_external (void); match gfc_match_gcc_attributes (void); diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def index 3bedc1a6ba5..2d6e9677d62 100644 --- a/gcc/fortran/mathbuiltins.def +++ b/gcc/fortran/mathbuiltins.def @@ -51,3 +51,20 @@ DEFINE_MATH_BUILTIN (ERFC, "erfc", 0) DEFINE_MATH_BUILTIN (TGAMMA,"tgamma", 0) DEFINE_MATH_BUILTIN (LGAMMA,"lgamma", 0) DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1) + +/* OTHER_BUILTIN (CODE, NAME, PROTOTYPE_TYPE) + For floating-point builtins that do not directly correspond to a + Fortran intrinsic. This is used to map the different variants (float, + double and long double) and to build the quad-precision decls. */ +OTHER_BUILTIN (CABS, "cabs", cabs) +OTHER_BUILTIN (COPYSIGN, "copysign", 2) +OTHER_BUILTIN (FABS, "fabs", 1) +OTHER_BUILTIN (FMOD, "fmod", 2) +OTHER_BUILTIN (FREXP, "frexp", frexp) +OTHER_BUILTIN (HUGE_VAL, "huge_val", 0) +OTHER_BUILTIN (LLROUND, "llround", llround) +OTHER_BUILTIN (LROUND, "lround", lround) +OTHER_BUILTIN (NEXTAFTER, "nextafter", 2) +OTHER_BUILTIN (ROUND, "round", 1) +OTHER_BUILTIN (SCALBN, "scalbn", scalbn) +OTHER_BUILTIN (TRUNC, "trunc", 1) diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 9bdee2a60f0..b42a9e8c1d1 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -74,6 +74,7 @@ along with GCC; see the file COPYING3. If not see #include "parse.h" /* FIXME */ #include "md5.h" #include "constructor.h" +#include "cpp.h" #define MODULE_EXTENSION ".mod" @@ -1674,7 +1675,7 @@ typedef enum AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, - AB_COARRAY_COMP, AB_VTYPE, AB_VTAB + AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS } ab_attribute; @@ -1684,6 +1685,7 @@ static const mstring attr_bits[] = minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), minit ("DIMENSION", AB_DIMENSION), minit ("CODIMENSION", AB_CODIMENSION), + minit ("CONTIGUOUS", AB_CONTIGUOUS), minit ("EXTERNAL", AB_EXTERNAL), minit ("INTRINSIC", AB_INTRINSIC), minit ("OPTIONAL", AB_OPTIONAL), @@ -1806,6 +1808,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); if (attr->codimension) MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); + if (attr->contiguous) + MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits); if (attr->external) MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); if (attr->intrinsic) @@ -1914,6 +1918,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_CODIMENSION: attr->codimension = 1; break; + case AB_CONTIGUOUS: + attr->contiguous = 1; + break; case AB_EXTERNAL: attr->external = 1; break; @@ -3323,7 +3330,7 @@ mio_typebound_proc (gfc_typebound_proc** proc) if (iomode == IO_INPUT) { - *proc = gfc_get_typebound_proc (); + *proc = gfc_get_typebound_proc (NULL); (*proc)->where = gfc_current_locus; } gcc_assert (*proc); @@ -5120,6 +5127,9 @@ gfc_dump_module (const char *name, int dump_flag) return; } + if (gfc_cpp_makedep ()) + gfc_cpp_add_target (filename); + /* Write the module to the temporary file. */ module_fp = fopen (filename_tmp, "w"); if (module_fp == NULL) diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 6a56515298e..0e25bf48cb3 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -845,11 +845,13 @@ resolve_omp_clauses (gfc_code *code) for (list = 0; list < OMP_LIST_NUM; list++) if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE) for (n = omp_clauses->lists[list]; n; n = n->next) - if (n->sym->mark) - gfc_error ("Symbol '%s' present on multiple clauses at %L", - n->sym->name, &code->loc); - else - n->sym->mark = 1; + { + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + } gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) @@ -862,22 +864,24 @@ resolve_omp_clauses (gfc_code *code) } for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) - if (n->sym->mark) - gfc_error ("Symbol '%s' present on multiple clauses at %L", - n->sym->name, &code->loc); - else - n->sym->mark = 1; - + { + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + } for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) n->sym->mark = 0; for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) - if (n->sym->mark) - gfc_error ("Symbol '%s' present on multiple clauses at %L", - n->sym->name, &code->loc); - else - n->sym->mark = 1; - + { + if (n->sym->mark) + gfc_error ("Symbol '%s' present on multiple clauses at %L", + n->sym->name, &code->loc); + else + n->sym->mark = 1; + } for (list = 0; list < OMP_LIST_NUM; list++) if ((n = omp_clauses->lists[list]) != NULL) { diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 6c6ccb10461..af537a1e70e 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -48,7 +48,7 @@ set_default_std_flags (void) { gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F2003 | GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77 - | GFC_STD_GNU | GFC_STD_LEGACY; + | GFC_STD_F2008_OBS | GFC_STD_GNU | GFC_STD_LEGACY; gfc_option.warn_std = GFC_STD_F95_DEL | GFC_STD_LEGACY; } @@ -541,10 +541,6 @@ gfc_handle_option (size_t scode, const char *arg, int value, int result = 1; enum opt_code code = (enum opt_code) scode; - /* Ignore file names. */ - if (code == N_OPTS) - return 1; - if (gfc_cpp_handle_option (scode, arg, value) == 1) return 1; @@ -861,7 +857,8 @@ gfc_handle_option (size_t scode, const char *arg, int value, break; case OPT_std_f95: - gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77; + gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77 + | GFC_STD_F2008_OBS; gfc_option.warn_std = GFC_STD_F95_OBS; gfc_option.max_continue_fixed = 19; gfc_option.max_continue_free = 39; @@ -872,7 +869,7 @@ gfc_handle_option (size_t scode, const char *arg, int value, case OPT_std_f2003: gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F77 - | GFC_STD_F2003 | GFC_STD_F95; + | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008_OBS; gfc_option.warn_std = GFC_STD_F95_OBS; gfc_option.max_identifier_length = 63; gfc_option.warn_ampersand = 1; @@ -881,8 +878,8 @@ gfc_handle_option (size_t scode, const char *arg, int value, case OPT_std_f2008: gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F77 - | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008; - gfc_option.warn_std = GFC_STD_F95_OBS; + | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F2008 | GFC_STD_F2008_OBS; + gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS; gfc_option.max_identifier_length = 63; gfc_option.warn_ampersand = 1; gfc_option.warn_tabs = 0; @@ -902,7 +899,7 @@ gfc_handle_option (size_t scode, const char *arg, int value, break; case OPT_fshort_enums: - flag_short_enums = 1; + /* Handled in language-independent code. */ break; case OPT_fconvert_little_endian: @@ -938,7 +935,7 @@ gfc_handle_option (size_t scode, const char *arg, int value, break; case OPT_frecursive: - gfc_option.flag_recursive = 1; + gfc_option.flag_recursive = value; break; case OPT_falign_commons: diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 7fc35418bec..50f795723eb 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -139,6 +139,7 @@ decode_specification_statement (void) case 'c': match ("codimension", gfc_match_codimension, ST_ATTR_DECL); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); break; case 'd': @@ -292,7 +293,7 @@ decode_statement (void) gfc_undo_symbols (); gfc_current_locus = old_locus; - /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, and BLOCK + /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE statements, which might begin with a block label. The match functions for these statements are unusual in that their keyword is not seen before the matcher is called. */ @@ -314,6 +315,7 @@ decode_statement (void) match (NULL, gfc_match_do, ST_DO); match (NULL, gfc_match_block, ST_BLOCK); + match (NULL, gfc_match_associate, ST_ASSOCIATE); match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); @@ -345,6 +347,7 @@ decode_statement (void) match ("call", gfc_match_call, ST_CALL); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); match ("cycle", gfc_match_cycle, ST_CYCLE); match ("case", gfc_match_case, ST_CASE); match ("common", gfc_match_common, ST_COMMON); @@ -714,7 +717,9 @@ next_free (void) if (at_bol && c == ';') { - gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + if (!(gfc_option.allow_std & GFC_STD_F2008)) + gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " + "statement"); gfc_next_ascii_char (); /* Eat up the semicolon. */ return ST_NONE; } @@ -850,7 +855,11 @@ next_fixed (void) if (c == ';') { - gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + if (digit_flag) + gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + else if (!(gfc_option.allow_std & GFC_STD_F2008)) + gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " + "statement"); return ST_NONE; } @@ -949,7 +958,7 @@ next_statement (void) /* Statements that mark other executable statements. */ #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ - case ST_IF_BLOCK: case ST_BLOCK: \ + case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ case ST_OMP_PARALLEL: \ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ @@ -970,7 +979,7 @@ next_statement (void) #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ - case ST_END_BLOCK + case ST_END_BLOCK: case ST_END_ASSOCIATE /* Push a new state onto the stack. */ @@ -1155,6 +1164,9 @@ gfc_ascii_statement (gfc_statement st) case ST_ALLOCATE: p = "ALLOCATE"; break; + case ST_ASSOCIATE: + p = "ASSOCIATE"; + break; case ST_ATTR_DECL: p = _("attribute declaration"); break; @@ -1215,6 +1227,9 @@ gfc_ascii_statement (gfc_statement st) case ST_ELSEWHERE: p = "ELSEWHERE"; break; + case ST_END_ASSOCIATE: + p = "END ASSOCIATE"; + break; case ST_END_BLOCK: p = "END BLOCK"; break; @@ -3160,7 +3175,8 @@ parse_block_construct (void) my_ns = gfc_build_block_ns (gfc_current_ns); new_st.op = EXEC_BLOCK; - new_st.ext.ns = my_ns; + new_st.ext.block.ns = my_ns; + new_st.ext.block.assoc = NULL; accept_statement (ST_BLOCK); push_state (&s, COMP_BLOCK, my_ns->proc_name); @@ -3173,6 +3189,92 @@ parse_block_construct (void) } +/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct + behind the scenes with compiler-generated variables. */ + +static void +parse_associate (void) +{ + gfc_namespace* my_ns; + gfc_state_data s; + gfc_statement st; + gfc_association_list* a; + gfc_code* assignTail; + + gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + gcc_assert (new_st.ext.block.assoc); + + /* Add all associations to expressions as BLOCK variables, and create + assignments to them giving their values. */ + gfc_current_ns = my_ns; + assignTail = NULL; + for (a = new_st.ext.block.assoc; a; a = a->next) + if (!a->variable) + { + gfc_code* newAssign; + + if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) + gcc_unreachable (); + + /* Note that in certain cases, the target-expression's type is not yet + known and so we have to adapt the symbol's ts also during resolution + for these cases. */ + a->st->n.sym->ts = a->target->ts; + a->st->n.sym->attr.flavor = FL_VARIABLE; + a->st->n.sym->assoc = a; + gfc_set_sym_referenced (a->st->n.sym); + + /* Create the assignment to calculate the expression and set it. */ + newAssign = gfc_get_code (); + newAssign->op = EXEC_ASSIGN; + newAssign->loc = gfc_current_locus; + newAssign->expr1 = gfc_get_variable_expr (a->st); + newAssign->expr2 = a->target; + + /* Hang it in. */ + if (assignTail) + assignTail->next = newAssign; + else + gfc_current_ns->code = newAssign; + assignTail = newAssign; + } + else + { + gfc_error ("Association to variables is not yet supported at %C"); + return; + } + gcc_assert (assignTail); + + accept_statement (ST_ASSOCIATE); + push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); + +loop: + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case_end: + accept_statement (st); + assignTail->next = gfc_state_stack->head; + break; + + default: + unexpected_statement (st); + goto loop; + } + + gfc_current_ns = gfc_current_ns->parent; + pop_state (); +} + + /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are handled inside of parse_executable(), because they aren't really loop statements. */ @@ -3542,8 +3644,6 @@ parse_executable (gfc_statement st) case ST_END_SUBROUTINE: case ST_DO: - case ST_CRITICAL: - case ST_BLOCK: case ST_FORALL: case ST_WHERE: case ST_SELECT_CASE: @@ -3573,6 +3673,10 @@ parse_executable (gfc_statement st) parse_block_construct (); break; + case ST_ASSOCIATE: + parse_associate (); + break; + case ST_IF_BLOCK: parse_if_block (); break; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index faa813d88d0..65d1a7e604a 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -28,7 +28,7 @@ typedef enum { COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION, COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, - COMP_BLOCK, COMP_IF, + COMP_BLOCK, COMP_ASSOCIATE, COMP_IF, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 68b6a437360..b6c08a9c406 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2975,6 +2975,12 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) gfc_error ("Assigning to PROTECTED variable at %C"); return MATCH_ERROR; } + if (sym->assoc && !sym->assoc->variable) + { + gfc_error ("'%s' associated to expression can't appear in a variable" + " definition context at %C", sym->name); + return MATCH_ERROR; + } break; case FL_UNKNOWN: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 48bb6187c17..4e11fc6c311 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1858,29 +1858,6 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } } - if (gsym->ns->proc_name->attr.function - && gsym->ns->proc_name->as - && gsym->ns->proc_name->as->rank - && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) - gfc_error ("The reference to function '%s' at %L either needs an " - "explicit INTERFACE or the rank is incorrect", sym->name, - where); - - /* Non-assumed length character functions. */ - if (sym->attr.function && sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl->length != NULL) - { - gfc_charlen *cl = sym->ts.u.cl; - - if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Nonconstant character-length function '%s' at %L " - "must have an explicit interface", sym->name, - &sym->declared_at); - } - } - /* Differences in constant character lengths. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER) { @@ -1911,26 +1888,108 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&gsym->ns->proc_name->ts)); - /* Assumed shape arrays as dummy arguments. */ if (gsym->ns->proc_name->formal) { gfc_formal_arglist *arg = gsym->ns->proc_name->formal; for ( ; arg; arg = arg->next) - if (arg->sym && arg->sym->as - && arg->sym->as->type == AS_ASSUMED_SHAPE) + if (!arg->sym) + continue; + /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */ + else if (arg->sym->attr.allocatable + || arg->sym->attr.asynchronous + || arg->sym->attr.optional + || arg->sym->attr.pointer + || arg->sym->attr.target + || arg->sym->attr.value + || arg->sym->attr.volatile_) + { + gfc_error ("Dummy argument '%s' of procedure '%s' at %L " + "has an attribute that requires an explicit " + "interface for this procedure", arg->sym->name, + sym->name, &sym->declared_at); + break; + } + /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_SHAPE) { gfc_error ("Procedure '%s' at %L with assumed-shape dummy " - "'%s' argument must have an explicit interface", + "argument '%s' must have an explicit interface", sym->name, &sym->declared_at, arg->sym->name); break; } - else if (arg->sym && arg->sym->attr.optional) + /* F2008, 12.4.2.2 (2c) */ + else if (arg->sym->attr.codimension) { - gfc_error ("Procedure '%s' at %L with optional dummy argument " + gfc_error ("Procedure '%s' at %L with coarray dummy argument " "'%s' must have an explicit interface", sym->name, &sym->declared_at, arg->sym->name); break; } + /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */ + else if (false) /* TODO: is a parametrized derived type */ + { + gfc_error ("Procedure '%s' at %L with parametrized derived " + "type argument '%s' must have an explicit " + "interface", sym->name, &sym->declared_at, + arg->sym->name); + break; + } + /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */ + else if (arg->sym->ts.type == BT_CLASS) + { + gfc_error ("Procedure '%s' at %L with polymorphic dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } + } + + if (gsym->ns->proc_name->attr.function) + { + /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */ + if (gsym->ns->proc_name->as + && gsym->ns->proc_name->as->rank + && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) + gfc_error ("The reference to function '%s' at %L either needs an " + "explicit INTERFACE or the rank is incorrect", sym->name, + where); + + /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ + if (gsym->ns->proc_name->result->attr.pointer + || gsym->ns->proc_name->result->attr.allocatable) + gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " + "result must have an explicit interface", sym->name, + where); + + /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ + if (sym->ts.type == BT_CHARACTER + && gsym->ns->proc_name->ts.u.cl->length != NULL) + { + gfc_charlen *cl = sym->ts.u.cl; + + if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Nonconstant character-length function '%s' at %L " + "must have an explicit interface", sym->name, + &sym->declared_at); + } + } + } + + /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ + if (gsym->ns->proc_name->attr.elemental) + { + gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " + "interface", sym->name, &sym->declared_at); + } + + /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ + if (gsym->ns->proc_name->attr.is_bind_c) + { + gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " + "an explicit interface", sym->name, &sym->declared_at); } if (gfc_option.flag_whole_file == 1 @@ -2200,6 +2259,7 @@ is_external_proc (gfc_symbol *sym) && !(sym->attr.intrinsic || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)) && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.proc_pointer && !sym->attr.use_assoc && sym->name) return true; @@ -3615,11 +3675,11 @@ resolve_operator (gfc_expr *e) e->rank = op1->rank; if (e->shape == NULL) { - t = compare_shapes(op1, op2); + t = compare_shapes (op1, op2); if (t == FAILURE) e->shape = NULL; else - e->shape = gfc_copy_shape (op1->shape, op1->rank); + e->shape = gfc_copy_shape (op1->shape, op1->rank); } } else @@ -5160,6 +5220,43 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target, } +/* Get the ultimate declared type from an expression. In addition, + return the last class/derived type reference and the copy of the + reference list. */ +static gfc_symbol* +get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, + gfc_expr *e) +{ + gfc_symbol *declared; + gfc_ref *ref; + + declared = NULL; + if (class_ref) + *class_ref = NULL; + if (new_ref) + *new_ref = gfc_copy_ref (e->ref); + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + continue; + + if (ref->u.c.component->ts.type == BT_CLASS + || ref->u.c.component->ts.type == BT_DERIVED) + { + declared = ref->u.c.component->ts.u.derived; + if (class_ref) + *class_ref = ref; + } + } + + if (declared == NULL) + declared = e->symtree->n.sym->ts.u.derived; + + return declared; +} + + /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out which of the specific bindings (if any) matches the arglist and transform the expression into a call of that binding. */ @@ -5169,6 +5266,8 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) { gfc_typebound_proc* genproc; const char* genname; + gfc_symtree *st; + gfc_symbol *derived; gcc_assert (e->expr_type == EXPR_COMPCALL); genname = e->value.compcall.name; @@ -5236,6 +5335,19 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) return FAILURE; success: + /* Make sure that we have the right specific instance for the name. */ + genname = e->value.compcall.tbp->u.specific->name; + + /* Is the symtree name a "unique name". */ + if (*genname == '@') + genname = e->value.compcall.tbp->u.specific->n.sym->name; + + derived = get_declared_from_expr (NULL, NULL, e); + + st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where); + if (st) + e->value.compcall.tbp = st->n.tb; + return SUCCESS; } @@ -5343,38 +5455,6 @@ resolve_compcall (gfc_expr* e, const char **name) } -/* Get the ultimate declared type from an expression. In addition, - return the last class/derived type reference and the copy of the - reference list. */ -static gfc_symbol* -get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, - gfc_expr *e) -{ - gfc_symbol *declared; - gfc_ref *ref; - - declared = NULL; - *class_ref = NULL; - *new_ref = gfc_copy_ref (e->ref); - for (ref = *new_ref; ref; ref = ref->next) - { - if (ref->type != REF_COMPONENT) - continue; - - if (ref->u.c.component->ts.type == BT_CLASS - || ref->u.c.component->ts.type == BT_DERIVED) - { - declared = ref->u.c.component->ts.u.derived; - *class_ref = ref; - } - } - - if (declared == NULL) - declared = e->symtree->n.sym->ts.u.derived; - - return declared; -} - /* Resolve a typebound function, or 'method'. First separate all the non-CLASS references by calling resolve_compcall directly. */ @@ -5395,6 +5475,9 @@ resolve_typebound_function (gfc_expr* e) if (st == NULL) return resolve_compcall (e, NULL); + if (resolve_ref (e) == FAILURE) + return FAILURE; + /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e); @@ -5416,18 +5499,16 @@ resolve_typebound_function (gfc_expr* e) /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ - resolve_compcall (e, &name); + if (resolve_compcall (e, &name) == FAILURE) + return FAILURE; ts = e->ts; /* Then convert the expression to a procedure pointer component call. */ e->value.function.esym = NULL; e->symtree = st; - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - e->ref = new_ref; - } + if (new_ref) + e->ref = new_ref; /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (e, "$vptr"); @@ -5470,6 +5551,9 @@ resolve_typebound_subroutine (gfc_code *code) if (st == NULL) return resolve_typebound_call (code, NULL); + if (resolve_ref (code->expr1) == FAILURE) + return FAILURE; + /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); @@ -5489,18 +5573,16 @@ resolve_typebound_subroutine (gfc_code *code) if (code->expr1->value.compcall.tbp->is_generic) genname = code->expr1->value.compcall.name; - resolve_typebound_call (code, &name); + if (resolve_typebound_call (code, &name) == FAILURE) + return FAILURE; ts = code->expr1->ts; /* Then convert the expression to a procedure pointer component call. */ code->expr1->value.function.esym = NULL; code->expr1->symtree = st; - if (class_ref) - { - gfc_free_ref_list (class_ref->next); - code->expr1->ref = new_ref; - } + if (new_ref) + code->expr1->ref = new_ref; /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (code->expr1, "$vptr"); @@ -6051,6 +6133,7 @@ resolve_deallocate_expr (gfc_expr *e) bad: gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); + return FAILURE; } if (check_intent_in && sym->attr.intent == INTENT_IN) @@ -6125,8 +6208,11 @@ gfc_expr_to_initialize (gfc_expr *e) static gfc_try conformable_arrays (gfc_expr *e1, gfc_expr *e2) { + gfc_ref *tail; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + /* First compare rank. */ - if (e2->ref && e1->rank != e2->ref->u.ar.as->rank) + if (tail && e1->rank != tail->u.ar.as->rank) { gfc_error ("Source-expr at %L must be scalar or have the " "same rank as the allocate-object at %L", @@ -6143,15 +6229,15 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) for (i = 0; i < e1->rank; i++) { - if (e2->ref->u.ar.end[i]) + if (tail->u.ar.end[i]) { - mpz_set (s, e2->ref->u.ar.end[i]->value.integer); - mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.end[i]->value.integer); + mpz_sub (s, s, tail->u.ar.start[i]->value.integer); mpz_add_ui (s, s, 1); } else { - mpz_set (s, e2->ref->u.ar.start[i]->value.integer); + mpz_set (s, tail->u.ar.start[i]->value.integer); } if (mpz_cmp (e1->shape[i], s) != 0) @@ -6182,10 +6268,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; - gfc_symbol *sym; + gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -6318,11 +6403,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } } - else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) + + /* Check F08:C629. */ + if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN + && !code->expr3) { gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " - "type-spec or SOURCE=", sym->name, &e->where); + "type-spec or source-expr", sym->name, &e->where); goto failure; } @@ -6333,25 +6421,26 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } - if (!code->expr3) + if (!code->expr3 || code->expr3->mold) { /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&e->ts))) - { - gfc_code *init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->expr2 = init_e; - init_st->next = code->next; - code->next = init_st; - } - else if (e->ts.type == BT_CLASS - && ((code->ext.alloc.ts.type == BT_UNKNOWN - && (init_e = gfc_default_initializer (&CLASS_DATA (e)->ts))) - || (code->ext.alloc.ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + gfc_expr *init_e = NULL; + gfc_typespec ts; + + if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + else if (code->expr3) + ts = code->expr3->ts; + else + ts = e->ts; + + if (ts.type == BT_DERIVED) + init_e = gfc_default_initializer (&ts); + /* FIXME: Use default init of dynamic type (cf. PR 44541). */ + else if (e->ts.type == BT_CLASS) + init_e = gfc_default_initializer (&ts.u.derived->components->ts); + + if (init_e) { gfc_code *init_st = gfc_get_code (); init_st->loc = code->loc; @@ -6503,8 +6592,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) - gfc_error ("Stat-variable at %L shall not be %sd within " - "the same %s statement", &stat->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Stat-variable at %L shall not be %sd within " + "the same %s statement", &stat->where, fcn, fcn); + break; + } + } } /* Check the errmsg variable. */ @@ -6532,8 +6642,29 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) for (p = code->ext.alloc.list; p; p = p->next) if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) - gfc_error ("Errmsg-variable at %L shall not be %sd within " - "the same %s statement", &errmsg->where, fcn, fcn); + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Errmsg-variable at %L shall not be %sd within " + "the same %s statement", &errmsg->where, fcn, fcn); + break; + } + } } /* Check that an allocate-object appears only once in the statement. @@ -7137,7 +7268,7 @@ resolve_select_type (gfc_code *code) gfc_namespace *ns; int error = 0; - ns = code->ext.ns; + ns = code->ext.block.ns; gfc_resolve (ns); /* Check for F03:C813. */ @@ -7224,6 +7355,7 @@ resolve_select_type (gfc_code *code) else ns->code->next = new_st; code->op = EXEC_BLOCK; + code->ext.block.assoc = NULL; code->expr1 = code->expr2 = NULL; code->block = NULL; @@ -7967,10 +8099,11 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static void resolve_block_construct (gfc_code* code) { - /* Eventually, we may want to do some checks here or handle special stuff. - But so far the only thing we can do is resolving the local namespace. */ + /* For an ASSOCIATE block, the associations (and their targets) are already + resolved during gfc_resolve_symbol. */ - gfc_resolve (code->ext.ns); + /* Resolve the BLOCK's namespace. */ + gfc_resolve (code->ext.block.ns); } @@ -8291,7 +8424,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) gfc_resolve_omp_do_blocks (code, ns); break; case EXEC_SELECT_TYPE: - gfc_current_ns = code->ext.ns; + gfc_current_ns = code->ext.block.ns; gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = ns; break; @@ -8455,7 +8588,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; case EXEC_BLOCK: - gfc_resolve (code->ext.ns); + gfc_resolve (code->ext.block.ns); break; case EXEC_DO: @@ -10694,6 +10827,14 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } + /* F2008, C448. */ + if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) + { + gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); + return FAILURE; + } + if (c->attr.proc_pointer && c->ts.interface) { if (c->ts.interface->attr.procedure && !sym->attr.vtype) @@ -10760,7 +10901,7 @@ resolve_fl_derived (gfc_symbol *sym) c->ts.u.cl = cl; } } - else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype) + else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0') { gfc_error ("Interface '%s' of procedure pointer component " "'%s' at %L must be explicit", c->ts.interface->name, @@ -11004,6 +11145,7 @@ resolve_fl_derived (gfc_symbol *sym) /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract + && !sym->attr.is_class && ensure_not_abstract (sym, super_type) == FAILURE) return FAILURE; @@ -11265,6 +11407,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.pure = ifc->attr.pure; sym->attr.elemental = ifc->attr.elemental; sym->attr.dimension = ifc->attr.dimension; + sym->attr.contiguous = ifc->attr.contiguous; sym->attr.recursive = ifc->attr.recursive; sym->attr.always_explicit = ifc->attr.always_explicit; sym->attr.ext_attr |= ifc->attr.ext_attr; @@ -11297,6 +11440,31 @@ resolve_symbol (gfc_symbol *sym) } } + if (sym->attr.is_protected && !sym->attr.proc_pointer + && (sym->attr.procedure || sym->attr.external)) + { + if (sym->attr.external) + gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute " + "at %L", &sym->declared_at); + else + gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute " + "at %L", &sym->declared_at); + + return; + } + + + /* F2008, C530. */ + if (sym->attr.contiguous + && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE + && !sym->attr.pointer))) + { + gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an " + "array pointer or an assumed-shape array", sym->name, + &sym->declared_at); + return; + } + if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) return; @@ -11307,7 +11475,6 @@ resolve_symbol (gfc_symbol *sym) can. */ mp_flag = (sym->result != NULL && sym->result != sym); - /* Make sure that the intrinsic is consistent with its internal representation. This needs to be done before assigning a default type to avoid spurious warnings. */ @@ -11315,6 +11482,18 @@ resolve_symbol (gfc_symbol *sym) && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) return; + /* For associate names, resolve corresponding expression and make sure + they get their type-spec set this way. */ + if (sym->assoc) + { + gcc_assert (sym->attr.flavor == FL_VARIABLE); + if (gfc_resolve_expr (sym->assoc->target) != SUCCESS) + return; + + sym->ts = sym->assoc->target->ts; + gcc_assert (sym->ts.type != BT_UNKNOWN); + } + /* Assign default type to symbols that need one and don't have one. */ if (sym->ts.type == BT_UNKNOWN) { @@ -11344,6 +11523,7 @@ resolve_symbol (gfc_symbol *sym) sym->attr.dimension = sym->result->attr.dimension; sym->attr.pointer = sym->result->attr.pointer; sym->attr.allocatable = sym->result->attr.allocatable; + sym->attr.contiguous = sym->result->attr.contiguous; } } } diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 7b4ab244136..a8ab2353e85 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -390,7 +390,8 @@ gfc_release_include_path (void) static FILE * -open_included_file (const char *name, gfc_directorylist *list, bool module) +open_included_file (const char *name, gfc_directorylist *list, + bool module, bool system) { char *fullname; gfc_directorylist *p; @@ -407,7 +408,12 @@ open_included_file (const char *name, gfc_directorylist *list, bool module) f = gfc_open_file (fullname); if (f != NULL) - return f; + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (fullname, system); + + return f; + } } return NULL; @@ -421,28 +427,37 @@ open_included_file (const char *name, gfc_directorylist *list, bool module) FILE * gfc_open_included_file (const char *name, bool include_cwd, bool module) { - FILE *f; + FILE *f = NULL; - if (IS_ABSOLUTE_PATH (name)) - return gfc_open_file (name); - - if (include_cwd) + if (IS_ABSOLUTE_PATH (name) || include_cwd) { f = gfc_open_file (name); - if (f != NULL) - return f; + if (f && gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, false); } - return open_included_file (name, include_dirs, module); + if (!f) + f = open_included_file (name, include_dirs, module, false); + + return f; } FILE * gfc_open_intrinsic_module (const char *name) { + FILE *f = NULL; + if (IS_ABSOLUTE_PATH (name)) - return gfc_open_file (name); + { + f = gfc_open_file (name); + if (f && gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, true); + } + + if (!f) + f = open_included_file (name, intrinsic_modules_dirs, true, true); - return open_included_file (name, intrinsic_modules_dirs, true); + return f; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 743c4632986..7356625cf41 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4589,9 +4589,11 @@ gfc_simplify_selected_int_kind (gfc_expr *e) gfc_expr * -gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) +gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) { - int range, precision, i, kind, found_precision, found_range; + int range, precision, radix, i, kind, found_precision, found_range, + found_radix; + locus *loc = &gfc_current_locus; if (p == NULL) precision = 0; @@ -4600,6 +4602,7 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (p->expr_type != EXPR_CONSTANT || gfc_extract_int (p, &precision) != NULL) return NULL; + loc = &p->where; } if (q == NULL) @@ -4609,11 +4612,27 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (q->expr_type != EXPR_CONSTANT || gfc_extract_int (q, &range) != NULL) return NULL; + + if (!loc) + loc = &q->where; + } + + if (rdx == NULL) + radix = 0; + else + { + if (rdx->expr_type != EXPR_CONSTANT + || gfc_extract_int (rdx, &radix) != NULL) + return NULL; + + if (!loc) + loc = &rdx->where; } kind = INT_MAX; found_precision = 0; found_range = 0; + found_radix = 0; for (i = 0; gfc_real_kinds[i].kind != 0; i++) { @@ -4623,23 +4642,30 @@ gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q) if (gfc_real_kinds[i].range >= range) found_range = 1; + if (gfc_real_kinds[i].radix >= radix) + found_radix = 1; + if (gfc_real_kinds[i].precision >= precision - && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind) + && gfc_real_kinds[i].range >= range + && gfc_real_kinds[i].radix >= radix && gfc_real_kinds[i].kind < kind) kind = gfc_real_kinds[i].kind; } if (kind == INT_MAX) { - kind = 0; - - if (!found_precision) + if (found_radix && found_range && !found_precision) kind = -1; - if (!found_range) - kind -= 2; + else if (found_radix && found_precision && !found_range) + kind = -2; + else if (found_radix && !found_precision && !found_range) + kind = -3; + else if (found_radix) + kind = -4; + else + kind = -5; } - return gfc_get_int_expr (gfc_default_integer_kind, - p ? &p->where : &q->where, kind); + return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); } diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index ffef22d1140..f9ad5d82793 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -116,7 +116,8 @@ gfc_free_statement (gfc_code *p) break; case EXEC_BLOCK: - gfc_free_namespace (p->ext.ns); + gfc_free_namespace (p->ext.block.ns); + gfc_free_association_list (p->ext.block.assoc); break; case EXEC_COMPCALL: @@ -231,3 +232,15 @@ gfc_free_statements (gfc_code *p) } } + +/* Free an association list (of an ASSOCIATE statement). */ + +void +gfc_free_association_list (gfc_association_list* assoc) +{ + if (!assoc) + return; + + gfc_free_association_list (assoc->next); + gfc_free (assoc); +} diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index b436de5e2af..df6ada963c3 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -372,7 +372,8 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", *volatile_ = "VOLATILE", *is_protected = "PROTECTED", *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION"; + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", + *contiguous = "CONTIGUOUS"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -518,6 +519,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointer, cray_pointee); conf (cray_pointer, dimension); conf (cray_pointer, codimension); + conf (cray_pointer, contiguous); conf (cray_pointer, pointer); conf (cray_pointer, target); conf (cray_pointer, allocatable); @@ -529,6 +531,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointer, entry); conf (cray_pointee, allocatable); + conf (cray_pointer, contiguous); conf (cray_pointer, codimension); conf (cray_pointee, intent); conf (cray_pointee, optional); @@ -545,7 +548,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (data, function); conf (data, result); conf (data, allocatable); - conf (data, use_assoc); conf (value, pointer) conf (value, allocatable) @@ -567,7 +569,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) } conf (is_protected, intrinsic) - conf (is_protected, external) conf (is_protected, in_common) conf (asynchronous, intrinsic) @@ -587,7 +588,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (procedure, dimension) conf (procedure, codimension) conf (procedure, intrinsic) - conf (procedure, is_protected) conf (procedure, target) conf (procedure, value) conf (procedure, volatile_) @@ -616,6 +616,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (dummy); conf2 (volatile_); conf2 (asynchronous); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -723,6 +724,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (entry); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -931,6 +933,18 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) gfc_try +gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + attr->contiguous = 1; + return check_conflict (attr, name, where); +} + + +gfc_try gfc_add_external (symbol_attribute *attr, locus *where) { @@ -1718,6 +1732,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE) goto fail; + if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE) + goto fail; if (src->optional && gfc_add_optional (dest, where) == FAILURE) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) @@ -2515,6 +2531,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) /* Clear the ptrs we may need. */ p->common_block = NULL; p->f2k_derived = NULL; + p->assoc = NULL; return p; } @@ -4593,12 +4610,14 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, list and marked `error' until symbols are committed. */ gfc_typebound_proc* -gfc_get_typebound_proc (void) +gfc_get_typebound_proc (gfc_typebound_proc *tb0) { gfc_typebound_proc *result; tentative_tbp *list_node; result = XCNEW (gfc_typebound_proc); + if (tb0) + *result = *tb0; result->error = 1; list_node = XCNEW (tentative_tbp); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7d7b3a36839..7eb8e755785 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -285,7 +285,9 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim) tree type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); if (integer_zerop (dim) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) return gfc_index_one_node; return gfc_conv_descriptor_stride (desc, dim); @@ -5522,6 +5524,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, ultimate_ptr_comp = false; ultimate_alloc_comp = false; + for (ref = expr->ref; ref; ref = ref->next) { if (ref->next == NULL) @@ -5608,7 +5611,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, contiguous = g77 && !this_array_result && contiguous; /* There is no need to pack and unpack the array, if it is contiguous - and not deferred or assumed shape. */ + and not a deferred- or assumed-shape array, or if it is simply + contiguous. */ no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED @@ -5616,7 +5620,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, || (ref && ref->u.ar.as && ref->u.ar.as->type != AS_DEFERRED - && ref->u.ar.as->type != AS_ASSUMED_SHAPE)); + && ref->u.ar.as->type != AS_ASSUMED_SHAPE) + || + gfc_is_simply_contiguous (expr, false)); no_pack = contiguous && no_pack; @@ -5680,9 +5686,24 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, gfc_add_expr_to_block (&se->post, tmp); } - if (g77) + if (g77 || (fsym && fsym->attr.contiguous + && !gfc_is_simply_contiguous (expr, false))) { + tree origptr = NULL_TREE; + desc = se->expr; + + /* For contiguous arrays, save the original value of the descriptor. */ + if (!g77) + { + origptr = gfc_create_var (pvoid_type_node, "origptr"); + tmp = build_fold_indirect_ref_loc (input_location, desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (origptr), origptr, + fold_convert (TREE_TYPE (origptr), tmp)); + gfc_add_expr_to_block (&se->pre, tmp); + } + /* Repack the array. */ if (gfc_option.warn_array_temp) { @@ -5706,7 +5727,15 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, ptr = gfc_evaluate_now (ptr, &se->pre); - se->expr = ptr; + /* Use the packed data for the actual argument, except for contiguous arrays, + where the descriptor's data component is set. */ + if (g77) + se->expr = ptr; + else + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); + } if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) { @@ -5768,6 +5797,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, gfc_add_block_to_block (&block, &se->post); gfc_init_block (&se->post); + + /* Reset the descriptor pointer. */ + if (!g77) + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->post, tmp, origptr); + } + gfc_add_block_to_block (&se->post, &block); } } @@ -5938,6 +5975,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_loopinfo loop; stmtblock_t fnblock; stmtblock_t loopbody; + tree decl_type; tree tmp; tree comp; tree dcmp; @@ -5951,21 +5989,28 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_block (&fnblock); - if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0) + decl_type = TREE_TYPE (decl); + + if ((POINTER_TYPE_P (decl_type) && rank != 0) + || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) + decl = build_fold_indirect_ref_loc (input_location, decl); + /* Just in case in gets dereferenced. */ + decl_type = TREE_TYPE (decl); + /* If this an array of derived types with allocatable components build a loop and recursively call this function. */ - if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE - || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (TREE_CODE (decl_type) == ARRAY_TYPE + || GFC_DESCRIPTOR_TYPE_P (decl_type)) { tmp = gfc_conv_array_data (decl); var = build_fold_indirect_ref_loc (input_location, tmp); /* Get the number of elements - 1 and set the counter. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (GFC_DESCRIPTOR_TYPE_P (decl_type)) { /* Use the descriptor for an allocatable array. Since this is a full array reference, we only need the descriptor @@ -5981,7 +6026,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else { /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (TREE_TYPE (decl)); + tmp = array_type_nelts (decl_type); tmp = fold_convert (gfc_array_index_type, tmp); } @@ -5998,7 +6043,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) { - tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank); + tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank); gfc_add_expr_to_block (&fnblock, tmp); } tmp = build_fold_indirect_ref_loc (input_location, diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 224474aeff2..1c7226c41e6 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -612,8 +612,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) void gfc_allocate_lang_decl (tree decl) { - DECL_LANG_SPECIFIC (decl) = (struct lang_decl *) - ggc_alloc_cleared (sizeof (struct lang_decl)); + DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof + (struct lang_decl)); } /* Remember a symbol to generate initialization/cleanup code at function @@ -1213,7 +1213,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Create variables to hold the non-constant bits of array info. */ gfc_build_qualified_array (decl, sym); - if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer) + if (sym->attr.contiguous + || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)) GFC_DECL_PACKED_ARRAY (decl) = 1; } @@ -2424,26 +2425,26 @@ gfc_build_intrinsic_function_decls (void) gfor_fndecl_string_len_trim = gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")), - gfc_int4_type_node, 2, + gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_string_index = gfc_build_library_function_decl (get_identifier (PREFIX("string_index")), - gfc_int4_type_node, 5, + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); gfor_fndecl_string_scan = gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")), - gfc_int4_type_node, 5, + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); gfor_fndecl_string_verify = gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")), - gfc_int4_type_node, 5, + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); @@ -2611,9 +2612,10 @@ gfc_build_intrinsic_function_decls (void) gfor_fndecl_sr_kind = gfc_build_library_function_decl (get_identifier - (PREFIX("selected_real_kind")), - gfc_int4_type_node, 2, - pvoid_type_node, pvoid_type_node); + (PREFIX("selected_real_kind2008")), + gfc_int4_type_node, 3, + pvoid_type_node, pvoid_type_node, + pvoid_type_node); /* Power functions. */ { @@ -3410,7 +3412,7 @@ gfc_find_module (const char *name) htab_hash_string (name), INSERT); if (*slot == NULL) { - struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry); + struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry (); entry->name = gfc_get_string (name); entry->decls = htab_create_ggc (10, module_htab_decls_hash, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6c5c3286eb8..692b3e2f846 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1718,6 +1718,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.contiguous = sym->attr.contiguous; new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; @@ -2492,12 +2493,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, ss = gfc_walk_expr (e); if (ss == gfc_ss_terminator) { + parmse->ss = NULL; gfc_conv_expr_reference (parmse, e); tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); gfc_add_modify (&parmse->pre, ctree, tmp); } else { + parmse->ss = ss; gfc_conv_expr (parmse, e); gfc_add_modify (&parmse->pre, ctree, parmse->expr); } @@ -4867,41 +4870,40 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, } -/* Try to translate array(:) = func (...), where func is a transformational - array function, without using a temporary. Returns NULL is this isn't the - case. */ +/* There are quite a lot of restrictions on the optimisation in using an + array function assign without a temporary. */ -static tree -gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +static bool +arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) { - gfc_se se; - gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; bool c = false; - gfc_component *comp = NULL; + gfc_symbol *sym = expr1->symtree->n.sym; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) - return NULL; + return true; - /* Elemental functions don't need a temporary anyway. */ + /* Elemental functions are scalarized so that they don't need a + temporary in gfc_trans_assignment_1, so return a true. Otherwise, + they would need special treatment in gfc_trans_arrayfunc_assign. */ if (expr2->value.function.esym != NULL && expr2->value.function.esym->attr.elemental) - return NULL; + return true; - /* Fail if rhs is not FULL or a contiguous section. */ + /* Need a temporary if rhs is not FULL or a contiguous section. */ if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) - return NULL; + return true; - /* Fail if EXPR1 can't be expressed as a descriptor. */ + /* Need a temporary if EXPR1 can't be expressed as a descriptor. */ if (gfc_ref_needs_temporary_p (expr1->ref)) - return NULL; + return true; /* Functions returning pointers need temporaries. */ if (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable) - return NULL; + return true; /* Character array functions need temporaries unless the character lengths are the same. */ @@ -4909,15 +4911,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) { if (expr1->ts.u.cl->length == NULL || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return NULL; + return true; if (expr2->ts.u.cl->length == NULL || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return NULL; + return true; if (mpz_cmp (expr1->ts.u.cl->length->value.integer, expr2->ts.u.cl->length->value.integer) != 0) - return NULL; + return true; } /* Check that no LHS component references appear during an array @@ -4931,7 +4933,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) if (ref->type == REF_ARRAY) seen_array_ref= true; else if (ref->type == REF_COMPONENT && seen_array_ref) - return NULL; + return true; } /* Check for a dependency. */ @@ -4939,6 +4941,62 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) expr2->value.function.esym, expr2->value.function.actual, NOT_ELEMENTAL)) + return true; + + /* If we have reached here with an intrinsic function, we do not + need a temporary. */ + if (expr2->value.function.isym) + return false; + + /* If the LHS is a dummy, we need a temporary if it is not + INTENT(OUT). */ + if (sym->attr.dummy && sym->attr.intent != INTENT_OUT) + return true; + + /* A PURE function can unconditionally be called without a temporary. */ + if (expr2->value.function.esym != NULL + && expr2->value.function.esym->attr.pure) + return false; + + /* TODO a function that could correctly be declared PURE but is not + could do with returning false as well. */ + + if (!sym->attr.use_assoc + && !sym->attr.in_common + && !sym->attr.pointer + && !sym->attr.target + && expr2->value.function.esym) + { + /* A temporary is not needed if the function is not contained and + the variable is local or host associated and not a pointer or + a target. */ + if (!expr2->value.function.esym->attr.contained) + return false; + + /* A temporary is not needed if the variable is local and not + a pointer, a target or a result. */ + if (sym->ns->parent + && expr2->value.function.esym->ns == sym->ns->parent) + return false; + } + + /* Default to temporary use. */ + return true; +} + + +/* Try to translate array(:) = func (...), where func is a transformational + array function, without using a temporary. Returns NULL if this isn't the + case. */ + +static tree +gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_se se; + gfc_ss *ss; + gfc_component *comp = NULL; + + if (arrayfunc_assign_needs_temporary (expr1, expr2)) return NULL; /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 94dcc296dbf..06fd538d775 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -50,14 +50,12 @@ typedef struct GTY(()) gfc_intrinsic_map_t { /* Enum value from the "language-independent", aka C-centric, part of gcc, or END_BUILTINS of no such value set. */ - enum built_in_function code_r4; - enum built_in_function code_r8; - enum built_in_function code_r10; - enum built_in_function code_r16; - enum built_in_function code_c4; - enum built_in_function code_c8; - enum built_in_function code_c10; - enum built_in_function code_c16; + enum built_in_function float_built_in; + enum built_in_function double_built_in; + enum built_in_function long_double_built_in; + enum built_in_function complex_float_built_in; + enum built_in_function complex_double_built_in; + enum built_in_function complex_long_double_built_in; /* True if the naming pattern is to prepend "c" for complex and append "f" for kind=4. False if the naming pattern is to @@ -90,28 +88,33 @@ gfc_intrinsic_map_t; except for atan2. */ #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, (enum built_in_function) 0, \ - (enum built_in_function) 0, (enum built_in_function) 0, \ - (enum built_in_function) 0, true, false, true, NAME, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ - NULL_TREE}, + BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \ - BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \ - true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \ + BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \ - { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ - END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + END_BUILTINS, END_BUILTINS, END_BUILTINS, \ false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } +#define OTHER_BUILTIN(ID, NAME, TYPE) \ + { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ + BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + true, false, true, NAME, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = { - /* Functions built into gcc itself. */ + /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and + DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond + to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */ #include "mathbuiltins.def" /* Functions in libgfortran. */ @@ -121,30 +124,45 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = LIB_FUNCTION (NONE, NULL, false) }; +#undef OTHER_BUILTIN #undef LIB_FUNCTION #undef DEFINE_MATH_BUILTIN #undef DEFINE_MATH_BUILTIN_C -/* Structure for storing components of a floating number to be used by - elemental functions to manipulate reals. */ -typedef struct + +enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; + + +/* Find the correct variant of a given builtin from its argument. */ +static tree +builtin_decl_for_precision (enum built_in_function base_built_in, + int precision) { - tree arg; /* Variable tree to view convert to integer. */ - tree expn; /* Variable tree to save exponent. */ - tree frac; /* Variable tree to save fraction. */ - tree smask; /* Constant tree of sign's mask. */ - tree emask; /* Constant tree of exponent's mask. */ - tree fmask; /* Constant tree of fraction's mask. */ - tree edigits; /* Constant tree of the number of exponent bits. */ - tree fdigits; /* Constant tree of the number of fraction bits. */ - tree f1; /* Constant tree of the f1 defined in the real model. */ - tree bias; /* Constant tree of the bias of exponent in the memory. */ - tree type; /* Type tree of arg1. */ - tree mtype; /* Type tree of integer type. Kind is that of arg1. */ + int i = END_BUILTINS; + + gfc_intrinsic_map_t *m; + for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++) + ; + + if (precision == TYPE_PRECISION (float_type_node)) + i = m->float_built_in; + else if (precision == TYPE_PRECISION (double_type_node)) + i = m->double_built_in; + else if (precision == TYPE_PRECISION (long_double_type_node)) + i = m->long_double_built_in; + + return (i == END_BUILTINS ? NULL_TREE : built_in_decls[i]); +} + + +static tree +builtin_decl_for_float_kind (enum built_in_function double_built_in, int kind) +{ + int i = gfc_validate_kind (BT_REAL, kind, false); + return builtin_decl_for_precision (double_built_in, + gfc_real_kinds[i].mode_precision); } -real_compnt_info; -enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; /* Evaluate the arguments to an intrinsic function. The value of NARGS may be less than the actual number of arguments in EXPR @@ -353,14 +371,10 @@ build_round_expr (tree arg, tree restype) gcc_unreachable (); /* Now, depending on the argument type, we choose between intrinsics. */ - if (argprec == TYPE_PRECISION (float_type_node)) - fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF]; - else if (argprec == TYPE_PRECISION (double_type_node)) - fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND]; - else if (argprec == TYPE_PRECISION (long_double_type_node)) - fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL]; + if (longlong) + fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec); else - gcc_unreachable (); + fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec); return fold_convert (restype, build_call_expr_loc (input_location, fn, 1, arg)); @@ -416,6 +430,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) tree arg[2]; tree tmp; tree cond; + tree decl; mpfr_t huge; int n, nargs; int kind; @@ -423,44 +438,16 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) kind = expr->ts.kind; nargs = gfc_intrinsic_argument_list_length (expr); - n = END_BUILTINS; + decl = NULL_TREE; /* We have builtin functions for some cases. */ switch (op) { case RND_ROUND: - switch (kind) - { - case 4: - n = BUILT_IN_ROUNDF; - break; - - case 8: - n = BUILT_IN_ROUND; - break; - - case 10: - case 16: - n = BUILT_IN_ROUNDL; - break; - } + decl = builtin_decl_for_float_kind (BUILT_IN_ROUND, kind); break; case RND_TRUNC: - switch (kind) - { - case 4: - n = BUILT_IN_TRUNCF; - break; - - case 8: - n = BUILT_IN_TRUNC; - break; - - case 10: - case 16: - n = BUILT_IN_TRUNCL; - break; - } + decl = builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind); break; default: @@ -472,11 +459,9 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) gfc_conv_intrinsic_function_args (se, expr, arg, nargs); /* Use a builtin function if one exists. */ - if (n != END_BUILTINS) + if (decl != NULL_TREE) { - tmp = built_in_decls[n]; - se->expr = build_call_expr_loc (input_location, - tmp, 1, arg[0]); + se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]); return; } @@ -580,24 +565,30 @@ gfc_build_intrinsic_lib_fndecls (void) gfc_intrinsic_map_t *m; /* Add GCC builtin functions. */ - for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) + for (m = gfc_intrinsic_map; + m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) { - if (m->code_r4 != END_BUILTINS) - m->real4_decl = built_in_decls[m->code_r4]; - if (m->code_r8 != END_BUILTINS) - m->real8_decl = built_in_decls[m->code_r8]; - if (m->code_r10 != END_BUILTINS) - m->real10_decl = built_in_decls[m->code_r10]; - if (m->code_r16 != END_BUILTINS) - m->real16_decl = built_in_decls[m->code_r16]; - if (m->code_c4 != END_BUILTINS) - m->complex4_decl = built_in_decls[m->code_c4]; - if (m->code_c8 != END_BUILTINS) - m->complex8_decl = built_in_decls[m->code_c8]; - if (m->code_c10 != END_BUILTINS) - m->complex10_decl = built_in_decls[m->code_c10]; - if (m->code_c16 != END_BUILTINS) - m->complex16_decl = built_in_decls[m->code_c16]; + if (m->float_built_in != END_BUILTINS) + m->real4_decl = built_in_decls[m->float_built_in]; + if (m->complex_float_built_in != END_BUILTINS) + m->complex4_decl = built_in_decls[m->complex_float_built_in]; + if (m->double_built_in != END_BUILTINS) + m->real8_decl = built_in_decls[m->double_built_in]; + if (m->complex_double_built_in != END_BUILTINS) + m->complex8_decl = built_in_decls[m->complex_double_built_in]; + + /* If real(kind=10) exists, it is always long double. */ + if (m->long_double_built_in != END_BUILTINS) + m->real10_decl = built_in_decls[m->long_double_built_in]; + if (m->complex_long_double_built_in != END_BUILTINS) + m->complex10_decl = built_in_decls[m->complex_long_double_built_in]; + + /* For now, we assume that if real(kind=16) exists, it is long double. + Later, we will deal with __float128 and break this assumption. */ + if (m->long_double_built_in != END_BUILTINS) + m->real16_decl = built_in_decls[m->long_double_built_in]; + if (m->complex_long_double_built_in != END_BUILTINS) + m->complex16_decl = built_in_decls[m->complex_long_double_built_in]; } } @@ -666,18 +657,18 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) if (m->libm_name) { - if (ts->kind == 4) + int n = gfc_validate_kind (BT_REAL, ts->kind, false); + if (gfc_real_kinds[n].c_float) snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); - else if (ts->kind == 8) + ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); + else if (gfc_real_kinds[n].c_double) snprintf (name, sizeof (name), "%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name); + ts->type == BT_COMPLEX ? "c" : "", m->name); + else if (gfc_real_kinds[n].c_long_double) + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); else - { - gcc_assert (ts->kind == 10 || ts->kind == 16); - snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); - } + gcc_unreachable (); } else { @@ -725,7 +716,8 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) id = expr->value.function.isym->id; /* Find the entry for this function. */ - for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) + for (m = gfc_intrinsic_map; + m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) { if (id == m->id) break; @@ -787,31 +779,16 @@ gfc_trans_same_strlen_check (const char* intr_name, locus* where, static void gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) { - tree arg, type, res, tmp; - int frexp; + tree arg, type, res, tmp, frexp; - switch (expr->value.function.actual->expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - break; - case 8: - frexp = BUILT_IN_FREXP; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - break; - default: - gcc_unreachable (); - } + frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, + expr->value.function.actual->expr->ts.kind); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); res = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, arg, - gfc_build_addr_expr (NULL_TREE, res)); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, res)); gfc_add_expr_to_block (&se->pre, tmp); type = gfc_typenode_for_spec (&expr->ts); @@ -991,8 +968,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { - tree arg; - int n; + tree arg, cabs; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); @@ -1004,23 +980,8 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) break; case BT_COMPLEX: - switch (expr->ts.kind) - { - case 4: - n = BUILT_IN_CABSF; - break; - case 8: - n = BUILT_IN_CABS; - break; - case 10: - case 16: - n = BUILT_IN_CABSL; - break; - default: - gcc_unreachable (); - } - se->expr = build_call_expr_loc (input_location, - built_in_decls[n], 1, arg); + cabs = builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind); + se->expr = build_call_expr_loc (input_location, cabs, 1, arg); break; default: @@ -1072,6 +1033,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) tree tmp; tree test; tree test2; + tree fmod; mpfr_t huge; int n, ikind; tree args[2]; @@ -1091,33 +1053,16 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) break; case BT_REAL: - n = END_BUILTINS; + fmod = NULL_TREE; /* Check if we have a builtin fmod. */ - switch (expr->ts.kind) - { - case 4: - n = BUILT_IN_FMODF; - break; - - case 8: - n = BUILT_IN_FMOD; - break; - - case 10: - case 16: - n = BUILT_IN_FMODL; - break; - - default: - break; - } + fmod = builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind); /* Use it if it exists. */ - if (n != END_BUILTINS) + if (fmod != NULL_TREE) { - tmp = build_addr (built_in_decls[n], current_function_decl); + tmp = build_addr (fmod, current_function_decl); se->expr = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (built_in_decls[n])), + TREE_TYPE (TREE_TYPE (fmod)), tmp, 2, args); if (modulo == 0) return; @@ -1135,7 +1080,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0)) thereby avoiding another division and retaining the accuracy of the builtin function. */ - if (n != END_BUILTINS && modulo) + if (fmod != NULL_TREE && modulo) { tree zero = gfc_build_const (type, integer_zero_node); tmp = gfc_evaluate_now (se->expr, &se->pre); @@ -1232,24 +1177,8 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) { tree abs; - switch (expr->ts.kind) - { - case 4: - tmp = built_in_decls[BUILT_IN_COPYSIGNF]; - abs = built_in_decls[BUILT_IN_FABSF]; - break; - case 8: - tmp = built_in_decls[BUILT_IN_COPYSIGN]; - abs = built_in_decls[BUILT_IN_FABS]; - break; - case 10: - case 16: - tmp = built_in_decls[BUILT_IN_COPYSIGNL]; - abs = built_in_decls[BUILT_IN_FABSL]; - break; - default: - gcc_unreachable (); - } + tmp = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); + abs = builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); /* We explicitly have to ignore the minus sign. We do so by using result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */ @@ -1264,8 +1193,8 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) build_call_expr (tmp, 2, args[0], args[1])); } else - se->expr = build_call_expr_loc (input_location, - tmp, 2, args[0], args[1]); + se->expr = build_call_expr_loc (input_location, tmp, 2, + args[0], args[1]); return; } @@ -1400,7 +1329,7 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) args = (tree *) alloca (sizeof (tree) * num_args); var = gfc_create_var (pchar_type_node, "pstr"); - len = gfc_create_var (gfc_get_int_type (4), "len"); + len = gfc_create_var (gfc_charlen_type_node, "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = gfc_build_addr_expr (NULL_TREE, var); @@ -1441,7 +1370,7 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) args = (tree *) alloca (sizeof (tree) * num_args); var = gfc_create_var (pchar_type_node, "pstr"); - len = gfc_create_var (gfc_get_int_type (4), "len"); + len = gfc_create_var (gfc_charlen_type_node, "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = gfc_build_addr_expr (NULL_TREE, var); @@ -3620,32 +3549,16 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) { - tree arg, type, tmp; - int frexp; + tree arg, type, tmp, frexp; - switch (expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - break; - case 8: - frexp = BUILT_IN_FREXP; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - break; - default: - gcc_unreachable (); - } + frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); tmp = gfc_create_var (integer_type_node, NULL); - se->expr = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, - fold_convert (type, arg), - gfc_build_addr_expr (NULL_TREE, tmp)); + se->expr = build_call_expr_loc (input_location, frexp, 2, + fold_convert (type, arg), + gfc_build_addr_expr (NULL_TREE, tmp)); se->expr = fold_convert (type, se->expr); } @@ -3657,41 +3570,19 @@ gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) { - tree args[2], type, tmp; - int nextafter, copysign, huge_val; + tree args[2], type, tmp, nextafter, copysign, huge_val; - switch (expr->ts.kind) - { - case 4: - nextafter = BUILT_IN_NEXTAFTERF; - copysign = BUILT_IN_COPYSIGNF; - huge_val = BUILT_IN_HUGE_VALF; - break; - case 8: - nextafter = BUILT_IN_NEXTAFTER; - copysign = BUILT_IN_COPYSIGN; - huge_val = BUILT_IN_HUGE_VAL; - break; - case 10: - case 16: - nextafter = BUILT_IN_NEXTAFTERL; - copysign = BUILT_IN_COPYSIGNL; - huge_val = BUILT_IN_HUGE_VALL; - break; - default: - gcc_unreachable (); - } + nextafter = builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind); + copysign = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); + huge_val = builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - tmp = build_call_expr_loc (input_location, - built_in_decls[copysign], 2, - build_call_expr_loc (input_location, - built_in_decls[huge_val], 0), - fold_convert (type, args[1])); - se->expr = build_call_expr_loc (input_location, - built_in_decls[nextafter], 2, - fold_convert (type, args[0]), tmp); + tmp = build_call_expr_loc (input_location, copysign, 2, + build_call_expr_loc (input_location, huge_val, 0), + fold_convert (type, args[1])); + se->expr = build_call_expr_loc (input_location, nextafter, 2, + fold_convert (type, args[0]), tmp); se->expr = fold_convert (type, se->expr); } @@ -3717,8 +3608,8 @@ static void gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) { tree arg, type, prec, emin, tiny, res, e; - tree cond, tmp; - int frexp, scalbn, k; + tree cond, tmp, frexp, scalbn; + int k; stmtblock_t block; k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); @@ -3726,24 +3617,8 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1); tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0); - switch (expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - scalbn = BUILT_IN_SCALBNF; - break; - case 8: - frexp = BUILT_IN_FREXP; - scalbn = BUILT_IN_SCALBN; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - scalbn = BUILT_IN_SCALBNL; - break; - default: - gcc_unreachable (); - } + frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); arg = gfc_evaluate_now (arg, &se->pre); @@ -3755,17 +3630,15 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) /* Build the block for s /= 0. */ gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, arg, - gfc_build_addr_expr (NULL_TREE, e)); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec); gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node, tmp, emin)); - tmp = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, + tmp = build_call_expr_loc (input_location, scalbn, 2, build_real_from_int_cst (type, integer_one_node), e); gfc_add_modify (&block, res, tmp); @@ -3796,33 +3669,16 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) { - tree arg, type, e, x, cond, stmt, tmp; - int frexp, scalbn, fabs, prec, k; + tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs; + int prec, k; stmtblock_t block; k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); prec = gfc_real_kinds[k].digits; - switch (expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - scalbn = BUILT_IN_SCALBNF; - fabs = BUILT_IN_FABSF; - break; - case 8: - frexp = BUILT_IN_FREXP; - scalbn = BUILT_IN_SCALBN; - fabs = BUILT_IN_FABS; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - scalbn = BUILT_IN_SCALBNL; - fabs = BUILT_IN_FABSL; - break; - default: - gcc_unreachable (); - } + + frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); + fabs = builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); @@ -3831,20 +3687,17 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) e = gfc_create_var (integer_type_node, NULL); x = gfc_create_var (type, NULL); gfc_add_modify (&se->pre, x, - build_call_expr_loc (input_location, - built_in_decls[fabs], 1, arg)); + build_call_expr_loc (input_location, fabs, 1, arg)); gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, arg, - gfc_build_addr_expr (NULL_TREE, e)); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2 (MINUS_EXPR, integer_type_node, build_int_cst (NULL_TREE, prec), e); - tmp = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, x, tmp); + tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp); gfc_add_modify (&block, x, tmp); stmt = gfc_finish_block (&block); @@ -3861,31 +3714,15 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) { - tree args[2], type; - int scalbn; + tree args[2], type, scalbn; - switch (expr->ts.kind) - { - case 4: - scalbn = BUILT_IN_SCALBNF; - break; - case 8: - scalbn = BUILT_IN_SCALBN; - break; - case 10: - case 16: - scalbn = BUILT_IN_SCALBNL; - break; - default: - gcc_unreachable (); - } + scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, - fold_convert (type, args[0]), - fold_convert (integer_type_node, args[1])); + se->expr = build_call_expr_loc (input_location, scalbn, 2, + fold_convert (type, args[0]), + fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); } @@ -3895,39 +3732,20 @@ gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) { - tree args[2], type, tmp; - int frexp, scalbn; + tree args[2], type, tmp, frexp, scalbn; - switch (expr->ts.kind) - { - case 4: - frexp = BUILT_IN_FREXPF; - scalbn = BUILT_IN_SCALBNF; - break; - case 8: - frexp = BUILT_IN_FREXP; - scalbn = BUILT_IN_SCALBN; - break; - case 10: - case 16: - frexp = BUILT_IN_FREXPL; - scalbn = BUILT_IN_SCALBNL; - break; - default: - gcc_unreachable (); - } + frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); tmp = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr_loc (input_location, - built_in_decls[frexp], 2, - fold_convert (type, args[0]), - gfc_build_addr_expr (NULL_TREE, tmp)); - se->expr = build_call_expr_loc (input_location, - built_in_decls[scalbn], 2, tmp, - fold_convert (integer_type_node, args[1])); + tmp = build_call_expr_loc (input_location, frexp, 2, + fold_convert (type, args[0]), + gfc_build_addr_expr (NULL_TREE, tmp)); + se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp, + fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); } @@ -4598,6 +4416,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) else { /* An optional target. */ + if (arg2->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg2->expr, "$data"); ss2 = gfc_walk_expr (arg2->expr); nonzero_charlen = NULL_TREE; @@ -4805,7 +4625,7 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); addr = gfc_build_addr_expr (ppvoid_type_node, var); - len = gfc_create_var (gfc_get_int_type (4), "len"); + len = gfc_create_var (gfc_charlen_type_node, "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); args[0] = gfc_build_addr_expr (NULL_TREE, len); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 50e7847d0e1..7a7d33088d7 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -75,7 +75,10 @@ gfc_omp_privatize_by_reference (const_tree decl) enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree decl) { - if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl)) + if (DECL_ARTIFICIAL (decl) + && ! GFC_DECL_RESULT (decl) + && ! (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl))) return OMP_CLAUSE_DEFAULT_SHARED; /* Cray pointees shouldn't be listed in any clauses and should be @@ -118,6 +121,19 @@ gfc_omp_predetermined_sharing (tree decl) return OMP_CLAUSE_DEFAULT_UNSPECIFIED; } +/* Return decl that should be used when reporting DEFAULT(NONE) + diagnostics. */ + +tree +gfc_omp_report_decl (tree decl) +{ + if (DECL_ARTIFICIAL (decl) + && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + return GFC_DECL_SAVED_DESCRIPTOR (decl); + + return decl; +} /* Return true if DECL in private clause needs OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ @@ -1134,6 +1150,14 @@ gfc_trans_omp_critical (gfc_code *code) return build2 (OMP_CRITICAL, void_type_node, stmt, name); } +typedef struct dovar_init_d { + tree var; + tree init; +} dovar_init; + +DEF_VEC_O(dovar_init); +DEF_VEC_ALLOC_O(dovar_init,heap); + static tree gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, gfc_omp_clauses *do_clauses, tree par_clauses) @@ -1145,7 +1169,9 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, stmtblock_t body; gfc_omp_clauses *clauses = code->ext.omp_clauses; int i, collapse = clauses->collapse; - tree dovar_init = NULL_TREE; + VEC(dovar_init,heap) *inits = NULL; + dovar_init *di; + unsigned ix; if (collapse <= 0) collapse = 1; @@ -1260,7 +1286,9 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, /* Initialize DOVAR. */ tmp = fold_build2 (MULT_EXPR, type, count, step); tmp = fold_build2 (PLUS_EXPR, type, from, tmp); - dovar_init = tree_cons (dovar, tmp, dovar_init); + di = VEC_safe_push (dovar_init, heap, inits, NULL); + di->var = dovar; + di->init = tmp; } if (!dovar_found) @@ -1329,24 +1357,18 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, gfc_start_block (&body); - dovar_init = nreverse (dovar_init); - while (dovar_init) - { - gfc_add_modify (&body, TREE_PURPOSE (dovar_init), - TREE_VALUE (dovar_init)); - dovar_init = TREE_CHAIN (dovar_init); - } + for (ix = 0; VEC_iterate (dovar_init, inits, ix, di); ix++) + gfc_add_modify (&body, di->var, di->init); + VEC_free (dovar_init, heap, inits); /* Cycle statement is implemented with a goto. Exit statement must not be present for this loop. */ cycle_label = gfc_build_label_decl (NULL_TREE); - /* Put these labels where they can be found later. We put the - labels in a TREE_LIST node (because TREE_CHAIN is already - used). cycle_label goes in TREE_PURPOSE (backend_decl), exit - label in TREE_VALUE (backend_decl). */ + /* Put these labels where they can be found later. */ - code->block->backend_decl = tree_cons (cycle_label, NULL, NULL); + code->block->cycle_label = cycle_label; + code->block->exit_label = NULL_TREE; /* Main loop body. */ tmp = gfc_trans_omp_code (code->block->next, true); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 37b577f2cc4..6fa84b91694 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -850,7 +850,7 @@ gfc_trans_block_construct (gfc_code* code) stmtblock_t body; tree tmp; - ns = code->ext.ns; + ns = code->ext.block.ns; gcc_assert (ns); sym = ns->proc_name; gcc_assert (sym); @@ -928,7 +928,8 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, exit_label = gfc_build_label_decl (NULL_TREE); /* Put the labels where they can be found later. See gfc_trans_do(). */ - code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); + code->block->cycle_label = cycle_label; + code->block->exit_label = exit_label; /* Loop body. */ gfc_start_block (&body); @@ -1196,12 +1197,10 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Loop body. */ gfc_start_block (&body); - /* Put these labels where they can be found later. We put the - labels in a TREE_LIST node (because TREE_CHAIN is already - used). cycle_label goes in TREE_PURPOSE (backend_decl), exit - label in TREE_VALUE (backend_decl). */ + /* Put these labels where they can be found later. */ - code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); + code->block->cycle_label = cycle_label; + code->block->exit_label = exit_label; /* Main loop body. */ tmp = gfc_trans_code_cond (code->block->next, exit_cond); @@ -1305,7 +1304,8 @@ gfc_trans_do_while (gfc_code * code) exit_label = gfc_build_label_decl (NULL_TREE); /* Put the labels where they can be found later. See gfc_trans_do(). */ - code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); + code->block->cycle_label = cycle_label; + code->block->exit_label = exit_label; /* Create a GIMPLE version of the exit condition. */ gfc_init_se (&cond, NULL); @@ -4080,7 +4080,7 @@ gfc_trans_cycle (gfc_code * code) { tree cycle_label; - cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl); + cycle_label = code->ext.whichloop->cycle_label; TREE_USED (cycle_label) = 1; return build1_v (GOTO_EXPR, cycle_label); } @@ -4095,7 +4095,7 @@ gfc_trans_exit (gfc_code * code) { tree exit_label; - exit_label = TREE_VALUE (code->ext.whichloop->backend_decl); + exit_label = code->ext.whichloop->exit_label; TREE_USED (exit_label) = 1; return build1_v (GOTO_EXPR, exit_label); } @@ -4155,20 +4155,23 @@ gfc_trans_allocate (gfc_code * code) /* A scalar or derived type. */ /* Determine allocate size. */ - if (code->expr3 && code->expr3->ts.type == BT_CLASS) + if (al->expr->ts.type == BT_CLASS && code->expr3) { - gfc_expr *sz; - gfc_se se_sz; - sz = gfc_copy_expr (code->expr3); - gfc_add_component_ref (sz, "$vptr"); - gfc_add_component_ref (sz, "$size"); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - memsz = se_sz.expr; + if (code->expr3->ts.type == BT_CLASS) + { + gfc_expr *sz; + gfc_se se_sz; + sz = gfc_copy_expr (code->expr3); + gfc_add_component_ref (sz, "$vptr"); + gfc_add_component_ref (sz, "$size"); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + memsz = se_sz.expr; + } + else + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); } - else if (code->expr3 && code->expr3->ts.type != BT_CLASS) - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); else if (code->ext.alloc.ts.type != BT_UNKNOWN) memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); else @@ -4230,7 +4233,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); /* Initialization via SOURCE block. */ - if (code->expr3) + if (code->expr3 && !code->expr3->mold) { gfc_expr *rhs = gfc_copy_expr (code->expr3); if (al->expr->ts.type == BT_CLASS) @@ -4266,7 +4269,7 @@ gfc_trans_allocate (gfc_code * code) rhs = NULL; if (code->expr3 && code->expr3->ts.type == BT_CLASS) { - /* VPTR must be determined at run time. */ + /* Polymorphic SOURCE: VPTR must be determined at run time. */ rhs = gfc_copy_expr (code->expr3); gfc_add_component_ref (rhs, "$vptr"); tmp = gfc_trans_pointer_assignment (lhs, rhs); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index d794c2fb668..2f5b759886d 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1202,7 +1202,8 @@ gfc_is_nodesc_array (gfc_symbol * sym) static tree gfc_build_array_type (tree type, gfc_array_spec * as, - enum gfc_array_kind akind, bool restricted) + enum gfc_array_kind akind, bool restricted, + bool contiguous) { tree lbound[GFC_MAX_DIMENSIONS]; tree ubound[GFC_MAX_DIMENSIONS]; @@ -1219,7 +1220,8 @@ gfc_build_array_type (tree type, gfc_array_spec * as, } if (as->type == AS_ASSUMED_SHAPE) - akind = GFC_ARRAY_ASSUMED_SHAPE; + akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT + : GFC_ARRAY_ASSUMED_SHAPE; return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound, ubound, 0, akind, restricted); } @@ -1390,8 +1392,8 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, type = make_node (ARRAY_TYPE); GFC_ARRAY_TYPE_P (type) = 1; - TYPE_LANG_SPECIFIC (type) = (struct lang_type *) - ggc_alloc_cleared (sizeof (struct lang_type)); + TYPE_LANG_SPECIFIC (type) + = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); known_stride = (packed != PACKED_NO); known_offset = 1; @@ -1631,8 +1633,8 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, TYPE_NAME (fat_type) = get_identifier (name); GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; - TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *) - ggc_alloc_cleared (sizeof (struct lang_type)); + TYPE_LANG_SPECIFIC (fat_type) + = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); GFC_TYPE_ARRAY_RANK (fat_type) = dimen; GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE; @@ -1799,10 +1801,12 @@ gfc_sym_type (gfc_symbol * sym) { enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN; if (sym->attr.pointer) - akind = GFC_ARRAY_POINTER; + akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; else if (sym->attr.allocatable) akind = GFC_ARRAY_ALLOCATABLE; - type = gfc_build_array_type (type, sym->as, akind, restricted); + type = gfc_build_array_type (type, sym->as, akind, restricted, + sym->attr.contiguous); } } else @@ -2121,14 +2125,16 @@ gfc_get_derived_type (gfc_symbol * derived) { enum gfc_array_kind akind; if (c->attr.pointer) - akind = GFC_ARRAY_POINTER; + akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; else akind = GFC_ARRAY_ALLOCATABLE; /* Pointers to arrays aren't actually pointer types. The descriptors are separate, but the data is common. */ field_type = gfc_build_array_type (field_type, c->as, akind, !c->attr.target - && !c->attr.pointer); + && !c->attr.pointer, + c->attr.contiguous); } else field_type = gfc_get_nodesc_array_type (field_type, c->as, @@ -2516,7 +2522,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) if (int_size_in_bytes (etype) <= 0) return false; /* Nor non-constant lower bounds in assumed shape arrays. */ - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE) + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) { for (dim = 0; dim < rank; dim++) if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE @@ -2565,7 +2572,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) info->allocated = build2 (NE_EXPR, boolean_type_node, info->data_location, null_pointer_node); - else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER) + else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) info->associated = build2 (NE_EXPR, boolean_type_node, info->data_location, null_pointer_node); @@ -2579,7 +2587,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) size_binop (PLUS_EXPR, dim_off, upper_suboff)); t = build1 (INDIRECT_REF, gfc_array_index_type, t); info->dimen[dim].upper_bound = t; - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE) + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) { /* Assumed shape arrays have known lower bounds. */ info->dimen[dim].upper_bound diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 9ee81480c5b..02361fc8466 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -523,6 +523,7 @@ bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); /* In trans-openmp.c */ bool gfc_omp_privatize_by_reference (const_tree); enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree); +tree gfc_omp_report_decl (tree); tree gfc_omp_clause_default_ctor (tree, tree, tree); tree gfc_omp_clause_copy_ctor (tree, tree, tree); tree gfc_omp_clause_assign_op (tree, tree, tree); @@ -619,18 +620,24 @@ extern GTY(()) tree gfor_fndecl_sr_kind; /* True if node is an integer constant. */ #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) -/* G95-specific declaration information. */ +/* gfortran-specific declaration information, the _CONT versions denote + arrays with CONTIGUOUS attribute. */ enum gfc_array_kind { GFC_ARRAY_UNKNOWN, GFC_ARRAY_ASSUMED_SHAPE, + GFC_ARRAY_ASSUMED_SHAPE_CONT, GFC_ARRAY_ALLOCATABLE, - GFC_ARRAY_POINTER + GFC_ARRAY_POINTER, + GFC_ARRAY_POINTER_CONT }; /* Array types only. */ -struct GTY(()) lang_type { +/* FIXME: the variable_size annotation here is needed because these types are + variable-sized in some other frontends. Due to gengtype deficiency the GTY + options of such types have to agree across all frontends. */ +struct GTY((variable_size)) lang_type { int rank; enum gfc_array_kind akind; tree lbound[GFC_MAX_DIMENSIONS]; @@ -644,7 +651,7 @@ struct GTY(()) lang_type { tree base_decl[2]; }; -struct GTY(()) lang_decl { +struct GTY((variable_size)) lang_decl { /* Dummy variables. */ tree saved_descriptor; /* Assigned integer nodes. Stringlength is the IO format string's length. |