diff options
Diffstat (limited to 'gcc/fortran')
41 files changed, 2728 insertions, 1833 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 18509132034..baba9e569e9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,472 @@ +2010-07-23 Jakub Jelinek <jakub@redhat.com> + + * trans-types.c (gfc_get_array_descriptor_base, + gfc_get_array_type_bounds): Set TYPE_NAMELESS. + * trans-decl.c (gfc_build_qualified_array): Set DECL_NAMELESS + instead of clearing DECL_NAME. + (gfc_build_dummy_array_decl): Set DECL_NAMELESS. + +2009-07-23 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/24524 + * trans-array.c (gfc_init_loopinfo): Initialize the reverse + field. + gfc_trans_scalarized_loop_end: If reverse set in dimension n, + reverse the scalarization loop. + gfc_conv_resolve_dependencies: Pass the reverse field of the + loopinfo to gfc_dep_resolver. + trans-expr.c (gfc_trans_assignment_1): Enable loop reversal for + assignment by resetting loop.reverse. + gfortran.h : Add the gfc_reverse enum. + trans.h : Add the reverse field to gfc_loopinfo. + dependency.c (gfc_check_dependency): Pass null to the new arg + of gfc_dep_resolver. + (gfc_check_section_vs_section): Check for reverse dependencies. + (gfc_dep_resolver): Add reverse argument and deal with the loop + reversal logic. + dependency.h : Modify prototype for gfc_dep_resolver to include + gfc_reverse *. + +2010-07-23 Daniel Kraft <d@domob.eu> + + PR fortran/44709 + * gfortran.h (gfc_find_symtree_in_proc): New method. + * symbol.c (gfc_find_symtree_in_proc): New method. + * match.c (match_exit_cycle): Look for loop name also in parent + namespaces within current procedure. + +2010-07-22 Tobias Burnus <burnus@net-b.de> + + PR fortran/45019 + * dependency.c (gfc_check_dependency): Add argument alising check. + * symbol.c (gfc_symbols_could_alias): Add argument alising check. + +2010-07-22 Daniel Kraft <d@domob.eu> + + * trans-stmt.c (gfc_trans_return): Put back in the handling of se.post, + now in the correct place. + +2010-07-21 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/44929 + * Revert my commit r162325. + +2010-07-21 Daniel Kraft <d@domob.eu> + + * trans.h (gfc_get_return_label): Removed. + (gfc_generate_return): New method. + (gfc_trans_deferred_vars): Update gfc_wrapped_block rather than + returning a tree directly. + * trans-stmt.c (gfc_trans_return): Use `gfc_generate_return'. + (gfc_trans_block_construct): Update for new interface to + `gfc_trans_deferred_vars'. + * trans-decl.c (current_function_return_label): Removed. + (current_procedure_symbol): New variable. + (gfc_get_return_label): Removed. + (gfc_trans_deferred_vars): Update gfc_wrapped_block rather than + returning a tree directly. + (get_proc_result), (gfc_generate_return): New methods. + (gfc_generate_function_code): Clean up and do init/cleanup here + also with gfc_wrapped_block. Remove return-label but rather + return directly. + +2010-07-19 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/44929 + * fortran/match.c (match_type_spec): Check for derived type before + intrinsic types. + +2010-07-19 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/42385 + * interface.c (matching_typebound_op): Add argument for the + return of the generic name for the procedure. + (build_compcall_for_operator): Add an argument for the generic + name of an operator procedure and supply it to the expression. + (gfc_extend_expr, gfc_extend_assign): Use the generic name in + calls to the above procedures. + * resolve.c (resolve_typebound_function): Catch procedure + component calls for CLASS objects, check that the vtable is + complete and insert the $vptr and procedure components, to make + the call. + (resolve_typebound_function): The same. + * trans-decl.c (gfc_trans_deferred_vars): Do not deallocate + an allocatable scalar if it is a result. + +2010-07-19 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44353 + * match.c (gfc_match_iterator): Reverted. + +2010-07-18 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44353 + * match.c (gfc_match_iterator): Remove error that iterator + cannot be INTENT(IN). + +2010-07-17 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_free_ss): Don't free beyond ss rank. + Access subscript through the "dim" field index. + (gfc_trans_create_temp_array): Access ss info through the "dim" field + index. + (gfc_conv_array_index_offset): Ditto. + (gfc_conv_loop_setup): Ditto. + (gfc_conv_expr_descriptor): Ditto. + (gfc_conv_ss_startstride): Ditto. Update call to + gfc_conv_section_startstride. + (gfc_conv_section_startstride): Set values along the array dimension. + Get array dimension directly from the argument. + +2010-07-15 Jakub Jelinek <jakub@redhat.com> + + * trans.h (gfc_string_to_single_character): New prototype. + * trans-expr.c (string_to_single_character): Renamed to ... + (gfc_string_to_single_character): ... this. No longer static. + (gfc_conv_scalar_char_value, gfc_build_compare_string, + gfc_trans_string_copy): Adjust callers. + * config-lang.in (gtfiles): Add fortran/trans-stmt.c. + * trans-stmt.c: Include ggc.h and gt-fortran-trans-stmt.h. + (select_struct): Move to toplevel, add GTY(()). + (gfc_trans_character_select): Optimize SELECT CASE + with character length 1. + +2010-07-15 Nathan Froyd <froydnj@codesourcery.com> + + * f95-lang.c: Carefully replace TREE_CHAIN with DECL_CHAIN. + * trans-common.c: Likewise. + * trans-decl.c: Likewise. + * trans-types.c: Likewise. + * trans.c: Likewise. + +2010-07-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44936 + * resolve.c (resolve_typebound_generic_call): Resolve generic + non-polymorphic type-bound procedure calls to the correct specific + procedure. + (resolve_typebound_subroutine): Remove superfluous code. + +2010-07-15 Daniel Kraft <d@domob.eu> + + PR fortran/44709 + * trans.h (struct gfc_wrapped_block): New struct. + (gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods. + (gfc_finish_wrapped_block): New method. + (gfc_init_default_dt): Add new init code to block rather than + returning it. + * trans-array.h (gfc_trans_auto_array_allocation): Use gfc_wrapped_block + (gfc_trans_dummy_array_bias): Ditto. + (gfc_trans_g77_array): Ditto. + (gfc_trans_deferred_array): Ditto. + * trans.c (gfc_add_expr_to_block): Call add_expr_to_chain. + (add_expr_to_chain): New method based on old gfc_add_expr_to_block. + (gfc_start_wrapped_block), (gfc_add_init_cleanup): New methods. + (gfc_finish_wrapped_block): New method. + * trans-array.c (gfc_trans_auto_array_allocation): use gfc_wrapped_block + (gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto. + (gfc_trans_deferred_array): Ditto. + * trans-decl.c (gfc_trans_dummy_character): Ditto. + (gfc_trans_auto_character_variable), (gfc_trans_assign_aux_var): Ditto. + (init_intent_out_dt): Ditto. + (gfc_init_default_dt): Add new init code to block rather than + returning it. + (gfc_trans_deferred_vars): Use gfc_wrapped_block to collect all init + and cleanup code and put it all together. + +2010-07-15 Jakub Jelinek <jakub@redhat.com> + + * trans.h (gfc_build_compare_string): Add CODE argument. + * trans-intrinsic.c (gfc_conv_intrinsic_strcmp): Pass OP to + gfc_build_compare_string. + * trans-expr.c (gfc_conv_expr_op): Pass CODE to + gfc_build_compare_string. + (string_to_single_character): Rename len variable to length. + (gfc_optimize_len_trim): New function. + (gfc_build_compare_string): Add CODE argument. If it is EQ_EXPR + or NE_EXPR and one of the strings is string literal with LEN_TRIM + bigger than the length of the other string, they compare unequal. + + PR fortran/40206 + * trans-stmt.c (gfc_trans_character_select): Always use NULL for high + in CASE_LABEL_EXPR and use NULL for low for the default case. + +2010-07-14 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (gfc_conv_section_upper_bound): Remove + (gfc_conv_section_startstride): Don't set the upper bound in the + vector subscript case. + (gfc_conv_loop_setup): Don't use gfc_conv_section_upper_bound + +2010-07-14 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44925 + * gfortran.h (gfc_is_data_pointer): Remove prototype. + * dependency.c (gfc_is_data_pointer): Make it static. + * intrinsic.texi: Update documentation on C_LOC. + * resolve.c (gfc_iso_c_func_interface): Fix pointer and target checks + and add a check for polymorphic variables. + +2010-07-14 Jakub Jelinek <jakub@redhat.com> + + * trans-expr.c (string_to_single_character): Also optimize + string literals containing a single char followed only by spaces. + (gfc_trans_string_copy): Remove redundant string_to_single_character + calls. + + * trans-decl.c (gfc_build_intrinsic_function_decls, + gfc_build_builtin_function_decls): Mark functions as + DECL_PURE_P or TREE_READONLY. + +2010-07-13 Nathan Froyd <froydnj@codesourcery.com> + + * trans-decl.c (build_entry_thunks): Call build_call_expr_loc_vec + instead of build_function_call_expr. + * trans-intrinsic.c (gfc_conv_intrinsic_sr_kind): Likewise. + +2010-07-13 Tobias Burnus <burnus@net-b.de> + Daniel Franke <franke.daniel@gmail.com> + + PR fortran/43665 + * trans.h (gfc_build_library_function_decl_with_spec): New prototype. + * trans-decl.c (gfc_build_library_function_decl_with_spec): Removed + static. + * trans-io (gfc_build_io_library_fndecls): Add "fn spec" annotations. + +2010-07-13 Daniel Franke <franke.daniel@gmail.com> + Tobias Burnus <burnus@net-b.de> + + PR fortran/43665 + * trans-decl.c (gfc_build_intrinsic_function_decls): Add + noclobber/noescape annotations to function calls. + (gfc_build_builtin_function_decls): Likewise. + +2010-07-13 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44434 + PR fortran/44565 + PR fortran/43945 + PR fortran/44869 + * gfortran.h (gfc_find_derived_vtab): Modified prototype. + * class.c (gfc_build_class_symbol): Modified call to + 'gfc_find_derived_vtab'. + (add_proc_component): Removed, moved code into 'add_proc_comp'. + (add_proc_comps): Renamed to 'add_proc_comp', removed treatment of + generics. + (add_procs_to_declared_vtab1): Removed unnecessary argument 'resolved'. + Removed treatment of generics. + (copy_vtab_proc_comps): Removed unnecessary argument 'resolved'. + Call 'add_proc_comp' instead of duplicating code. + (add_procs_to_declared_vtab): Removed unnecessary arguments 'resolved' + and 'declared'. + (add_generic_specifics,add_generics_to_declared_vtab): Removed. + (gfc_find_derived_vtab): Removed unnecessary argument 'resolved'. + Removed treatment of generics. + * iresolve.c (gfc_resolve_extends_type_of): Modified call to + 'gfc_find_derived_vtab'. + * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): + Removed treatment of generics. + (resolve_select_type,resolve_fl_derived): Modified call to + 'gfc_find_derived_vtab'. + * trans-decl.c (gfc_get_symbol_decl): Ditto. + * trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign): + Ditto. + * trans-stmt.c (gfc_trans_allocate): Ditto. + +2010-07-12 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/37077 + * trans-io.c (build_dt): Set common.unit to flag chracter(kind=4) + internal unit. + +2010-07-12 Mikael Morin <mikael@gcc.gnu.org> + + * expr.c (gfc_get_int_expr): Don't initialize mpfr data twice. + * resolve.c (build_default_init_expr): Ditto. + +2010-07-11 Tobias Burnus <burnus@net-b.de> + + PR fortran/44702 + * module.c (sort_iso_c_rename_list): Remove. + (import_iso_c_binding_module,use_iso_fortran_env_module): + Allow multiple imports of the same symbol. + +2010-07-11 Mikael Morin <mikael@gcc.gnu.org> + + * arith.c (gfc_arith_done_1): Release mpfr internal caches. + +2010-07-11 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44869 + * decl.c (build_sym,attr_decl1): Only build the class container if the + symbol has sufficient attributes. + * expr.c (gfc_check_pointer_assign): Use class_pointer instead of + pointer attribute for classes. + * match.c (gfc_match_allocate,gfc_match_deallocate): Ditto. + * module.c (MOD_VERSION): Bump. + (enum ab_attribute,attr_bits): Add AB_CLASS_POINTER. + (mio_symbol_attribute): Handle class_pointer attribute. + * parse.c (parse_derived): Use class_pointer instead of pointer + attribute for classes. + * primary.c (gfc_variable_attr,gfc_expr_attr): Ditto. + * resolve.c (resolve_structure_cons,resolve_deallocate_expr, + resolve_allocate_expr,resolve_fl_derived): Ditto. + (resolve_fl_var_and_proc): Check for class_ok attribute. + +2010-07-10 Mikael Morin <mikael@gcc.gnu.org> + + * trans-io.c (gfc_build_st_parameter): Update calls to + gfc_add_field_to_struct. + * trans-stmt.c (ADD_FIELD): Ditto. + * trans-types.c + (gfc_get_derived_type): Ditto. Don't create backend_decl for C_PTR's + C_ADDRESS field. + (gfc_add_field_to_struct_1): Set TYPE_FIELDS(context) instead of + fieldlist, remove fieldlist from argument list. + (gfc_add_field_to_struct): Update call to gfc_add_field_to_struct_1 + and remove fieldlist from argument list. + (gfc_get_desc_dim_type, gfc_get_array_descriptor_base, + gfc_get_mixed_entry_union): Move setting + TYPE_FIELDS to gfc_add_field_to_struct_1 and update calls to it. + * trans-types.h (gfc_add_field_to_struct): Update prototype. + +2010-07-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44773 + * trans-expr.c (arrayfunc_assign_needs_temporary): No temporary + if the lhs has never been host associated, as well as not being + use associated, a pointer or a target. + * resolve.c (resolve_variable): Mark variables that are host + associated. + * gfortran.h: Add the host_assoc bit to the symbol_attribute + structure. + +2010-07-09 Janus Weil <janus@gcc.gnu.org> + + * intrinsic.texi: Add documentation for SAME_TYPE_AS, EXTENDS_TYPE_OF, + STORAGE_SIZE, C_NULL_PTR and C_NULL_FUNPTR. Modify documentation of + SIZEOF and C_SIZEOF. + +2010-07-08 Janus Weil <janus@gcc.gnu.org> + + PR fortran/44649 + * gfortran.h (gfc_isym_id): Add GFC_ISYM_C_SIZEOF,GFC_ISYM_STORAGE_SIZE. + * intrinsic.h (gfc_check_c_sizeof,gfc_check_storage_size, + gfc_resolve_storage_size): New prototypes. + * check.c (gfc_check_c_sizeof,gfc_check_storage_size): New functions. + * intrinsic.c (add_functions): Add STORAGE_SIZE. + * iresolve.c (gfc_resolve_storage_size): New function. + * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle polymorphic + arguments. + (gfc_conv_intrinsic_storage_size): New function. + (gfc_conv_intrinsic_function): Handle STORAGE_SIZE. + +2010-07-08 Jakub Jelinek <jakub@redhat.com> + + PR fortran/44847 + * match.c (match_exit_cycle): Error on EXIT also from collapsed + !$omp do loops. Error on CYCLE to non-innermost collapsed + !$omp do loops. + +2010-07-08 Tobias Burnus <burnus@net-b.de> + + PR fortran/18918 + * array.c (gfc_match_array_ref): Better error message for + coarrays with too few ranks. + (match_subscript): Move one diagnostic to caller. + * gfortran.h (gfc_get_corank): Add prottype. + * expr.c (gfc_get_corank): New function. + * iresolve.c (resolve_bound): Fix rank for cobounds. + (gfc_resolve_lbound,gfc_resolve_lcobound, gfc_resolve_ubound, + gfc_resolve_ucobound, gfc_resolve_this_image): Update + resolve_bound call. + +2010-07-06 Tobias Burnus <burnus@net-b.de> + + PR fortran/44742 + * array.c (gfc_expand_constructor): Add optional diagnostic. + * gfortran.h (gfc_expand_constructor): Update prototype. + * expr.c (gfc_simplify_expr, check_init_expr, + gfc_reduce_init_expr): Update gfc_expand_constructor call. + * resolve.c (gfc_resolve_expr): Ditto. + +2010-07-06 Tobias Burnus <burnus@net-b.de> + + * trans-decl.c: Include diagnostic-core.h besides toplev.h. + * trans-intrinsic.c: Ditto. + * trans-types.c: Ditto. + * convert.c: Include diagnostic-core.h instead of toplev.h. + * options.c: Ditto. + * trans-array.c: Ditto. + * trans-const.c: Ditto. + * trans-expr.c: Ditto. + * trans-io.c: Ditto. + * trans-openmp.c: Ditto. + * trans.c: Ditto. + +2010-07-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/PR44693 + * check.c (dim_rank_check): Also check intrinsic functions. + Adjust permissible rank for functions which reduce the rank of + their argument. Spread is an exception, where DIM can + be one larger than the rank of array. + +2010-07-05 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/44797 + * fortran/io.c (resolve_tag): Check EXIST tag is a default logical. + +2010-07-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44596 + * trans-types.c (gfc_get_derived_type): Derived type fields + with the vtype attribute must have TYPE_REF_CAN_ALIAS_ALL set + but build_pointer_type_for_mode must be used for this. + +2010-07-05 Nathan Froyd <froydnj@codesourcery.com> + + * trans.h (gfc_conv_procedure_call): Take a VEC instead of a tree. + * trans-intrinsic.c (gfc_conv_intrinsic_funcall): Adjust for new + type of gfc_conv_procedure_call. + (conv_generic_with_optional_char_arg): Likewise. + * trans-stmt.c (gfc_trans_call): Likewise. + * trans-expr.c (gfc_conv_function_expr): Likewise. + (gfc_conv_procedure_call): Use build_call_vec instead of + build_call_list. + +2010-07-04 Daniel Kraft <d@domob.eu> + + * gfc-internals.texi (gfc_code): Document BLOCK and ASSOCIATE. + +2010-07-04 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/44596 + PR fortran/44745 + * trans-types.c (gfc_get_derived_type): Derived type fields + with the vtype attribute must have TYPE_REF_CAN_ALIAS_ALL set. + +2010-07-02 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/44662 + * decl.c (match_procedure_in_type): Clear structure before using. + (gfc_match_generic): Ditto. + +2010-07-02 Nathan Froyd <froydnj@codesourcery.com> + + * trans-types.h (gfc_add_field_to_struct): Add tree ** parameter. + * trans-types.c (gfc_add_field_to_struct_1): New function, most + of which comes from... + (gfc_add_field_to_struct): ...here. Call it. Add new parameter. + (gfc_get_desc_dim_type): Call gfc_add_field_to_struct_1 for + building fields. + (gfc_get_array_descriptor_base): Likewise. + (gfc_get_mixed_entry_union): Likewise. + (gfc_get_derived_type): Add extra chain parameter for + gfc_add_field_to_struct. + * trans-stmt.c (gfc_trans_character_select): Likewise. + * trans-io.c (gfc_build_st_parameter): Likewise. + 2010-06-29 Janus Weil <janus@gcc.gnu.org> PR fortran/44718 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 1e90584be49..f555eb104cd 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -260,6 +260,8 @@ gfc_arith_done_1 (void) for (rp = gfc_real_kinds; rp->kind; rp++) mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL); + + mpfr_free_cache (); } diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 64816f28abb..68b6456cdbc 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -91,7 +91,9 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star) else if (!star) m = gfc_match_expr (&ar->start[i]); - if (m == MATCH_NO) + if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES) + return MATCH_NO; + else if (m == MATCH_NO) gfc_error ("Expected array subscript at %C"); if (m != MATCH_YES) return MATCH_ERROR; @@ -229,12 +231,28 @@ coarray: if (gfc_match_char (']') == MATCH_YES) { ar->codimen++; + if (ar->codimen < corank) + { + gfc_error ("Too few codimensions at %C, expected %d not %d", + corank, ar->codimen); + return MATCH_ERROR; + } return MATCH_YES; } if (gfc_match_char (',') != MATCH_YES) { - gfc_error ("Invalid form of coarray reference at %C"); + if (gfc_match_char ('*') == MATCH_YES) + gfc_error ("Unexpected '*' for codimension %d of %d at %C", + ar->codimen + 1, corank); + else + gfc_error ("Invalid form of coarray reference at %C"); + return MATCH_ERROR; + } + if (ar->codimen >= corank) + { + gfc_error ("Invalid codimension %d at %C, only %d codimensions exist", + ar->codimen + 1, corank); return MATCH_ERROR; } } @@ -1545,7 +1563,7 @@ gfc_get_array_element (gfc_expr *array, int element) constructor if they are small enough. */ gfc_try -gfc_expand_constructor (gfc_expr *e) +gfc_expand_constructor (gfc_expr *e, bool fatal) { expand_info expand_save; gfc_expr *f; @@ -1557,6 +1575,15 @@ gfc_expand_constructor (gfc_expr *e) if (f != NULL) { gfc_free_expr (f); + if (fatal) + { + gfc_error ("The number of elements in the array constructor " + "at %L requires an increase of the allowed %d " + "upper limit. See -fmax-array-constructor " + "option", &e->where, + gfc_option.flag_max_array_constructor); + return FAILURE; + } return SUCCESS; } diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 34527172431..7578775ef42 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -473,12 +473,15 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) if (dim == NULL) return SUCCESS; - if (dim->expr_type != EXPR_CONSTANT - || (array->expr_type != EXPR_VARIABLE - && array->expr_type != EXPR_ARRAY)) + if (dim->expr_type != EXPR_CONSTANT) return SUCCESS; - rank = array->rank; + if (array->expr_type == EXPR_FUNCTION && array->value.function.isym + && array->value.function.isym->id == GFC_ISYM_SPREAD) + rank = array->rank + 1; + else + rank = array->rank; + if (array->expr_type == EXPR_VARIABLE) { ar = gfc_find_array_ref (array); @@ -3043,6 +3046,20 @@ gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED) gfc_try +gfc_check_c_sizeof (gfc_expr *arg) +{ + if (verify_c_interop (&arg->ts) != SUCCESS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an " + "interoperable data entity", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &arg->where); + return FAILURE; + } + return SUCCESS; +} + + +gfc_try gfc_check_sleep_sub (gfc_expr *seconds) { if (type_check (seconds, 0, BT_INTEGER) == FAILURE) @@ -4556,3 +4573,27 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) return SUCCESS; } + + +gfc_try +gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + if (kind == NULL) + return SUCCESS; + + if (type_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (kind, 1) == FAILURE) + return FAILURE; + + if (kind->expr_type != EXPR_CONSTANT) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + &kind->where); + return FAILURE; + } + + return SUCCESS; +} diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 37b9cf01590..b5e17f4e2f6 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -174,7 +174,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.u.derived = NULL; else { - vtab = gfc_find_derived_vtab (ts->u.derived, false); + vtab = gfc_find_derived_vtab (ts->u.derived); gcc_assert (vtab); c->ts.u.derived = vtab->ts.u.derived; } @@ -199,344 +199,126 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, } +/* Add a procedure pointer component to the vtype + to represent a specific type-bound procedure. */ + static void -add_proc_component (gfc_component *c, gfc_symbol *vtype, - gfc_symtree *st, gfc_symbol *specific, - bool is_generic, bool is_generic_specific) +add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) { - /* Add procedure component. */ - if (is_generic) - { - if (gfc_add_component (vtype, specific->name, &c) == FAILURE) - return; - c->ts.interface = specific; - } - else if (c && is_generic_specific) - { - c->ts.interface = st->n.tb->u.specific->n.sym; - } - else + gfc_component *c; + c = gfc_find_component (vtype, name, true, true); + + if (c == NULL) { - c = gfc_find_component (vtype, st->name, true, true); - if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE) + /* Add procedure component. */ + if (gfc_add_component (vtype, name, &c) == FAILURE) return; - c->ts.interface = st->n.tb->u.specific->n.sym; - } - - if (!c->tb) - c->tb = XCNEW (gfc_typebound_proc); - *c->tb = *st->n.tb; - c->tb->ppc = 1; - c->attr.procedure = 1; - c->attr.proc_pointer = 1; - c->attr.flavor = FL_PROCEDURE; - c->attr.access = ACCESS_PRIVATE; - c->attr.external = 1; - c->attr.untyped = 1; - c->attr.if_source = IFSRC_IFBODY; - - /* A static initializer cannot be used here because the specific - function is not a constant; internal compiler error: in - output_constant, at varasm.c:4623 */ - c->initializer = NULL; -} + if (tb->u.specific) + c->ts.interface = tb->u.specific->n.sym; + if (!c->tb) + c->tb = XCNEW (gfc_typebound_proc); + *c->tb = *tb; + c->tb->ppc = 1; + c->attr.procedure = 1; + c->attr.proc_pointer = 1; + c->attr.flavor = FL_PROCEDURE; + c->attr.access = ACCESS_PRIVATE; + c->attr.external = 1; + c->attr.untyped = 1; + c->attr.if_source = IFSRC_IFBODY; -static void -add_proc_comps (gfc_component *c, gfc_symbol *vtype, - gfc_symtree *st, bool is_generic) -{ - if (c == NULL && !is_generic) - { - add_proc_component (c, vtype, st, NULL, false, false); - } - else if (is_generic && st->n.tb && vtype->components == NULL) - { - gfc_tbp_generic* g; - gfc_symbol * specific; - for (g = st->n.tb->u.generic; g; g = g->next) - { - if (!g->specific) - continue; - specific = g->specific->u.specific->n.sym; - add_proc_component (NULL, vtype, st, specific, true, false); - } + /* A static initializer cannot be used here because the specific + function is not a constant; internal compiler error: in + output_constant, at varasm.c:4623 */ + c->initializer = NULL; } else if (c->attr.proc_pointer && c->tb) { - *c->tb = *st->n.tb; + *c->tb = *tb; c->tb->ppc = 1; - c->ts.interface = st->n.tb->u.specific->n.sym; + c->ts.interface = tb->u.specific->n.sym; } } + +/* Add all specific type-bound procedures in the symtree 'st' to a vtype. */ + static void -add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype, - bool resolved) +add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) { - gfc_component *c; - gfc_symbol *generic; - char name[3 * GFC_MAX_SYMBOL_LEN + 10]; - if (!st) return; if (st->left) - add_procs_to_declared_vtab1 (st->left, vtype, resolved); + add_procs_to_declared_vtab1 (st->left, vtype); if (st->right) - add_procs_to_declared_vtab1 (st->right, vtype, resolved); + add_procs_to_declared_vtab1 (st->right, vtype); if (!st->n.tb) return; if (!st->n.tb->is_generic && st->n.tb->u.specific) - { - c = gfc_find_component (vtype, st->name, true, true); - add_proc_comps (c, vtype, st, false); - } - else if (st->n.tb->is_generic) - { - c = gfc_find_component (vtype, st->name, true, true); - - if (c == NULL) - { - /* Add derived type component with generic name. */ - if (gfc_add_component (vtype, st->name, &c) == FAILURE) - return; - c->ts.type = BT_DERIVED; - c->attr.flavor = FL_VARIABLE; - c->attr.pointer = 1; - - /* Add a special empty derived type as a placeholder. */ - sprintf (name, "$empty"); - gfc_find_symbol (name, vtype->ns, 0, &generic); - if (generic == NULL) - { - gfc_get_symbol (name, vtype->ns, &generic); - generic->attr.flavor = FL_DERIVED; - generic->refs++; - gfc_set_sym_referenced (generic); - generic->ts.type = BT_UNKNOWN; - generic->attr.zero_comp = 1; - } - - c->ts.u.derived = generic; - } - } + add_proc_comp (vtype, st->name, st->n.tb); } +/* Copy procedure pointers components from the parent type. */ + static void -copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype, - bool resolved) +copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) { - gfc_component *c, *cmp; + gfc_component *cmp; gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared, resolved); + vtab = gfc_find_derived_vtab (declared); for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) { if (gfc_find_component (vtype, cmp->name, true, true)) continue; - if (gfc_add_component (vtype, cmp->name, &c) == FAILURE) - return; - - if (cmp->ts.type == BT_DERIVED) - { - c->ts = cmp->ts; - c->ts.u.derived = cmp->ts.u.derived; - c->attr.flavor = FL_VARIABLE; - c->attr.pointer = 1; - c->initializer = NULL; - continue; - } - - c->tb = XCNEW (gfc_typebound_proc); - *c->tb = *cmp->tb; - c->attr.procedure = 1; - c->attr.proc_pointer = 1; - c->attr.flavor = FL_PROCEDURE; - c->attr.access = ACCESS_PRIVATE; - c->attr.external = 1; - c->ts.interface = cmp->ts.interface; - c->attr.untyped = 1; - c->attr.if_source = IFSRC_IFBODY; - c->initializer = NULL; + add_proc_comp (vtype, cmp->name, cmp->tb); } } -static void -add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype, - gfc_symbol *derived, bool resolved) -{ - gfc_symbol* super_type; - - super_type = gfc_get_derived_super_type (declared); - - if (super_type && (super_type != declared)) - add_procs_to_declared_vtab (super_type, vtype, derived, resolved); - - if (declared != derived) - copy_vtab_proc_comps (declared, vtype, resolved); - - if (declared->f2k_derived && declared->f2k_derived->tb_sym_root) - add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root, - vtype, resolved); - - if (declared->f2k_derived && declared->f2k_derived->tb_uop_root) - add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root, - vtype, resolved); -} - - -static -void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab, - const char *name) -{ - gfc_tbp_generic* g; - gfc_symbol * specific1; - gfc_symbol * specific2; - gfc_symtree *st = NULL; - gfc_component *c; - - /* Find the generic procedure using the component name. */ - st = gfc_find_typebound_proc (declared, NULL, name, true, NULL); - if (st == NULL) - st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL); - - if (st == NULL) - return; - - /* Add procedure pointer components for the specific procedures. */ - for (g = st->n.tb->u.generic; g; g = g->next) - { - if (!g->specific) - continue; - specific1 = g->specific_st->n.tb->u.specific->n.sym; - - c = vtab->ts.u.derived->components; - specific2 = NULL; - - /* Override identical specific interface. */ - if (vtab->ts.u.derived->components) - { - for (; c; c= c->next) - { - specific2 = c->ts.interface; - if (gfc_compare_interfaces (specific2, specific1, - specific1->name, 0, 0, NULL, 0)) - break; - } - } - - add_proc_component (c, vtab->ts.u.derived, g->specific_st, - NULL, false, true); - vtab->ts.u.derived->attr.zero_comp = 0; - } -} +/* Add procedure pointers for all type-bound procedures to a vtab. */ static void -add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype, - gfc_symbol *derived, bool resolved) +add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) { - gfc_component *cmp; - gfc_symtree *st = NULL; - gfc_symbol * vtab; - char name[2 * GFC_MAX_SYMBOL_LEN + 8]; gfc_symbol* super_type; - gcc_assert (resolved); + super_type = gfc_get_derived_super_type (derived); - for (cmp = vtype->components; cmp; cmp = cmp->next) + if (super_type && (super_type != derived)) { - if (cmp->ts.type != BT_DERIVED) - continue; - - /* The only derived type that does not represent a generic - procedure is the pointer to the parent vtab. */ - if (cmp->ts.u.derived - && strcmp (cmp->ts.u.derived->name, "$extends") == 0) - continue; - - /* Find the generic procedure using the component name. */ - st = gfc_find_typebound_proc (declared, NULL, cmp->name, - true, NULL); - if (st == NULL) - st = gfc_find_typebound_user_op (declared, NULL, cmp->name, - true, NULL); - - /* Should be an error but we pass on it for now. */ - if (st == NULL || !st->n.tb->is_generic) - continue; - - vtab = NULL; - - /* Build a vtab and a special vtype, with only the procedure - pointer fields, to carry the pointers to the specific - procedures. Should this name ever be changed, the same - should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */ - sprintf (name, "vtab$%s$%s", vtype->name, cmp->name); - gfc_find_symbol (name, derived->ns, 0, &vtab); - if (vtab == NULL) - { - gfc_get_symbol (name, derived->ns, &vtab); - vtab->ts.type = BT_DERIVED; - vtab->attr.flavor = FL_VARIABLE; - vtab->attr.target = 1; - vtab->attr.save = SAVE_EXPLICIT; - vtab->attr.vtab = 1; - vtab->refs++; - gfc_set_sym_referenced (vtab); - sprintf (name, "%s$%s", vtype->name, cmp->name); - - gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived); - if (cmp->ts.u.derived == NULL - || (strcmp (cmp->ts.u.derived->name, "$empty") == 0)) - { - gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived); - if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED, - NULL, &gfc_current_locus) == FAILURE) - return; - cmp->ts.u.derived->refs++; - gfc_set_sym_referenced (cmp->ts.u.derived); - cmp->ts.u.derived->attr.vtype = 1; - cmp->ts.u.derived->attr.zero_comp = 1; - } - vtab->ts.u.derived = cmp->ts.u.derived; - } - - /* Store this for later use in setting the pointer. */ - cmp->ts.interface = vtab; - - if (vtab->ts.u.derived->components) - continue; - - super_type = gfc_get_derived_super_type (declared); + /* Make sure that the PPCs appear in the same order as in the parent. */ + copy_vtab_proc_comps (super_type, vtype); + /* Only needed to get the PPC interfaces right. */ + add_procs_to_declared_vtab (super_type, vtype); + } - if (super_type && (super_type != declared)) - add_generic_specifics (super_type, vtab, cmp->name); + if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) + add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); - add_generic_specifics (declared, vtab, cmp->name); - } + if (derived->f2k_derived && derived->f2k_derived->tb_uop_root) + add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype); } -/* Find the symbol for a derived type's vtab. A vtab has the following - fields: - $hash a hash value used to identify the derived type - $size the size in bytes of the derived type - $extends a pointer to the vtable of the parent derived type - then: - procedure pointer components for the specific typebound procedures - structure pointers to reduced vtabs that contain procedure - pointers to the specific procedures. */ +/* Find the symbol for a derived type's vtab. + A vtab has the following fields: + * $hash a hash value used to identify the derived type + * $size the size in bytes of the derived type + * $extends a pointer to the vtable of the parent derived type + After these follow procedure pointer components for the + specific type-bound procedures. */ gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) +gfc_find_derived_vtab (gfc_symbol *derived) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL; @@ -608,7 +390,7 @@ gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) parent = gfc_get_derived_super_type (derived); if (parent) { - parent_vtab = gfc_find_derived_vtab (parent, resolved); + parent_vtab = gfc_find_derived_vtab (parent); c->ts.type = BT_DERIVED; c->ts.u.derived = parent_vtab->ts.u.derived; c->initializer = gfc_get_expr (); @@ -623,7 +405,7 @@ gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) c->initializer = gfc_get_null_expr (NULL); } - add_procs_to_declared_vtab (derived, vtype, derived, resolved); + add_procs_to_declared_vtab (derived, vtype); vtype->attr.vtype = 1; } @@ -632,15 +414,6 @@ gfc_find_derived_vtab (gfc_symbol *derived, bool resolved) } } - /* Catch the call just before the backend declarations are built, so that - the generic procedures have been resolved and the specific procedures - have formal interfaces that can be compared. */ - if (resolved - && vtab->ts.u.derived - && vtab->ts.u.derived->backend_decl == NULL) - add_generics_to_declared_vtab (derived, vtab->ts.u.derived, - derived, resolved); - return vtab; } diff --git a/gcc/fortran/config-lang.in b/gcc/fortran/config-lang.in index 030b0f67de0..b7ace71fee4 100644 --- a/gcc/fortran/config-lang.in +++ b/gcc/fortran/config-lang.in @@ -29,5 +29,5 @@ compilers="f951\$(exeext)" target_libs=target-libgfortran -gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h" +gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-stmt.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h" diff --git a/gcc/fortran/convert.c b/gcc/fortran/convert.c index f69ea2386ef..50e3a6a10f1 100644 --- a/gcc/fortran/convert.c +++ b/gcc/fortran/convert.c @@ -40,7 +40,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "flags.h" #include "convert.h" -#include "toplev.h" /* For error. */ +#include "diagnostic-core.h" /* For error. */ #include "gfortran.h" #include "trans.h" diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 07c3acb9467..9515676acc9 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1155,13 +1155,10 @@ build_sym (const char *name, gfc_charlen *cl, sym->attr.implied_index = 0; - if (sym->ts.type == BT_CLASS) - { - sym->attr.class_ok = (sym->attr.dummy - || sym->attr.pointer - || sym->attr.allocatable) ? 1 : 0; - gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false); - } + if (sym->ts.type == BT_CLASS + && (sym->attr.class_ok = sym->attr.dummy || sym->attr.pointer + || sym->attr.allocatable)) + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false); return SUCCESS; } @@ -5874,7 +5871,7 @@ attr_decl1 (void) /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). For CLASS variables, this must be applied to the first component, or '$data' field. */ - if (sym->ts.type == BT_CLASS) + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class) { if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr,&var_locus) == FAILURE) @@ -5882,8 +5879,6 @@ attr_decl1 (void) m = MATCH_ERROR; goto cleanup; } - sym->attr.class_ok = (sym->attr.class_ok || current_attr.allocatable - || current_attr.pointer); } else { @@ -5894,6 +5889,11 @@ attr_decl1 (void) goto cleanup; } } + + if (sym->ts.type == BT_CLASS && !sym->attr.class_ok + && (sym->attr.class_ok = sym->attr.class_ok || current_attr.allocatable + || current_attr.pointer)) + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false); if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE) { @@ -7697,8 +7697,8 @@ match_procedure_in_type (void) } /* Construct the data structure. */ + memset (&tb, 0, sizeof (tb)); tb.where = gfc_current_locus; - tb.is_generic = 0; /* Match binding attributes. */ m = match_binding_attributes (&tb, false, false); @@ -7856,6 +7856,9 @@ gfc_match_generic (void) ns = block->f2k_derived; gcc_assert (block && ns); + memset (&tbattr, 0, sizeof (tbattr)); + tbattr.where = gfc_current_locus; + /* See if we get an access-specifier. */ m = match_binding_attributes (&tbattr, true, false); if (m == MATCH_ERROR) diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index fcf5b25d350..9dd4d9c4672 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -39,7 +39,8 @@ typedef enum { GFC_DEP_ERROR, GFC_DEP_EQUAL, /* Identical Ranges. */ - GFC_DEP_FORWARD, /* e.g., a(1:3), a(2:4). */ + GFC_DEP_FORWARD, /* e.g., a(1:3) = a(2:4). */ + GFC_DEP_BACKWARD, /* e.g. a(2:4) = a(1:3). */ GFC_DEP_OVERLAP, /* May overlap in some other way. */ GFC_DEP_NODEP /* Distinct ranges. */ } @@ -424,7 +425,7 @@ gfc_ref_needs_temporary_p (gfc_ref *ref) } -int +static int gfc_is_data_pointer (gfc_expr *e) { gfc_ref *ref; @@ -807,6 +808,19 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) return 1; } + else + { + gfc_symbol *sym1 = expr1->symtree->n.sym; + gfc_symbol *sym2 = expr2->symtree->n.sym; + if (sym1->attr.target && sym2->attr.target + && ((sym1->attr.dummy && !sym1->attr.contiguous + && (!sym1->attr.dimension + || sym2->as->type == AS_ASSUMED_SHAPE)) + || (sym2->attr.dummy && !sym2->attr.contiguous + && (!sym2->attr.dimension + || sym2->as->type == AS_ASSUMED_SHAPE)))) + return 1; + } /* Otherwise distinct symbols have no dependencies. */ return 0; @@ -818,7 +832,7 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) /* Identical and disjoint ranges return 0, overlapping ranges return 1. */ if (expr1->ref && expr2->ref) - return gfc_dep_resolver (expr1->ref, expr2->ref); + return gfc_dep_resolver (expr1->ref, expr2->ref, NULL); return 1; @@ -1061,6 +1075,30 @@ gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n) return GFC_DEP_FORWARD; } + /* Check for backward dependencies: + Are the strides the same?. */ + if ((!l_stride && !r_stride) + || + (l_stride && r_stride + && gfc_dep_compare_expr (l_stride, r_stride) == 0)) + { + /* x:y vs. x+1:z. */ + if (l_dir == 1 && r_dir == 1 + && l_start && r_start + && gfc_dep_compare_expr (l_start, r_start) == 1 + && l_end && r_end + && gfc_dep_compare_expr (l_end, r_end) == 1) + return GFC_DEP_BACKWARD; + + /* x:y:-1 vs. x-1:z:-1. */ + if (l_dir == -1 && r_dir == -1 + && l_start && r_start + && gfc_dep_compare_expr (l_start, r_start) == -1 + && l_end && r_end + && gfc_dep_compare_expr (l_end, r_end) == -1) + return GFC_DEP_BACKWARD; + } + return GFC_DEP_OVERLAP; } @@ -1468,16 +1506,19 @@ ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) /* Finds if two array references are overlapping or not. Return value + 2 : array references are overlapping but reversal of one or + more dimensions will clear the dependency. 1 : array references are overlapping. 0 : array references are identical or not overlapping. */ int -gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref) +gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse) { int n; gfc_dependency fin_dep; gfc_dependency this_dep; + this_dep = GFC_DEP_ERROR; fin_dep = GFC_DEP_ERROR; /* Dependencies due to pointers should already have been identified. We only need to check for overlapping array references. */ @@ -1530,6 +1571,7 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref) if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR || rref->u.ar.dimen_type[n] == DIMEN_VECTOR) return 1; + if (lref->u.ar.dimen_type[n] == DIMEN_RANGE && rref->u.ar.dimen_type[n] == DIMEN_RANGE) this_dep = gfc_check_section_vs_section (lref, rref, n); @@ -1550,6 +1592,38 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref) if (this_dep == GFC_DEP_NODEP) return 0; + /* Now deal with the loop reversal logic: This only works on + ranges and is activated by setting + reverse[n] == GFC_CAN_REVERSE + The ability to reverse or not is set by previous conditions + in this dimension. If reversal is not activated, the + value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */ + if (rref->u.ar.dimen_type[n] == DIMEN_RANGE + && lref->u.ar.dimen_type[n] == DIMEN_RANGE) + { + /* Set reverse if backward dependence and not inhibited. */ + if (reverse && reverse[n] != GFC_CANNOT_REVERSE) + reverse[n] = (this_dep == GFC_DEP_BACKWARD) ? + GFC_REVERSE_SET : reverse[n]; + + /* Inhibit loop reversal if dependence not compatible. */ + if (reverse && reverse[n] != GFC_REVERSE_NOT_SET + && this_dep != GFC_DEP_EQUAL + && this_dep != GFC_DEP_BACKWARD + && this_dep != GFC_DEP_NODEP) + { + reverse[n] = GFC_CANNOT_REVERSE; + if (this_dep != GFC_DEP_FORWARD) + this_dep = GFC_DEP_OVERLAP; + } + + /* If no intention of reversing or reversing is explicitly + inhibited, convert backward dependence to overlap. */ + if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD) + || (reverse && reverse[n] == GFC_CANNOT_REVERSE)) + this_dep = GFC_DEP_OVERLAP; + } + /* Overlap codes are in order of priority. We only need to know the worst one.*/ if (this_dep > fin_dep) @@ -1565,7 +1639,7 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref) /* Exactly matching and forward overlapping ranges don't cause a dependency. */ - if (fin_dep < GFC_DEP_OVERLAP) + if (fin_dep < GFC_DEP_BACKWARD) return 0; /* Keep checking. We only have a dependency if diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index dd786bedaba..bac2749093b 100644 --- a/gcc/fortran/dependency.h +++ b/gcc/fortran/dependency.h @@ -29,7 +29,6 @@ typedef enum } gfc_dep_check; - /*********************** Functions prototypes **************************/ bool gfc_ref_needs_temporary_p (gfc_ref *); @@ -41,6 +40,6 @@ int gfc_check_dependency (gfc_expr *, gfc_expr *, bool); int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int); int gfc_expr_is_one (gfc_expr *, int); -int gfc_dep_resolver(gfc_ref *, gfc_ref *); +int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *); int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index c876fdd7740..cb7305ecf5a 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -215,7 +215,7 @@ gfc_get_int_expr (int kind, locus *where, int value) p = gfc_get_constant_expr (BT_INTEGER, kind, where ? where : &gfc_current_locus); - mpz_init_set_si (p->value.integer, value); + mpz_set_si (p->value.integer, value); return p; } @@ -1894,7 +1894,7 @@ gfc_simplify_expr (gfc_expr *p, int type) if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY && p->ref->u.ar.type == AR_FULL) - gfc_expand_constructor (p); + gfc_expand_constructor (p, false); if (simplify_const_ref (p) == FAILURE) return FAILURE; @@ -2573,7 +2573,7 @@ check_init_expr (gfc_expr *e) if (t == FAILURE) break; - t = gfc_expand_constructor (e); + t = gfc_expand_constructor (e, true); if (t == FAILURE) break; @@ -2609,7 +2609,7 @@ gfc_reduce_init_expr (gfc_expr *expr) { if (gfc_check_constructor_type (expr) == FAILURE) return FAILURE; - if (gfc_expand_constructor (expr) == FAILURE) + if (gfc_expand_constructor (expr, true) == FAILURE) return FAILURE; } @@ -3306,7 +3306,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } if (!pointer && !proc_pointer - && !(lvalue->ts.type == BT_CLASS && CLASS_DATA (lvalue)->attr.pointer)) + && !(lvalue->ts.type == BT_CLASS + && CLASS_DATA (lvalue)->attr.class_pointer)) { gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); return FAILURE; @@ -3543,7 +3544,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) lvalue.where = sym->declared_at; if (sym->attr.pointer || sym->attr.proc_pointer - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.pointer + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer && rvalue->expr_type == EXPR_NULL)) r = gfc_check_pointer_assign (&lvalue, rvalue); else @@ -4022,6 +4023,22 @@ gfc_is_coindexed (gfc_expr *e) } +bool +gfc_get_corank (gfc_expr *e) +{ + int corank; + gfc_ref *ref; + corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + corank = ref->u.ar.as->corank; + gcc_assert (ref->type != REF_SUBSTRING); + } + return corank; +} + + /* Check whether the expression has an ultimate allocatable component. Being itself allocatable does not count. */ bool diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index c6af0026ba8..5b676214e6a 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -310,7 +310,7 @@ struct GTY(()) binding_level { /* A chain of ..._DECL nodes for all variables, constants, functions, parameters and type declarations. These ..._DECL nodes are chained - through the TREE_CHAIN field. Note that these ..._DECL nodes are stored + through the DECL_CHAIN field. Note that these ..._DECL nodes are stored in the reverse of the order supplied to be compatible with the back-end. */ tree names; @@ -409,7 +409,7 @@ poplevel (int keep, int reverse, int functionbody) /* Clear out the meanings of the local variables of this level. */ for (subblock_node = decl_chain; subblock_node; - subblock_node = TREE_CHAIN (subblock_node)) + subblock_node = DECL_CHAIN (subblock_node)) if (DECL_NAME (subblock_node) != 0) /* If the identifier was used or addressed via a local extern decl, don't forget that fact. */ @@ -467,7 +467,7 @@ pushdecl (tree decl) order. The list will be reversed later if necessary. This needs to be this way for compatibility with the back-end. */ - TREE_CHAIN (decl) = current_binding_level->names; + DECL_CHAIN (decl) = current_binding_level->names; current_binding_level->names = decl; /* For the declaration of a type, set its name if it is not already set. */ diff --git a/gcc/fortran/gfc-internals.texi b/gcc/fortran/gfc-internals.texi index 90f90fdac5d..ed4c5ed3d66 100644 --- a/gcc/fortran/gfc-internals.texi +++ b/gcc/fortran/gfc-internals.texi @@ -406,6 +406,33 @@ case-block, and @code{extx.case_list} contains the case-values this block corresponds to. The @code{block} member links to the next case in the list. +@subsection @code{BLOCK} and @code{ASSOCIATE} + +The code related to a @code{BLOCK} statement is stored inside an +@code{gfc_code} structure (say @var{c}) +with @code{c.op} set to @code{EXEC_BLOCK}. The +@code{gfc_namespace} holding the locally defined variables of the +@code{BLOCK} is stored in @code{c.ext.block.ns}. The code inside the +construct is in @code{c.code}. + +@code{ASSOCIATE} constructs are based on @code{BLOCK} and thus also have +the internal storage structure described above (including @code{EXEC_BLOCK}). +However, for them @code{c.ext.block.assoc} is set additionally and points +to a linked list of @code{gfc_association_list} structures. Those +structures basically store a link of associate-names to target expressions. +The associate-names themselves are still also added to the @code{BLOCK}'s +namespace as ordinary symbols, but they have their @code{gfc_symbol}'s +member @code{assoc} set also pointing to the association-list structure. +This way associate-names can be distinguished from ordinary variables +and their target expressions identified. + +For association to expressions (as opposed to variables), at the very beginning +of the @code{BLOCK} construct assignments are automatically generated to +set the corresponding variables to their target expressions' values, and +later on the compiler simply disallows using such associate-names in contexts +that may change the value. + + @c gfc_expr @c -------- diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 0c96bf40e6e..a493866ab36 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -348,6 +348,7 @@ enum gfc_isym_id GFC_ISYM_CPU_TIME, GFC_ISYM_CSHIFT, GFC_ISYM_CTIME, + GFC_ISYM_C_SIZEOF, GFC_ISYM_DATE_AND_TIME, GFC_ISYM_DBLE, GFC_ISYM_DIGITS, @@ -504,6 +505,7 @@ enum gfc_isym_id GFC_ISYM_SRAND, GFC_ISYM_SR_KIND, GFC_ISYM_STAT, + GFC_ISYM_STORAGE_SIZE, GFC_ISYM_SUM, GFC_ISYM_SYMLINK, GFC_ISYM_SYMLNK, @@ -574,6 +576,15 @@ typedef enum } gfc_fcoarray; +typedef enum +{ + GFC_REVERSE_NOT_SET, + GFC_REVERSE_SET, + GFC_CAN_REVERSE, + GFC_CANNOT_REVERSE +} +gfc_reverse; + /************************* Structures *****************************/ /* Used for keeping things in balanced binary trees. */ @@ -680,7 +691,8 @@ typedef struct use_assoc:1, /* Symbol has been use-associated. */ use_only:1, /* Symbol has been use-associated, with ONLY. */ use_rename:1, /* Symbol has been use-associated and renamed. */ - imported:1; /* Symbol has been associated by IMPORT. */ + imported:1, /* Symbol has been associated by IMPORT. */ + host_assoc:1; /* Symbol has been host associated. */ unsigned in_namelist:1, in_common:1, in_equivalence:1; unsigned function:1, subroutine:1, procedure:1; @@ -2509,6 +2521,7 @@ gfc_user_op *gfc_get_uop (const char *); gfc_user_op *gfc_find_uop (const char *, gfc_namespace *); void gfc_free_symbol (gfc_symbol *); gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *); +gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *); int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **); int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **); int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **); @@ -2670,6 +2683,7 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *); bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **); bool gfc_is_coindexed (gfc_expr *); +bool gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); bool gfc_has_ultimate_pointer (gfc_expr *); @@ -2715,7 +2729,7 @@ gfc_try gfc_resolve_array_spec (gfc_array_spec *, int); int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *); void gfc_simplify_iterator_var (gfc_expr *); -gfc_try gfc_expand_constructor (gfc_expr *); +gfc_try gfc_expand_constructor (gfc_expr *, bool); int gfc_constant_ac (gfc_expr *); int gfc_expanded_ac (gfc_expr *); gfc_try gfc_resolve_character_array_constructor (gfc_expr *); @@ -2806,7 +2820,6 @@ void gfc_global_used (gfc_gsymbol *, locus *); /* dependency.c */ int gfc_dep_compare_expr (gfc_expr *, gfc_expr *); -int gfc_is_data_pointer (gfc_expr *); /* check.c */ gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*); @@ -2816,7 +2829,7 @@ void gfc_add_component_ref (gfc_expr *, const char *); gfc_expr *gfc_class_null_initializer (gfc_typespec *); gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **, bool); -gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool); +gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool, locus*); gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 587b09cdf8c..201961d6355 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2779,12 +2779,14 @@ gfc_find_sym_in_symtree (gfc_symbol *sym) /* See if the arglist to an operator-call contains a derived-type argument with a matching type-bound operator. If so, return the matching specific procedure defined as operator-target as well as the base-object to use - (which is the found derived-type argument with operator). */ + (which is the found derived-type argument with operator). The generic + name, if any, is transmitted to the final expression via 'gname'. */ static gfc_typebound_proc* matching_typebound_op (gfc_expr** tb_base, gfc_actual_arglist* args, - gfc_intrinsic_op op, const char* uop) + gfc_intrinsic_op op, const char* uop, + const char ** gname) { gfc_actual_arglist* base; @@ -2850,6 +2852,7 @@ matching_typebound_op (gfc_expr** tb_base, if (matches) { *tb_base = base->expr; + *gname = g->specific_st->name; return g->specific; } } @@ -2868,11 +2871,12 @@ matching_typebound_op (gfc_expr** tb_base, static void build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual, - gfc_expr* base, gfc_typebound_proc* target) + gfc_expr* base, gfc_typebound_proc* target, + const char *gname) { e->expr_type = EXPR_COMPCALL; e->value.compcall.tbp = target; - e->value.compcall.name = "operator"; /* Should not matter. */ + e->value.compcall.name = gname ? gname : "$op"; e->value.compcall.actual = actual; e->value.compcall.base_object = base; e->value.compcall.ignore_pass = 1; @@ -2898,6 +2902,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error) gfc_namespace *ns; gfc_user_op *uop; gfc_intrinsic_op i; + const char *gname; sym = NULL; @@ -2905,6 +2910,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error) actual->expr = e->value.op.op1; *real_error = false; + gname = NULL; if (e->value.op.op2 != NULL) { @@ -2970,7 +2976,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error) /* See if we find a matching type-bound operator. */ if (i == INTRINSIC_USER) tbo = matching_typebound_op (&tb_base, actual, - i, e->value.op.uop->name); + i, e->value.op.uop->name, &gname); else switch (i) { @@ -2978,10 +2984,10 @@ gfc_extend_expr (gfc_expr *e, bool *real_error) case INTRINSIC_##comp: \ case INTRINSIC_##comp##_OS: \ tbo = matching_typebound_op (&tb_base, actual, \ - INTRINSIC_##comp, NULL); \ + INTRINSIC_##comp, NULL, &gname); \ if (!tbo) \ tbo = matching_typebound_op (&tb_base, actual, \ - INTRINSIC_##comp##_OS, NULL); \ + INTRINSIC_##comp##_OS, NULL, &gname); \ break; CHECK_OS_COMPARISON(EQ) CHECK_OS_COMPARISON(NE) @@ -2992,7 +2998,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error) #undef CHECK_OS_COMPARISON default: - tbo = matching_typebound_op (&tb_base, actual, i, NULL); + tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); break; } @@ -3003,7 +3009,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error) gfc_try result; gcc_assert (tb_base); - build_compcall_for_operator (e, actual, tb_base, tbo); + build_compcall_for_operator (e, actual, tb_base, tbo, gname); result = gfc_resolve_expr (e); if (result == FAILURE) @@ -3050,6 +3056,9 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) gfc_actual_arglist *actual; gfc_expr *lhs, *rhs; gfc_symbol *sym; + const char *gname; + + gname = NULL; lhs = c->expr1; rhs = c->expr2; @@ -3085,7 +3094,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) /* See if we find a matching type-bound assignment. */ tbo = matching_typebound_op (&tb_base, actual, - INTRINSIC_ASSIGN, NULL); + INTRINSIC_ASSIGN, NULL, &gname); /* If there is one, replace the expression with a call to it and succeed. */ @@ -3093,7 +3102,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) { gcc_assert (tb_base); c->expr1 = gfc_get_expr (); - build_compcall_for_operator (c->expr1, actual, tb_base, tbo); + build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); c->expr1->value.compcall.assign = 1; c->expr2 = NULL; c->op = EXEC_COMPCALL; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 833fd30beb1..87d9c800df0 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2459,7 +2459,10 @@ add_functions (void) x, BT_UNKNOWN, 0, REQUIRED); make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU); - make_alias ("c_sizeof", GFC_STD_F2008); + + add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL, + x, BT_UNKNOWN, 0, REQUIRED); add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing, @@ -2500,6 +2503,12 @@ add_functions (void) make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU); + add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_storage_size, NULL, gfc_resolve_storage_size, + a, BT_UNKNOWN, 0, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); + add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 919f09e90b4..f5da7a0649c 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -133,10 +133,12 @@ gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_sign (gfc_expr *, gfc_expr *); gfc_try gfc_check_signal (gfc_expr *, gfc_expr *); gfc_try gfc_check_sizeof (gfc_expr *); +gfc_try gfc_check_c_sizeof (gfc_expr *); gfc_try gfc_check_sngl (gfc_expr *); gfc_try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_srand (gfc_expr *); gfc_try gfc_check_stat (gfc_expr *, gfc_expr *); +gfc_try gfc_check_storage_size (gfc_expr *, gfc_expr *); gfc_try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_symlnk (gfc_expr *, gfc_expr *); gfc_try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *); @@ -494,6 +496,7 @@ void gfc_resolve_spacing (gfc_expr *, gfc_expr *); void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_sqrt (gfc_expr *, gfc_expr *); void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a, gfc_expr *kind); void gfc_resolve_srand (gfc_code *); void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 06c6793b2c4..2e91a3eb37a 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -107,6 +107,7 @@ Some basic guidelines for editing this document: * @code{EXIT}: EXIT, Exit the program with status. * @code{EXP}: EXP, Exponential function * @code{EXPONENT}: EXPONENT, Exponent function +* @code{EXTENDS_TYPE_OF}: EXTENDS_TYPE_OF, Query dynamic type for extension * @code{FDATE}: FDATE, Subroutine (or function) to get the current time as a string * @code{FGET}: FGET, Read a single character in stream mode from stdin * @code{FGETC}: FGETC, Read a single character in stream mode @@ -223,6 +224,7 @@ Some basic guidelines for editing this document: * @code{RESHAPE}: RESHAPE, Function to reshape an array * @code{RRSPACING}: RRSPACING, Reciprocal of the relative spacing * @code{RSHIFT}: RSHIFT, Right shift bits +* @code{SAME_TYPE_AS}: SAME_TYPE_AS, Query dynamic types for equality * @code{SCALE}: SCALE, Scale a real value * @code{SCAN}: SCAN, Scan a string for the presence of a set of characters * @code{SECNDS}: SECNDS, Time function @@ -244,6 +246,7 @@ Some basic guidelines for editing this document: * @code{SQRT}: SQRT, Square-root function * @code{SRAND}: SRAND, Reinitialize the random number generator * @code{STAT}: STAT, Get file status +* @code{STORAGE_SIZE}: STORAGE_SIZE, Storage size in bits * @code{SUM}: SUM, Sum of array elements * @code{SYMLNK}: SYMLNK, Create a symbolic link * @code{SYSTEM}: SYSTEM, Execute a shell command @@ -2139,9 +2142,9 @@ Inquiry function @code{RESULT = C_LOC(X)} @item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{X} @tab Associated scalar pointer or interoperable scalar -or allocated allocatable variable with @code{TARGET} attribute. +@multitable @columnfractions .10 .75 +@item @var{X} @tab Shall have either the POINTER or TARGET attribute. It shall not be a coindexed object. It shall either be a variable with interoperable type and kind type parameters, or be a scalar, nonpolymorphic variable with no length type parameters. + @end multitable @item @emph{Return value}: @@ -2187,7 +2190,7 @@ Intrinsic function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{X} @tab The argument shall be of any type, rank or shape. +@item @var{X} @tab The argument shall be an interoperable data entity. @end multitable @item @emph{Return value}: @@ -2211,7 +2214,7 @@ The example will print @code{.TRUE.} unless you are using a platform where default @code{REAL} variables are unusually padded. @item @emph{See also}: -@ref{SIZEOF} +@ref{SIZEOF}, @ref{STORAGE_SIZE} @end table @@ -3927,6 +3930,42 @@ end program test_exponent +@node EXTENDS_TYPE_OF +@section @code{EXTENDS_TYPE_OF} --- Query dynamic type for extension +@fnindex EXTENDS_TYPE_OF + +@table @asis +@item @emph{Description}: +Query dynamic type for extension. + +@item @emph{Standard}: +Fortran 2003 and later + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = EXTENDS_TYPE_OF(A, MOLD)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{A} @tab Shall be an object of extensible declared type or +unlimited polymorphic. +@item @var{MOLD} @tab Shall be an object of extensible declared type or +unlimited polymorphic. +@end multitable + +@item @emph{Return value}: +The return value is a scalar of type default logical. It is true if and only if +the dynamic type of A is an extension type of the dynamic type of MOLD. + + +@item @emph{See also}: +@ref{SAME_TYPE_AS} +@end table + + + @node FDATE @section @code{FDATE} --- Get the current time as a string @fnindex FDATE @@ -9405,6 +9444,42 @@ The return value is of type @code{INTEGER} and of the same kind as +@node SAME_TYPE_AS +@section @code{SAME_TYPE_AS} --- Query dynamic types for equality +@fnindex SAME_TYPE_AS + +@table @asis +@item @emph{Description}: +Query dynamic types for equality. + +@item @emph{Standard}: +Fortran 2003 and later + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = SAME_TYPE_AS(A, B)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{A} @tab Shall be an object of extensible declared type or +unlimited polymorphic. +@item @var{B} @tab Shall be an object of extensible declared type or +unlimited polymorphic. +@end multitable + +@item @emph{Return value}: +The return value is a scalar of type default logical. It is true if and +only if the dynamic type of A is the same as the dynamic type of B. + +@item @emph{See also}: +@ref{EXTENDS_TYPE_OF} + +@end table + + + @node SCALE @section @code{SCALE} --- Scale a real value @fnindex SCALE @@ -10146,7 +10221,8 @@ number of bytes occupied by the argument. If the argument has the @code{POINTER} attribute, the number of bytes of the storage area pointed to is returned. If the argument is of a derived type with @code{POINTER} or @code{ALLOCATABLE} components, the return value doesn't account for -the sizes of the data pointed to by these components. +the sizes of the data pointed to by these components. If the argument is +polymorphic, the size according to the declared type is returned. @item @emph{Example}: @smallexample @@ -10159,7 +10235,7 @@ The example will print @code{.TRUE.} unless you are using a platform where default @code{REAL} variables are unusually padded. @item @emph{See also}: -@ref{C_SIZEOF} +@ref{C_SIZEOF}, @ref{STORAGE_SIZE} @end table @@ -10478,6 +10554,37 @@ To stat an open file: @ref{FSTAT}, to stat a link: @ref{LSTAT} +@node STORAGE_SIZE +@section @code{STORAGE_SIZE} --- Storage size in bits +@fnindex STORAGE_SIZE +@cindex storage size + +@table @asis +@item @emph{Description}: +Returns the storage size of argument @var{A} in bits. +@item @emph{Standard}: +Fortran 2008 and later +@item @emph{Class}: +Inquiry function +@item @emph{Syntax}: +@code{RESULT = STORAGE_SIZE(A [, KIND])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{A} @tab Shall be a scalar or array of any type. +@item @var{KIND} @tab (Optional) shall be a scalar integer constant expression. +@end multitable + +@item @emph{Return Value}: +The result is a scalar integer with the kind type parameter specified by KIND (or default integer type if KIND is missing). The result value is the size expressed in bits for an element of an array that +has the dynamic type and type parameters of A. + +@item @emph{See also}: +@ref{C_SIZEOF}, @ref{SIZEOF} +@end table + + + @node SUM @section @code{SUM} --- Sum of array elements @fnindex SUM @@ -10519,7 +10626,7 @@ The result is of the same type as @var{ARRAY}. If @var{DIM} is absent, a scalar with the sum of all elements in @var{ARRAY} is returned. Otherwise, an array of rank n-1, where n equals the rank of -@var{ARRAY},and a shape similar to that of @var{ARRAY} with dimension @var{DIM} +@var{ARRAY}, and a shape similar to that of @var{ARRAY} with dimension @var{DIM} dropped is returned. @item @emph{Example}: @@ -10648,7 +10755,6 @@ Subroutine @code{CALL SYSTEM_CLOCK([COUNT, COUNT_RATE, COUNT_MAX])} @item @emph{Arguments}: -@item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{COUNT} @tab (Optional) shall be a scalar of type default @code{INTEGER} with @code{INTENT(OUT)}. @@ -11658,6 +11764,16 @@ are defined. @item @code{C_VERTICAL_TAB} @tab vertical tab @tab @code{'\v'} @end multitable +Moreover, the following two named constants are defined: + +@multitable @columnfractions .20 .80 +@item Name @tab Type +@item @code{C_NULL_PTR} @tab @code{C_PTR} +@item @code{C_NULL_FUNPTR} @tab @code{C_FUNPTR} +@end multitable + +Both are equivalent to the value @code{NULL} in C. + @node OpenMP Modules OMP_LIB and OMP_LIB_KINDS @section OpenMP Modules @code{OMP_LIB} and @code{OMP_LIB_KINDS} @table @asis diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index f9a6d7b1240..afbde0210b4 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1497,6 +1497,14 @@ resolve_tag (const io_tag *tag, gfc_expr *e) return FAILURE; } + if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Nondefault LOGICAL " + "in %s tag at %L", tag->name, &e->where) + == FAILURE) + return FAILURE; + } + if (tag == &tag_convert) { if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L", diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 8f764ef9083..9bf767dbaf6 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -122,7 +122,7 @@ resolve_mask_arg (gfc_expr *mask) static void resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, - const char *name) + const char *name, bool coarray) { f->ts.type = BT_INTEGER; if (kind) @@ -134,7 +134,8 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, { f->rank = 1; f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); + mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) + : array->rank); } f->value.function.name = xstrdup (name); @@ -853,7 +854,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_component_ref (a, "$vptr"); else if (a->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (a->ts.u.derived, false); + vtab = gfc_find_derived_vtab (a->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (a->ref); memset (a, '\0', sizeof (gfc_expr)); @@ -869,7 +870,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_component_ref (mo, "$vptr"); else if (mo->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (mo->ts.u.derived, false); + vtab = gfc_find_derived_vtab (mo->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (mo->ref); memset (mo, '\0', sizeof (gfc_expr)); @@ -1268,14 +1269,14 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED, void gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__lbound"); + resolve_bound (f, array, dim, kind, "__lbound", false); } void gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__lcobound"); + resolve_bound (f, array, dim, kind, "__lcobound", true); } @@ -2318,6 +2319,18 @@ gfc_resolve_ftell (gfc_expr *f, gfc_expr *u) void +gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; +} + + +void gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) { const char *name; @@ -2401,7 +2414,7 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, void gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim) { - resolve_bound (f, array, dim, NULL, "__this_image"); + resolve_bound (f, array, dim, NULL, "__this_image", true); } @@ -2540,14 +2553,14 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string) void gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__ubound"); + resolve_bound (f, array, dim, kind, "__ubound", false); } void gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__ucobound"); + resolve_bound (f, array, dim, kind, "__ucobound", true); } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 92c4da0a4b5..92580e359db 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2000,12 +2000,16 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) gfc_state_data *p, *o; gfc_symbol *sym; match m; + int cnt; if (gfc_match_eos () == MATCH_YES) sym = NULL; else { - m = gfc_match ("% %s%t", &sym); + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree* stree; + + m = gfc_match ("% %n%t", name); if (m == MATCH_ERROR) return MATCH_ERROR; if (m == MATCH_NO) @@ -2014,15 +2018,27 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) return MATCH_ERROR; } + /* Find the corresponding symbol. If there's a BLOCK statement + between here and the label, it is not in gfc_current_ns but a parent + namespace! */ + stree = gfc_find_symtree_in_proc (name, gfc_current_ns); + if (!stree) + { + gfc_error ("Name '%s' in %s statement at %C is unknown", + name, gfc_ascii_statement (st)); + return MATCH_ERROR; + } + + sym = stree->n.sym; if (sym->attr.flavor != FL_LABEL) { gfc_error ("Name '%s' in %s statement at %C is not a loop name", - sym->name, gfc_ascii_statement (st)); + name, gfc_ascii_statement (st)); return MATCH_ERROR; } } - /* Find the loop mentioned specified by the label (or lack of a label). */ + /* Find the loop specified by the label (or lack of a label). */ for (o = NULL, p = gfc_state_stack; p; p = p->previous) if (p->state == COMP_DO && (sym == NULL || sym == p->sym)) break; @@ -2053,17 +2069,34 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) gfc_ascii_statement (st)); return MATCH_ERROR; } - else if (st == ST_EXIT - && p->previous != NULL - && p->previous->state == COMP_OMP_STRUCTURED_BLOCK - && (p->previous->head->op == EXEC_OMP_DO - || p->previous->head->op == EXEC_OMP_PARALLEL_DO)) - { - gcc_assert (p->previous->head->next != NULL); - gcc_assert (p->previous->head->next->op == EXEC_DO - || p->previous->head->next->op == EXEC_DO_WHILE); - gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); - return MATCH_ERROR; + + for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) + o = o->previous; + if (cnt > 0 + && o != NULL + && o->state == COMP_OMP_STRUCTURED_BLOCK + && (o->head->op == EXEC_OMP_DO + || o->head->op == EXEC_OMP_PARALLEL_DO)) + { + int collapse = 1; + gcc_assert (o->head->next != NULL + && (o->head->next->op == EXEC_DO + || o->head->next->op == EXEC_DO_WHILE) + && o->previous != NULL + && o->previous->tail->op == o->head->op); + if (o->previous->tail->ext.omp_clauses != NULL + && o->previous->tail->ext.omp_clauses->collapse > 1) + collapse = o->previous->tail->ext.omp_clauses->collapse; + if (st == ST_EXIT && cnt <= collapse) + { + gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); + return MATCH_ERROR; + } + if (st == ST_CYCLE && cnt < collapse) + { + gfc_error ("CYCLE statement at %C to non-innermost collapsed !$OMP DO loop"); + return MATCH_ERROR; + } } /* Save the first statement in the loop - needed by the backend. */ @@ -2878,7 +2911,7 @@ gfc_match_allocate (void) || tail->expr->ref->type == REF_ARRAY)); if (sym && sym->ts.type == BT_CLASS) b2 = !(CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.pointer); + || CLASS_DATA (sym)->attr.class_pointer); else b2 = sym && !(sym->attr.allocatable || sym->attr.pointer || sym->attr.proc_pointer); @@ -3184,7 +3217,7 @@ gfc_match_deallocate (void) || tail->expr->ref->type == REF_ARRAY)); if (sym && sym->ts.type == BT_CLASS) b2 = !(CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.pointer); + || CLASS_DATA (sym)->attr.class_pointer); else b2 = sym && !(sym->attr.allocatable || sym->attr.pointer || sym->attr.proc_pointer); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index b42a9e8c1d1..426a17c5cdf 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "5" +#define MOD_VERSION "6" /* Structure that describes a position within a module file. */ @@ -1675,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_CONTIGUOUS + AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER } ab_attribute; @@ -1724,6 +1724,7 @@ static const mstring attr_bits[] = minit ("PROC_POINTER", AB_PROC_POINTER), minit ("VTYPE", AB_VTYPE), minit ("VTAB", AB_VTAB), + minit ("CLASS_POINTER", AB_CLASS_POINTER), minit (NULL, -1) }; @@ -1818,6 +1819,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits); if (attr->pointer) MIO_NAME (ab_attribute) (AB_POINTER, attr_bits); + if (attr->class_pointer) + MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits); if (attr->is_protected) MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits); if (attr->value) @@ -1933,6 +1936,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_POINTER: attr->pointer = 1; break; + case AB_CLASS_POINTER: + attr->class_pointer = 1; + break; case AB_PROTECTED: attr->is_protected = 1; break; @@ -5195,53 +5201,6 @@ gfc_dump_module (const char *name, int dump_flag) } -static void -sort_iso_c_rename_list (void) -{ - gfc_use_rename *tmp_list = NULL; - gfc_use_rename *curr; - gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL}; - int c_kind; - int i; - - for (curr = gfc_rename_list; curr; curr = curr->next) - { - c_kind = get_c_kind (curr->use_name, c_interop_kinds_table); - if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST) - { - gfc_error ("Symbol '%s' referenced at %L does not exist in " - "intrinsic module ISO_C_BINDING.", curr->use_name, - &curr->where); - } - else - /* Put it in the list. */ - kinds_used[c_kind] = curr; - } - - /* Make a new (sorted) rename list. */ - i = 0; - while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL) - i++; - - if (i < ISOCBINDING_NUMBER) - { - tmp_list = kinds_used[i]; - - i++; - curr = tmp_list; - for (; i < ISOCBINDING_NUMBER; i++) - if (kinds_used[i] != NULL) - { - curr->next = kinds_used[i]; - curr = curr->next; - curr->next = NULL; - } - } - - gfc_rename_list = tmp_list; -} - - /* Import the intrinsic ISO_C_BINDING module, generating symbols in the current namespace for all named constants, pointer types, and procedures in the module unless the only clause was used or a rename @@ -5255,7 +5214,6 @@ import_iso_c_binding_module (void) const char *iso_c_module_name = "__iso_c_binding"; gfc_use_rename *u; int i; - char *local_name; /* Look only in the current namespace. */ mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name); @@ -5280,57 +5238,32 @@ import_iso_c_binding_module (void) /* Generate the symbols for the named constants representing the kinds for intrinsic data types. */ - if (only_flag) + for (i = 0; i < ISOCBINDING_NUMBER; i++) { - /* Sort the rename list because there are dependencies between types - and procedures (e.g., c_loc needs c_ptr). */ - sort_iso_c_rename_list (); - + bool found = false; for (u = gfc_rename_list; u; u = u->next) - { - i = get_c_kind (u->use_name, c_interop_kinds_table); + if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0) + { + u->found = 1; + found = true; + generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) i, + u->local_name); + } - if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST) - { - gfc_error ("Symbol '%s' referenced at %L does not exist in " - "intrinsic module ISO_C_BINDING.", u->use_name, - &u->where); - continue; - } - - generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) i, - u->local_name); - } - } - else - { - for (i = 0; i < ISOCBINDING_NUMBER; i++) - { - local_name = NULL; - for (u = gfc_rename_list; u; u = u->next) - { - if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0) - { - local_name = u->local_name; - u->found = 1; - break; - } - } - generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) i, - local_name); - } + if (!found && !only_flag) + generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) i, NULL); + } - for (u = gfc_rename_list; u; u = u->next) - { - if (u->found) - continue; + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; - gfc_error ("Symbol '%s' referenced at %L not found in intrinsic " - "module ISO_C_BINDING", u->use_name, &u->where); - } - } + gfc_error ("Symbol '%s' referenced at %L not found in intrinsic " + "module ISO_C_BINDING", u->use_name, &u->where); + } } @@ -5372,7 +5305,6 @@ static void use_iso_fortran_env_module (void) { static char mod[] = "iso_fortran_env"; - const char *local_name; gfc_use_rename *u; gfc_symbol *mod_sym; gfc_symtree *mod_symtree; @@ -5408,60 +5340,41 @@ use_iso_fortran_env_module (void) "non-intrinsic module name used previously", mod); /* Generate the symbols for the module integer named constants. */ - if (only_flag) - for (u = gfc_rename_list; u; u = u->next) - { - for (i = 0; symbol[i].name; i++) - if (strcmp (symbol[i].name, u->use_name) == 0) - break; - - if (symbol[i].name == NULL) - { - gfc_error ("Symbol '%s' referenced at %L does not exist in " - "intrinsic module ISO_FORTRAN_ENV", u->use_name, - &u->where); - continue; - } - - if ((gfc_option.flag_default_integer || gfc_option.flag_default_real) - && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) - gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant " - "from intrinsic module ISO_FORTRAN_ENV at %L is " - "incompatible with option %s", &u->where, - gfc_option.flag_default_integer - ? "-fdefault-integer-8" : "-fdefault-real-8"); - - if (gfc_notify_std (symbol[i].standard, "The symbol '%s', referrenced " - "at %C, is not in the selected standard", - symbol[i].name) == FAILURE) - continue; - create_int_parameter (u->local_name[0] ? u->local_name - : symbol[i].name, - symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV, - symbol[i].id); - } - else + for (i = 0; symbol[i].name; i++) { - for (i = 0; symbol[i].name; i++) + bool found = false; + for (u = gfc_rename_list; u; u = u->next) { - local_name = NULL; - - for (u = gfc_rename_list; u; u = u->next) + if (strcmp (symbol[i].name, u->use_name) == 0) { - if (strcmp (symbol[i].name, u->use_name) == 0) - { - local_name = u->local_name; - u->found = 1; - break; - } + found = true; + u->found = 1; + + if (gfc_notify_std (symbol[i].standard, "The symbol '%s', " + "referrenced at %C, is not in the selected " + "standard", symbol[i].name) == FAILURE) + continue; + + if ((gfc_option.flag_default_integer || gfc_option.flag_default_real) + && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) + gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named " + "constant from intrinsic module " + "ISO_FORTRAN_ENV at %C is incompatible with " + "option %s", + gfc_option.flag_default_integer + ? "-fdefault-integer-8" + : "-fdefault-real-8"); + + create_int_parameter (u->local_name[0] ? u->local_name : u->use_name, + symbol[i].value, mod, + INTMOD_ISO_FORTRAN_ENV, symbol[i].id); } + } - if (u && gfc_notify_std (symbol[i].standard, "The symbol '%s', " - "referrenced at %C, is not in the selected " - "standard", symbol[i].name) == FAILURE) - continue; - else if ((gfc_option.allow_std & symbol[i].standard) == 0) + if (!found && !only_flag) + { + if ((gfc_option.allow_std & symbol[i].standard) == 0) continue; if ((gfc_option.flag_default_integer || gfc_option.flag_default_real) @@ -5472,19 +5385,18 @@ use_iso_fortran_env_module (void) gfc_option.flag_default_integer ? "-fdefault-integer-8" : "-fdefault-real-8"); - create_int_parameter (local_name ? local_name : symbol[i].name, - symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV, - symbol[i].id); + create_int_parameter (symbol[i].name, symbol[i].value, mod, + INTMOD_ISO_FORTRAN_ENV, symbol[i].id); } + } - for (u = gfc_rename_list; u; u = u->next) - { - if (u->found) - continue; + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; - gfc_error ("Symbol '%s' referenced at %L not found in intrinsic " + gfc_error ("Symbol '%s' referenced at %L not found in intrinsic " "module ISO_FORTRAN_ENV", u->use_name, &u->where); - } } } diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index af537a1e70e..d5c6c3caf90 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -33,7 +33,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "target.h" #include "cpp.h" -#include "toplev.h" /* For sorry. */ +#include "diagnostic-core.h" /* For sorry. */ #include "tm.h" gfc_option_t gfc_option; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 50f795723eb..a1af0264658 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2103,7 +2103,7 @@ endType: /* Look for pointer components. */ if (c->attr.pointer - || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer) + || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer) || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) sym->attr.pointer_comp = 1; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index b6c08a9c406..cb6fae20c41 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1999,7 +1999,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (sym->ts.type == BT_CLASS) { dimension = CLASS_DATA (sym)->attr.dimension; - pointer = CLASS_DATA (sym)->attr.pointer; + pointer = CLASS_DATA (sym)->attr.class_pointer; allocatable = CLASS_DATA (sym)->attr.allocatable; } else @@ -2059,7 +2059,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (comp->ts.type == BT_CLASS) { - pointer = CLASS_DATA (comp)->attr.pointer; + pointer = CLASS_DATA (comp)->attr.class_pointer; allocatable = CLASS_DATA (comp)->attr.allocatable; } else @@ -2109,7 +2109,7 @@ gfc_expr_attr (gfc_expr *e) if (sym->ts.type == BT_CLASS) { attr.dimension = CLASS_DATA (sym)->attr.dimension; - attr.pointer = CLASS_DATA (sym)->attr.pointer; + attr.pointer = CLASS_DATA (sym)->attr.class_pointer; attr.allocatable = CLASS_DATA (sym)->attr.allocatable; } } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4e11fc6c311..2434be192d7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -905,7 +905,7 @@ resolve_structure_cons (gfc_expr *expr) && !(comp->attr.pointer || comp->attr.allocatable || comp->attr.proc_pointer || (comp->ts.type == BT_CLASS - && (CLASS_DATA (comp)->attr.pointer + && (CLASS_DATA (comp)->attr.class_pointer || CLASS_DATA (comp)->attr.allocatable)))) { t = FAILURE; @@ -2440,10 +2440,11 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, { char name[GFC_MAX_SYMBOL_LEN + 1]; char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; - int optional_arg = 0, is_pointer = 0; + int optional_arg = 0; gfc_try retval = SUCCESS; gfc_symbol *args_sym; gfc_typespec *arg_ts; + symbol_attribute arg_attr; if (args->expr->expr_type == EXPR_CONSTANT || args->expr->expr_type == EXPR_OP @@ -2460,8 +2461,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, and not necessarily that of the expr symbol (args_sym), because the actual expression could be a part-ref of the expr symbol. */ arg_ts = &(args->expr->ts); - - is_pointer = gfc_is_data_pointer (args->expr); + arg_attr = gfc_expr_attr (args->expr); if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { @@ -2504,7 +2504,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, else if (sym->intmod_sym_id == ISOCBINDING_LOC) { /* Make sure we have either the target or pointer attribute. */ - if (!args_sym->attr.target && !is_pointer) + if (!arg_attr.target && !arg_attr.pointer) { gfc_error_now ("Parameter '%s' to '%s' at %L must be either " "a TARGET or an associated pointer", @@ -2587,7 +2587,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, } } } - else if (is_pointer + else if (arg_attr.pointer && is_scalar_expr_ptr (args->expr) != SUCCESS) { /* Case 1c, section 15.1.2.5, J3/04-007: an associated @@ -2622,6 +2622,13 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, &(args->expr->where)); retval = FAILURE; } + else if (arg_ts->type == BT_CLASS) + { + gfc_error_now ("Parameter '%s' to '%s' at %L must not be " + "polymorphic", args_sym->name, sym->name, + &(args->expr->where)); + retval = FAILURE; + } } } else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) @@ -4772,6 +4779,15 @@ resolve_variable (gfc_expr *e) sym->entry_id = current_entry_id + 1; } + /* If a symbol has been host_associated mark it. This is used latter, + to identify if aliasing is possible via host association. */ + if (sym->attr.flavor == FL_VARIABLE + && gfc_current_ns->parent + && (gfc_current_ns->parent == sym->ns + || (gfc_current_ns->parent->parent + && gfc_current_ns->parent->parent == sym->ns))) + sym->attr.host_assoc = 1; + resolve_procedure: if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE) t = FAILURE; @@ -5320,10 +5336,11 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) if (matches) { e->value.compcall.tbp = g->specific; + genname = g->specific_st->name; /* Pass along the name for CLASS methods, where the vtab procedure pointer component has to be referenced. */ if (name) - *name = g->specific_st->name; + *name = genname; goto success; } } @@ -5336,12 +5353,6 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name) 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); @@ -5468,10 +5479,38 @@ resolve_typebound_function (gfc_expr* e) gfc_ref *class_ref; gfc_symtree *st; const char *name; - const char *genname; gfc_typespec ts; + gfc_expr *expr; st = e->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = e->value.compcall.base_object; + if (expr && expr->symtree->n.sym->ts.type == BT_CLASS + && e->value.compcall.name) + { + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + ts = expr->symtree->n.sym->ts; + declared = ts.u.derived; + c = gfc_find_component (declared, "$vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (resolve_compcall (e, &name) == FAILURE) + return FAILURE; + + /* Use the generic name if it is there. */ + name = name ? name : e->value.function.esym->name; + e->symtree = expr->symtree; + expr->symtree->n.sym->ts.u.derived = declared; + gfc_add_component_ref (e, "$vptr"); + gfc_add_component_ref (e, name); + e->value.function.esym = NULL; + return SUCCESS; + } + if (st == NULL) return resolve_compcall (e, NULL); @@ -5492,11 +5531,6 @@ resolve_typebound_function (gfc_expr* e) c = gfc_find_component (declared, "$data", true, true); declared = c->ts.u.derived; - /* Keep the generic name so that the vtab reference can be made. */ - genname = NULL; - if (e->value.compcall.tbp->is_generic) - genname = e->value.compcall.name; - /* Treat the call as if it is a typebound procedure, in order to roll out the correct name for the specific function. */ if (resolve_compcall (e, &name) == FAILURE) @@ -5512,15 +5546,6 @@ resolve_typebound_function (gfc_expr* e) /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (e, "$vptr"); - if (genname) - { - /* A generic procedure needs the subsidiary vtabs and vtypes for - the specific procedures to have been build. */ - gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared, true); - gcc_assert (vtab); - gfc_add_component_ref (e, genname); - } gfc_add_component_ref (e, name); /* Recover the typespec for the expression. This is really only @@ -5543,11 +5568,39 @@ resolve_typebound_subroutine (gfc_code *code) gfc_ref *new_ref; gfc_ref *class_ref; gfc_symtree *st; - const char *genname; const char *name; gfc_typespec ts; + gfc_expr *expr; st = code->expr1->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = code->expr1->value.compcall.base_object; + if (expr && expr->symtree->n.sym->ts.type == BT_CLASS + && code->expr1->value.compcall.name) + { + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + ts = expr->symtree->n.sym->ts; + declared = ts.u.derived; + c = gfc_find_component (declared, "$vptr", true, true); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (resolve_typebound_call (code, &name) == FAILURE) + return FAILURE; + + /* Use the generic name if it is there. */ + name = name ? name : code->expr1->value.function.esym->name; + code->expr1->symtree = expr->symtree; + expr->symtree->n.sym->ts.u.derived = declared; + gfc_add_component_ref (code->expr1, "$vptr"); + gfc_add_component_ref (code->expr1, name); + code->expr1->value.function.esym = NULL; + return SUCCESS; + } + if (st == NULL) return resolve_typebound_call (code, NULL); @@ -5555,7 +5608,7 @@ resolve_typebound_subroutine (gfc_code *code) return FAILURE; /* Get the CLASS declared type. */ - declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); + get_declared_from_expr (&class_ref, &new_ref, code->expr1); /* Weed out cases of the ultimate component being a derived type. */ if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) @@ -5563,15 +5616,7 @@ resolve_typebound_subroutine (gfc_code *code) { gfc_free_ref_list (new_ref); return resolve_typebound_call (code, NULL); - } - - c = gfc_find_component (declared, "$data", true, true); - declared = c->ts.u.derived; - - /* Keep the generic name so that the vtab reference can be made. */ - genname = NULL; - if (code->expr1->value.compcall.tbp->is_generic) - genname = code->expr1->value.compcall.name; + } if (resolve_typebound_call (code, &name) == FAILURE) return FAILURE; @@ -5586,15 +5631,6 @@ resolve_typebound_subroutine (gfc_code *code) /* '$vptr' points to the vtab, which contains the procedure pointers. */ gfc_add_component_ref (code->expr1, "$vptr"); - if (genname) - { - /* A generic procedure needs the subsidiary vtabs and vtypes for - the specific procedures to have been build. */ - gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared, true); - gcc_assert (vtab); - gfc_add_component_ref (code->expr1, genname); - } gfc_add_component_ref (code->expr1, name); /* Recover the typespec for the expression. This is really only @@ -5776,7 +5812,7 @@ gfc_resolve_expr (gfc_expr *e) { expression_rank (e); if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) - gfc_expand_constructor (e); + gfc_expand_constructor (e, false); } /* This provides the opportunity for the length of constructors with @@ -5786,7 +5822,7 @@ gfc_resolve_expr (gfc_expr *e) { /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER here rather then add a duplicate test for it above. */ - gfc_expand_constructor (e); + gfc_expand_constructor (e, false); t = gfc_resolve_character_array_constructor (e); } @@ -6087,7 +6123,7 @@ resolve_deallocate_expr (gfc_expr *e) if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.pointer; + pointer = CLASS_DATA (sym)->attr.class_pointer; } else { @@ -6111,7 +6147,7 @@ resolve_deallocate_expr (gfc_expr *e) if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.pointer; + pointer = CLASS_DATA (c)->attr.class_pointer; } else { @@ -6310,7 +6346,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.pointer; + pointer = CLASS_DATA (sym)->attr.class_pointer; dimension = CLASS_DATA (sym)->attr.dimension; codimension = CLASS_DATA (sym)->attr.codimension; is_abstract = CLASS_DATA (sym)->attr.abstract; @@ -6348,7 +6384,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) if (c->ts.type == BT_CLASS) { allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.pointer; + pointer = CLASS_DATA (c)->attr.class_pointer; dimension = CLASS_DATA (c)->attr.dimension; codimension = CLASS_DATA (c)->attr.codimension; is_abstract = CLASS_DATA (c)->attr.abstract; @@ -7496,7 +7532,7 @@ resolve_select_type (gfc_code *code) new_st->expr1->value.function.actual = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr"); - vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true); + vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); @@ -9130,7 +9166,7 @@ build_default_init_expr (gfc_symbol *sym) { case BT_INTEGER: if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) - mpz_init_set_si (init_expr->value.integer, + mpz_set_si (init_expr->value.integer, gfc_option.flag_init_integer_value); else { @@ -9140,7 +9176,6 @@ build_default_init_expr (gfc_symbol *sym) break; case BT_REAL: - mpfr_init (init_expr->value.real); switch (gfc_option.flag_init_real) { case GFC_INIT_REAL_SNAN: @@ -9170,7 +9205,6 @@ build_default_init_expr (gfc_symbol *sym) break; case BT_COMPLEX: - mpc_init2 (init_expr->value.complex, mpfr_get_default_prec()); switch (gfc_option.flag_init_real) { case GFC_INIT_REAL_SNAN: @@ -9318,7 +9352,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) { /* F03:C502. */ - if (!gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) + if (sym->attr.class_ok + && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", CLASS_DATA (sym)->ts.u.derived->name, sym->name, @@ -10769,7 +10804,7 @@ resolve_fl_derived (gfc_symbol *sym) gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true); if (vptr->ts.u.derived == NULL) { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived, false); + gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); gcc_assert (vtab); vptr->ts.u.derived = vtab->ts.u.derived; } @@ -11084,7 +11119,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer + if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->ts.u.derived->components == NULL && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp) { @@ -11096,7 +11131,8 @@ resolve_fl_derived (gfc_symbol *sym) /* C437. */ if (c->ts.type == BT_CLASS - && !(CLASS_DATA (c)->attr.pointer || CLASS_DATA (c)->attr.allocatable)) + && !(CLASS_DATA (c)->attr.class_pointer + || CLASS_DATA (c)->attr.allocatable)) { gfc_error ("Component '%s' with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index df6ada963c3..18f7b253a28 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2565,6 +2565,27 @@ select_type_insert_tmp (gfc_symtree **st) } +/* Look for a symtree in the current procedure -- that is, go up to + parent namespaces but only if inside a BLOCK. Returns NULL if not found. */ + +gfc_symtree* +gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns) +{ + while (ns) + { + gfc_symtree* st = gfc_find_symtree (ns->sym_root, name); + if (st) + return st; + + if (!ns->construct_entities) + break; + ns = ns->parent; + } + + return NULL; +} + + /* Search for a symtree starting in the current namespace, resorting to any parent namespaces if requested by a nonzero parent_flag. Returns nonzero if the name is ambiguous. */ @@ -2811,6 +2832,17 @@ gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym) if (lsym->attr.allocatable && rsym->attr.pointer) return 1; + /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7 + and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already + checked above. */ + if (lsym->attr.target && rsym->attr.target + && ((lsym->attr.dummy && !lsym->attr.contiguous + && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE)) + || (rsym->attr.dummy && !rsym->attr.contiguous + && (!rsym->attr.dimension + || rsym->as->type == AS_ASSUMED_SHAPE)))) + return 1; + return 0; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7eb8e755785..cca4ecc4d9c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "toplev.h" /* For internal_error/fatal_error. */ +#include "diagnostic-core.h" /* For internal_error/fatal_error. */ #include "flags.h" #include "gfortran.h" #include "constructor.h" @@ -434,10 +434,10 @@ gfc_free_ss (gfc_ss * ss) switch (ss->type) { case GFC_SS_SECTION: - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + for (n = 0; n < ss->data.info.dimen; n++) { - if (ss->data.info.subscript[n]) - gfc_free_ss_chain (ss->data.info.subscript[n]); + if (ss->data.info.subscript[ss->data.info.dim[n]]) + gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]); } break; @@ -762,25 +762,28 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, for (n = 0; n < info->dimen; n++) { + dim = info->dim[n]; + if (size == NULL_TREE) { /* For a callee allocated array express the loop bounds in terms of the descriptor fields. */ - tmp = - fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n])); + tmp = fold_build2 ( + MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), + gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); loop->to[n] = tmp; continue; } /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); + gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[dim], size); - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], + gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[dim], gfc_index_zero_node); - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]); + gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[dim], + loop->to[n]); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->to[n], gfc_index_one_node); @@ -2177,9 +2180,12 @@ gfc_init_loopinfo (gfc_loopinfo * loop) gfc_init_block (&loop->pre); gfc_init_block (&loop->post); - /* Initially scalarize in order. */ + /* Initially scalarize in order and default to no loop reversal. */ for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - loop->order[n] = n; + { + loop->order[n] = n; + loop->reverse[n] = GFC_CANNOT_REVERSE; + } loop->ss = gfc_ss_terminator; } @@ -2387,7 +2393,8 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, /* Return the offset for an index. Performs bound checking for elemental - dimensions. Single element references are processed separately. */ + dimensions. Single element references are processed separately. + DIM is the array dimension, I is the loop dimension. */ static tree gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, @@ -2448,14 +2455,14 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, /* Scalarized dimension. */ gcc_assert (info && se->loop); - /* Multiply the loop variable by the stride and delta. */ + /* Multiply the loop variable by the stride and delta. */ index = se->loop->loopvar[i]; - if (!integer_onep (info->stride[i])) + if (!integer_onep (info->stride[dim])) index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, - info->stride[i]); - if (!integer_zerop (info->delta[i])) + info->stride[dim]); + if (!integer_zerop (info->delta[dim])) index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, - info->delta[i]); + info->delta[dim]); break; default: @@ -2467,9 +2474,9 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, /* Temporary array or derived type component. */ gcc_assert (se->loop); index = se->loop->loopvar[se->loop->order[i]]; - if (!integer_zerop (info->delta[i])) + if (!integer_zerop (info->delta[dim])) index = fold_build2 (PLUS_EXPR, gfc_array_index_type, - index, info->delta[i]); + index, info->delta[dim]); } /* Multiply by the stride. */ @@ -2838,8 +2845,18 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, } else { + bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) + && (loop->temp_ss == NULL); + loopbody = gfc_finish_block (pbody); + if (reverse_loop) + { + tmp = loop->from[n]; + loop->from[n] = loop->to[n]; + loop->to[n] = tmp; + } + /* Initialize the loopvar. */ if (loop->loopvar[n] != loop->from[n]) gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); @@ -2850,8 +2867,8 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, gfc_init_block (&block); /* The exit condition. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - loop->loopvar[n], loop->to[n]); + cond = fold_build2 (reverse_loop ? LT_EXPR : GT_EXPR, + boolean_type_node, loop->loopvar[n], loop->to[n]); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -2861,8 +2878,10 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, gfc_add_expr_to_block (&block, loopbody); /* Increment the loopvar. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - loop->loopvar[n], gfc_index_one_node); + tmp = fold_build2 (reverse_loop ? MINUS_EXPR : PLUS_EXPR, + gfc_array_index_type, loop->loopvar[n], + gfc_index_one_node); + gfc_add_modify (&block, loop->loopvar[n], tmp); /* Build the loop. */ @@ -2964,54 +2983,10 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) } -/* Calculate the upper bound of an array section. */ - -static tree -gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock) -{ - int dim; - gfc_expr *end; - tree desc; - tree bound; - gfc_se se; - gfc_ss_info *info; - - gcc_assert (ss->type == GFC_SS_SECTION); - - info = &ss->data.info; - dim = info->dim[n]; - - if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - /* We'll calculate the upper bound once we have access to the - vector's descriptor. */ - return NULL; - - gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE); - desc = info->descriptor; - end = info->ref->u.ar.end[dim]; - - if (end) - { - /* The upper bound was specified. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, end, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - bound = se.expr; - } - else - { - /* No upper bound was specified, so use the bound of the array. */ - bound = gfc_conv_array_ubound (desc, dim); - } - - return bound; -} - - /* Calculate the lower bound of an array section. */ static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) { gfc_expr *start; gfc_expr *end; @@ -3019,19 +2994,17 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) tree desc; gfc_se se; gfc_ss_info *info; - int dim; gcc_assert (ss->type == GFC_SS_SECTION); info = &ss->data.info; - dim = info->dim[n]; if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) { /* We use a zero-based index to access the vector. */ - info->start[n] = gfc_index_zero_node; - info->end[n] = gfc_index_zero_node; - info->stride[n] = gfc_index_one_node; + info->start[dim] = gfc_index_zero_node; + info->stride[dim] = gfc_index_one_node; + info->end[dim] = NULL; return; } @@ -3049,14 +3022,14 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, start, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->start[n] = se.expr; + info->start[dim] = se.expr; } else { /* No lower bound specified so use the bound of the array. */ - info->start[n] = gfc_conv_array_lbound (desc, dim); + info->start[dim] = gfc_conv_array_lbound (desc, dim); } - info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre); + info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre); /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end @@ -3067,24 +3040,24 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, end, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->end[n] = se.expr; + info->end[dim] = se.expr; } else { /* No upper bound specified so use the bound of the array. */ - info->end[n] = gfc_conv_array_ubound (desc, dim); + info->end[dim] = gfc_conv_array_ubound (desc, dim); } - info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre); + info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); /* Calculate the stride. */ if (stride == NULL) - info->stride[n] = gfc_index_one_node; + info->stride[dim] = gfc_index_one_node; else { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre); + info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre); } } @@ -3149,7 +3122,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); for (n = 0; n < ss->data.info.dimen; n++) - gfc_conv_section_startstride (loop, ss, n); + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]); break; case GFC_SS_INTRINSIC: @@ -3224,11 +3197,10 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) check_upper = true; /* Zero stride is not allowed. */ - tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n], + tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[dim], gfc_index_zero_node); asprintf (&msg, "Zero stride is not allowed, for dimension %d " - "of array '%s'", info->dim[n]+1, - ss->expr->symtree->name); + "of array '%s'", dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg); gfc_free (msg); @@ -3236,27 +3208,27 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) desc = ss->data.info.descriptor; /* This is the run-time equivalent of resolve.c's - check_dimension(). The logical is more readable there - than it is here, with all the trees. */ + check_dimension(). The logical is more readable there + than it is here, with all the trees. */ lbound = gfc_conv_array_lbound (desc, dim); - end = info->end[n]; + end = info->end[dim]; if (check_upper) ubound = gfc_conv_array_ubound (desc, dim); else ubound = NULL; /* non_zerosized is true when the selected range is not - empty. */ + empty. */ stride_pos = fold_build2 (GT_EXPR, boolean_type_node, - info->stride[n], gfc_index_zero_node); - tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n], + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[dim], end); stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, stride_pos, tmp); stride_neg = fold_build2 (LT_EXPR, boolean_type_node, - info->stride[n], gfc_index_zero_node); - tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n], + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[dim], end); stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, stride_neg, tmp); @@ -3269,41 +3241,41 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) error message. */ if (check_upper) { - tmp = fold_build2 (LT_EXPR, boolean_type_node, - info->start[n], lbound); + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[dim], lbound); tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp); tmp2 = fold_build2 (GT_EXPR, boolean_type_node, - info->start[n], ubound); + info->start[dim], ubound); tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp2); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, + "outside of expected range (%%ld:%%ld)", + dim + 1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), - fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), fold_convert (long_integer_type_node, ubound)); - gfc_trans_runtime_check (true, false, tmp2, &inner, + gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), - fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), fold_convert (long_integer_type_node, ubound)); gfc_free (msg); } else { - tmp = fold_build2 (LT_EXPR, boolean_type_node, - info->start[n], lbound); + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[dim], lbound); tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, + "below lower bound of %%ld", + dim + 1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), + fold_convert (long_integer_type_node, info->start[dim]), fold_convert (long_integer_type_node, lbound)); gfc_free (msg); } @@ -3313,9 +3285,9 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) and check it against both lower and upper bounds. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - info->start[n]); + info->start[dim]); tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp, - info->stride[n]); + info->stride[dim]); tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, tmp); tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound); @@ -3327,8 +3299,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp3); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - info->dim[n]+1, ss->expr->symtree->name); + "outside of expected range (%%ld:%%ld)", + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), @@ -3344,32 +3316,32 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) else { asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - info->dim[n]+1, ss->expr->symtree->name); + "below lower bound of %%ld", + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), fold_convert (long_integer_type_node, lbound)); gfc_free (msg); } - + /* Check the section sizes match. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - info->start[n]); + info->start[dim]); tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, - info->stride[n]); + info->stride[dim]); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, gfc_index_one_node, tmp); tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, build_int_cst (gfc_array_index_type, 0)); /* We remember the size of the first section, and check all the - others against this. */ + others against this. */ if (size[n]) { tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); asprintf (&msg, "Array bound mismatch for dimension %d " "of array '%s' (%%ld/%%ld)", - info->dim[n]+1, ss->expr->symtree->name); + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp3, &inner, &ss->expr->where, msg, @@ -3492,7 +3464,8 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, lref = dest->expr->ref; rref = ss->expr->ref; - nDepend = gfc_dep_resolver (lref, rref); + nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); + if (nDepend == 1) break; #if 0 @@ -3561,7 +3534,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, void gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) { - int n; + int n, dim, spec_dim; gfc_ss_info *info; gfc_ss_info *specinfo; gfc_ss *ss; @@ -3577,14 +3550,34 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) loopspec[n] = NULL; dynamic[n] = false; /* We use one SS term, and use that to determine the bounds of the - loop for this dimension. We try to pick the simplest term. */ + loop for this dimension. We try to pick the simplest term. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { + if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE) + continue; + + info = &ss->data.info; + dim = info->dim[n]; + + if (loopspec[n] != NULL) + { + specinfo = &loopspec[n]->data.info; + spec_dim = specinfo->dim[n]; + } + else + { + /* Silence unitialized warnings. */ + specinfo = NULL; + spec_dim = 0; + } + if (ss->shape) { + gcc_assert (ss->shape[dim]); /* The frontend has worked out the size for us. */ - if (!loopspec[n] || !loopspec[n]->shape - || !integer_zerop (loopspec[n]->data.info.start[n])) + if (!loopspec[n] + || !loopspec[n]->shape + || !integer_zerop (specinfo->start[spec_dim])) /* Prefer zero-based descriptors if possible. */ loopspec[n] = ss; continue; @@ -3611,22 +3604,16 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* TODO: Pick the best bound if we have a choice between a function and something else. */ - if (ss->type == GFC_SS_FUNCTION) - { - loopspec[n] = ss; - continue; - } + if (ss->type == GFC_SS_FUNCTION) + { + loopspec[n] = ss; + continue; + } if (ss->type != GFC_SS_SECTION) continue; - if (loopspec[n]) - specinfo = &loopspec[n]->data.info; - else - specinfo = NULL; - info = &ss->data.info; - - if (!specinfo) + if (!loopspec[n]) loopspec[n] = ss; /* Criteria for choosing a loop specifier (most important first): doesn't need realloc @@ -3637,14 +3624,14 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) */ else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n]) loopspec[n] = ss; - else if (integer_onep (info->stride[n]) - && !integer_onep (specinfo->stride[n])) + else if (integer_onep (info->stride[dim]) + && !integer_onep (specinfo->stride[spec_dim])) loopspec[n] = ss; - else if (INTEGER_CST_P (info->stride[n]) - && !INTEGER_CST_P (specinfo->stride[n])) + else if (INTEGER_CST_P (info->stride[dim]) + && !INTEGER_CST_P (specinfo->stride[spec_dim])) loopspec[n] = ss; - else if (INTEGER_CST_P (info->start[n]) - && !INTEGER_CST_P (specinfo->start[n])) + else if (INTEGER_CST_P (info->start[dim]) + && !INTEGER_CST_P (specinfo->start[spec_dim])) loopspec[n] = ss; /* We don't work out the upper bound. else if (INTEGER_CST_P (info->finish[n]) @@ -3657,26 +3644,27 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) gcc_assert (loopspec[n]); info = &loopspec[n]->data.info; + dim = info->dim[n]; /* Set the extents of this range. */ cshape = loopspec[n]->shape; - if (cshape && INTEGER_CST_P (info->start[n]) - && INTEGER_CST_P (info->stride[n])) + if (cshape && INTEGER_CST_P (info->start[dim]) + && INTEGER_CST_P (info->stride[dim])) { - loop->from[n] = info->start[n]; + loop->from[n] = info->start[dim]; mpz_set (i, cshape[n]); mpz_sub_ui (i, i, 1); /* To = from + (size - 1) * stride. */ tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); - if (!integer_onep (info->stride[n])) + if (!integer_onep (info->stride[dim])) tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp, info->stride[dim]); loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->from[n], tmp); } else { - loop->from[n] = info->start[n]; + loop->from[n] = info->start[dim]; switch (loopspec[n]->type) { case GFC_SS_CONSTRUCTOR: @@ -3688,17 +3676,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) case GFC_SS_SECTION: /* Use the end expression if it exists and is not constant, so that it is only evaluated once. */ - if (info->end[n] && !INTEGER_CST_P (info->end[n])) - loop->to[n] = info->end[n]; - else - loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n, - &loop->pre); + loop->to[n] = info->end[dim]; break; - case GFC_SS_FUNCTION: + case GFC_SS_FUNCTION: /* The loop bound will be set when we generate the call. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; + gcc_assert (loop->to[n] == NULL_TREE); + break; default: gcc_unreachable (); @@ -3706,20 +3690,20 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) } /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[n])) - info->delta[n] = gfc_index_zero_node; + if (integer_onep (info->stride[dim])) + info->delta[dim] = gfc_index_zero_node; else { /* Set the delta for this section. */ - info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre); + info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); /* Number of iterations is (end - start + step) / step. with start = 0, this simplifies to last = end / step; for (i = 0; i<=last; i++){...}; */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop->to[n], loop->from[n]); - tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, + tmp, info->stride[dim]); tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, build_int_cst (gfc_array_index_type, -1)); loop->to[n] = gfc_evaluate_now (tmp, &loop->pre); @@ -3780,18 +3764,20 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* If we are specifying the range the delta is already set. */ if (loopspec[n] != ss) { + dim = ss->data.info.dim[n]; + /* Calculate the offset relative to the loop variable. - First multiply by the stride. */ + First multiply by the stride. */ tmp = loop->from[n]; - if (!integer_onep (info->stride[n])) + if (!integer_onep (info->stride[dim])) tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp, info->stride[dim]); /* Then subtract this from our starting value. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - info->start[n], tmp); + info->start[dim], tmp); - info->delta[n] = gfc_evaluate_now (tmp, &loop->pre); + info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre); } } } @@ -4313,10 +4299,11 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, /* Generate code to initialize/allocate an array variable. */ -tree -gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) +void +gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, + gfc_wrapped_block * block) { - stmtblock_t block; + stmtblock_t init; tree type; tree tmp; tree size; @@ -4327,32 +4314,32 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) /* Do nothing for USEd variables. */ if (sym->attr.use_assoc) - return fnbody; + return; type = TREE_TYPE (decl); gcc_assert (GFC_ARRAY_TYPE_P (type)); onstack = TREE_CODE (type) != POINTER_TYPE; - gfc_start_block (&block); + gfc_start_block (&init); /* Evaluate character string length. */ if (sym->ts.type == BT_CHARACTER && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &block); + gfc_trans_vla_type_sizes (sym, &init); /* Emit a DECL_EXPR for this variable, which will cause the gimplifier to allocate storage, and all that good stuff. */ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&block, tmp); + gfc_add_expr_to_block (&init, tmp); } if (onstack) { - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } type = TREE_TYPE (type); @@ -4363,17 +4350,18 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - size = gfc_trans_array_bounds (type, sym, &offset, &block); + size = gfc_trans_array_bounds (type, sym, &offset, &init); /* Don't actually allocate space for Cray Pointees. */ if (sym->attr.cray_pointee) { if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* The size is the number of elements in the array, so multiply by the @@ -4383,31 +4371,27 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) fold_convert (gfc_array_index_type, tmp)); /* Allocate memory to hold the data. */ - tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size); - gfc_add_modify (&block, decl, tmp); + tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); + gfc_add_modify (&init, decl, tmp); /* Set offset of the array. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Automatic arrays should not have initializers. */ gcc_assert (!sym->value); - gfc_add_expr_to_block (&block, fnbody); - /* Free the temporary. */ tmp = gfc_call_free (convert (pvoid_type_node, decl)); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } /* Generate entry and exit code for g77 calling convention arrays. */ -tree -gfc_trans_g77_array (gfc_symbol * sym, tree body) +void +gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree parm; tree type; @@ -4415,7 +4399,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) tree offset; tree tmp; tree stmt; - stmtblock_t block; + stmtblock_t init; gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4425,31 +4409,29 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) type = TREE_TYPE (parm); gcc_assert (GFC_ARRAY_TYPE_P (type)); - gfc_start_block (&block); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); /* Evaluate the bounds of the array. */ - gfc_trans_array_bounds (type, sym, &offset, &block); + gfc_trans_array_bounds (type, sym, &offset, &init); /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Set the pointer itself if we aren't using the parameter directly. */ if (TREE_CODE (parm) != PARM_DECL) { tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); - gfc_add_modify (&block, parm, tmp); + gfc_add_modify (&init, parm, tmp); } - stmt = gfc_finish_block (&block); + stmt = gfc_finish_block (&init); gfc_set_backend_locus (&loc); - gfc_start_block (&block); - /* Add the initialization code to the start of the function. */ if (sym->attr.optional || sym->attr.not_always_present) @@ -4458,10 +4440,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - gfc_add_expr_to_block (&block, body); - - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmt, NULL_TREE); } @@ -4476,22 +4455,22 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) Code is also added to copy the data back at the end of the function. */ -tree -gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) +void +gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, + gfc_wrapped_block * block) { tree size; tree type; tree offset; locus loc; - stmtblock_t block; - stmtblock_t cleanup; + stmtblock_t init; + tree stmtInit, stmtCleanup; tree lbound; tree ubound; tree dubound; tree dlbound; tree dumdesc; tree tmp; - tree stmt; tree stride, stride2; tree stmt_packed; tree stmt_unpacked; @@ -4504,10 +4483,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) /* Do nothing for pointer and allocatable arrays. */ if (sym->attr.pointer || sym->attr.allocatable) - return body; + return; if (sym->attr.dummy && gfc_is_nodesc_array (sym)) - return gfc_trans_g77_array (sym, body); + { + gfc_trans_g77_array (sym, block); + return; + } gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4516,35 +4498,32 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) type = TREE_TYPE (tmpdesc); gcc_assert (GFC_ARRAY_TYPE_P (type)); dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref_loc (input_location, - dumdesc); - gfc_start_block (&block); + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); checkparm = (sym->as->type == AS_EXPLICIT && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) - || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); + || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) { /* For non-constant shape arrays we only check if the first dimension - is contiguous. Repacking higher dimensions wouldn't gain us - anything as we still don't know the array stride. */ + is contiguous. Repacking higher dimensions wouldn't gain us + anything as we still don't know the array stride. */ partial = gfc_create_var (boolean_type_node, "partial"); TREE_USED (partial) = 1; tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node); - gfc_add_modify (&block, partial, tmp); + gfc_add_modify (&init, partial, tmp); } else - { - partial = NULL_TREE; - } + partial = NULL_TREE; /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive here, however I think it does the right thing. */ @@ -4552,14 +4531,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) { /* Set the first stride. */ stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - stride = gfc_evaluate_now (stride, &block); + stride = gfc_evaluate_now (stride, &init); tmp = fold_build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node); tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp, gfc_index_one_node, stride); stride = GFC_TYPE_ARRAY_STRIDE (type, 0); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); /* Allow the user to disable array repacking. */ stmt_unpacked = NULL_TREE; @@ -4594,7 +4573,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) } else tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp)); + gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); offset = gfc_index_zero_node; size = gfc_index_one_node; @@ -4609,34 +4588,34 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); } else - { + { dubound = NULL_TREE; dlbound = NULL_TREE; - } + } lbound = GFC_TYPE_ARRAY_LBOUND (type, n); if (!INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, lbound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, sym->as->lower[n], + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, lbound, se.expr); + } ubound = GFC_TYPE_ARRAY_UBOUND (type, n); /* Set the desired upper bound. */ if (sym->as->upper[n]) { /* We know what we want the upper bound to be. */ - if (!INTEGER_CST_P (ubound)) - { + if (!INTEGER_CST_P (ubound)) + { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, sym->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, ubound, se.expr); - } + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, ubound, se.expr); + } /* Check the sizes match. */ if (checkparm) @@ -4655,11 +4634,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type, gfc_index_one_node, stride2); - tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); + tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); asprintf (&msg, "Dimension %d of array '%s' has extent " - "%%ld instead of %%ld", n+1, sym->name); + "%%ld instead of %%ld", n+1, sym->name); - gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg, + gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, fold_convert (long_integer_type_node, temp), fold_convert (long_integer_type_node, stride2)); @@ -4670,10 +4649,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) { /* For assumed shape arrays move the upper bound by the same amount as the lower bound. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); - gfc_add_modify (&block, ubound, tmp); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); + gfc_add_modify (&init, ubound, tmp); } /* The offset of this dimension. offset = offset - lbound * stride. */ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride); @@ -4681,41 +4660,39 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) /* The size of this dimension, and the stride of the next. */ if (n + 1 < sym->as->rank) - { - stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); + { + stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); - if (no_repack || partial != NULL_TREE) - { - stmt_unpacked = - gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - } + if (no_repack || partial != NULL_TREE) + stmt_unpacked = + gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - /* Figure out the stride if not a known constant. */ - if (!INTEGER_CST_P (stride)) - { - if (no_repack) - stmt_packed = NULL_TREE; - else - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + /* Figure out the stride if not a known constant. */ + if (!INTEGER_CST_P (stride)) + { + if (no_repack) + stmt_packed = NULL_TREE; + else + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, gfc_index_one_node, lbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); - stmt_packed = size; - } + stmt_packed = size; + } - /* Assign the stride. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + /* Assign the stride. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial, stmt_unpacked, stmt_packed); - else - tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, stride, tmp); - } - } + else + tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; + gfc_add_modify (&init, stride, tmp); + } + } else { stride = GFC_TYPE_ARRAY_SIZE (type); @@ -4729,20 +4706,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) ubound, tmp); tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); } } } /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_trans_vla_type_sizes (sym, &block); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - stmt = gfc_finish_block (&block); + gfc_trans_vla_type_sizes (sym, &init); - gfc_start_block (&block); + stmtInit = gfc_finish_block (&init); /* Only do the entry/initialization code if the arg is present. */ dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); @@ -4752,18 +4727,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) if (optional_arg) { tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtInit = build3_v (COND_EXPR, tmp, stmtInit, + build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - - /* Add the main function body. */ - gfc_add_expr_to_block (&block, body); /* Cleanup code. */ - if (!no_repack) + if (no_repack) + stmtCleanup = NULL_TREE; + else { + stmtblock_t cleanup; gfc_start_block (&cleanup); - + if (sym->attr.intent != INTENT_IN) { /* Copy the data back. */ @@ -4776,26 +4751,26 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) tmp = gfc_call_free (tmpdesc); gfc_add_expr_to_block (&cleanup, tmp); - stmt = gfc_finish_block (&cleanup); + stmtCleanup = gfc_finish_block (&cleanup); /* Only do the cleanup if the array was repacked. */ - tmp = build_fold_indirect_ref_loc (input_location, - dumdesc); + tmp = build_fold_indirect_ref_loc (input_location, dumdesc); tmp = gfc_conv_descriptor_data_get (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&block, stmt); + { + tmp = gfc_conv_expr_present (sym); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); + } } + /* We don't need to free any memory allocated by internal_pack as it will be freed at the end of the function by pop_context. */ - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmtInit, stmtCleanup); } @@ -5355,7 +5330,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gcc_assert (info->dim[dim] == n); /* Evaluate and remember the start of the section. */ - start = info->start[dim]; + start = info->start[n]; stride = gfc_evaluate_now (stride, &loop.pre); } @@ -5402,11 +5377,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) /* Multiply the stride by the section stride to get the total stride. */ stride = fold_build2 (MULT_EXPR, gfc_array_index_type, - stride, info->stride[dim]); + stride, info->stride[n]); if (se->direct_byref - && info->ref - && info->ref->u.ar.type != AR_FULL) + && info->ref + && info->ref->u.ar.type != AR_FULL) { base = fold_build2 (MINUS_EXPR, TREE_TYPE (base), base, stride); @@ -6265,13 +6240,14 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) Do likewise, recursively if necessary, with the allocatable components of derived types. */ -tree -gfc_trans_deferred_array (gfc_symbol * sym, tree body) +void +gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree type; tree tmp; tree descriptor; - stmtblock_t fnblock; + stmtblock_t init; + stmtblock_t cleanup; locus loc; int rank; bool sym_has_alloc_comp; @@ -6285,7 +6261,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) "allocatable attribute or derived type without allocatable " "components."); - gfc_init_block (&fnblock); + gfc_init_block (&init); gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL || TREE_CODE (sym->backend_decl) == PARM_DECL); @@ -6293,16 +6269,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock); - gfc_trans_vla_type_sizes (sym, &fnblock); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + gfc_trans_vla_type_sizes (sym, &init); } /* Dummy, use associated and result variables don't need anything special. */ if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) { - gfc_add_expr_to_block (&fnblock, body); - - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } gfc_get_backend_locus (&loc); @@ -6316,7 +6291,9 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); - return body; + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* Get the descriptor type. */ @@ -6331,14 +6308,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) || !gfc_has_default_initializer (sym->ts.u.derived)) { rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, + descriptor, rank); + gfc_add_expr_to_block (&init, tmp); } else - { - tmp = gfc_init_default_dt (sym, NULL, false); - gfc_add_expr_to_block (&fnblock, tmp); - } + gfc_init_default_dt (sym, &init, false); } } else if (!GFC_DESCRIPTOR_TYPE_P (type)) @@ -6346,16 +6321,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) /* If the backend_decl is not a descriptor, we must have a pointer to one. */ descriptor = build_fold_indirect_ref_loc (input_location, - sym->backend_decl); + sym->backend_decl); type = TREE_TYPE (descriptor); } /* NULLIFY the data pointer. */ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save) - gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node); - - gfc_add_expr_to_block (&fnblock, body); + gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + gfc_init_block (&cleanup); gfc_set_backend_locus (&loc); /* Allocatable arrays need to be freed when they go out of scope. @@ -6366,17 +6340,18 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) int rank; rank = sym->as ? sym->as->rank : 0; tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } if (sym->attr.allocatable && sym->attr.dimension && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); } /************ Expression Walking Functions ******************/ diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 44256fb86f4..2e491c8c16b 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -37,11 +37,11 @@ tree gfc_trans_create_temp_array (stmtblock_t *, stmtblock_t *, gfc_loopinfo *, /* Generate function entry code for allocation of compiler allocated array variables. */ -tree gfc_trans_auto_array_allocation (tree, gfc_symbol *, tree); +void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *); /* Generate entry and exit code for dummy array parameters. */ -tree gfc_trans_dummy_array_bias (gfc_symbol *, tree, tree); +void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ -tree gfc_trans_g77_array (gfc_symbol *, tree); +void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); /* Generate code to deallocate an array, if it is allocated. */ tree gfc_trans_dealloc_allocated (tree); @@ -58,7 +58,7 @@ tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int); tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int); /* Add initialization for deferred arrays. */ -tree gfc_trans_deferred_array (gfc_symbol *, tree); +void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *); /* Generate an initializer for a static pointer or allocatable array. */ void gfc_trans_static_array_pointer (gfc_symbol *); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 1162636fe5a..a19facb8317 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -432,7 +432,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) what C will do. */ tree field = NULL_TREE; field = TYPE_FIELDS (TREE_TYPE (decl)); - if (TREE_CHAIN (field) == NULL_TREE) + if (DECL_CHAIN (field) == NULL_TREE) DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field)); } DECL_USER_ALIGN (decl) = 0; @@ -608,7 +608,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) { is_init = true; *field_link = field; - field_link = &TREE_CHAIN (field); + field_link = &DECL_CHAIN (field); } for (s = head; s; s = s->next) @@ -617,7 +617,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) /* Link the field into the type. */ *field_link = s->field; - field_link = &TREE_CHAIN (s->field); + field_link = &DECL_CHAIN (s->field); /* Has initial value. */ if (s->sym->value) diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 6d4f222ede6..8cd4fda6d8d 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "tree.h" #include "realmpfr.h" -#include "toplev.h" /* For fatal_error. */ +#include "diagnostic-core.h" /* For fatal_error. */ #include "double-int.h" #include "gfortran.h" #include "trans.h" diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 1c7226c41e6..2b030110231 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -29,7 +29,8 @@ along with GCC; see the file COPYING3. If not see #include "tree-dump.h" #include "gimple.h" /* For create_tmp_var_raw. */ #include "ggc.h" -#include "toplev.h" /* For announce_function/internal_error. */ +#include "diagnostic-core.h" /* For internal_error. */ +#include "toplev.h" /* For announce_function. */ #include "output.h" /* For decl_default_tls_model. */ #include "target.h" #include "function.h" @@ -54,8 +55,6 @@ along with GCC; see the file COPYING3. If not see static GTY(()) tree current_fake_result_decl; static GTY(()) tree parent_fake_result_decl; -static GTY(()) tree current_function_return_label; - /* Holds the variable DECLs for the current function. */ @@ -74,6 +73,9 @@ static GTY(()) tree saved_local_decls; static gfc_namespace *module_namespace; +/* The currently processed procedure symbol. */ +static gfc_symbol* current_procedure_symbol = NULL; + /* List of static constructor functions. */ @@ -173,7 +175,7 @@ gfc_add_decl_to_parent_function (tree decl) gcc_assert (decl); DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl); DECL_NONLOCAL (decl) = 1; - TREE_CHAIN (decl) = saved_parent_function_decls; + DECL_CHAIN (decl) = saved_parent_function_decls; saved_parent_function_decls = decl; } @@ -183,7 +185,7 @@ gfc_add_decl_to_function (tree decl) gcc_assert (decl); TREE_USED (decl) = 1; DECL_CONTEXT (decl) = current_function_decl; - TREE_CHAIN (decl) = saved_function_decls; + DECL_CHAIN (decl) = saved_function_decls; saved_function_decls = decl; } @@ -193,7 +195,7 @@ add_decl_as_local (tree decl) gcc_assert (decl); TREE_USED (decl) = 1; DECL_CONTEXT (decl) = current_function_decl; - TREE_CHAIN (decl) = saved_local_decls; + DECL_CHAIN (decl) = saved_local_decls; saved_local_decls = decl; } @@ -236,28 +238,6 @@ gfc_build_label_decl (tree label_id) } -/* Returns the return label for the current function. */ - -tree -gfc_get_return_label (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 10]; - - if (current_function_return_label) - return current_function_return_label; - - sprintf (name, "__return_%s", - IDENTIFIER_POINTER (DECL_NAME (current_function_decl))); - - current_function_return_label = - gfc_build_label_decl (get_identifier (name)); - - DECL_ARTIFICIAL (current_function_return_label) = 1; - - return current_function_return_label; -} - - /* Set the backend source location of a decl. */ void @@ -779,16 +759,16 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) gtype = build_array_type (gtype, rtype); /* Ensure the bound variables aren't optimized out at -O0. For -O1 and above they often will be optimized out, but - can be tracked by VTA. Also clear the artificial - lbound.N or ubound.N DECL_NAME, so that it doesn't end up - in debug info. */ + can be tracked by VTA. Also set DECL_NAMELESS, so that + the artificial lbound.N or ubound.N DECL_NAME doesn't + end up in debug info. */ if (lbound && TREE_CODE (lbound) == VAR_DECL && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound)) { if (DECL_NAME (lbound) && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)), "lbound") != 0) - DECL_NAME (lbound) = NULL_TREE; + DECL_NAMELESS (lbound) = 1; DECL_IGNORED_P (lbound) = 0; } if (ubound && TREE_CODE (ubound) == VAR_DECL @@ -797,7 +777,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) if (DECL_NAME (ubound) && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)), "ubound") != 0) - DECL_NAME (ubound) = NULL_TREE; + DECL_NAMELESS (ubound) = 1; DECL_IGNORED_P (ubound) = 0; } } @@ -899,6 +879,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) VAR_DECL, get_identifier (name), type); DECL_ARTIFICIAL (decl) = 1; + DECL_NAMELESS (decl) = 1; TREE_PUBLIC (decl) = 0; TREE_STATIC (decl) = 0; DECL_EXTERNAL (decl) = 0; @@ -959,7 +940,7 @@ gfc_nonlocal_dummy_array_decl (gfc_symbol *sym) SET_DECL_VALUE_EXPR (decl, sym->backend_decl); DECL_HAS_VALUE_EXPR_P (decl) = 1; DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl); - TREE_CHAIN (decl) = nonlocal_dummy_decls; + DECL_CHAIN (decl) = nonlocal_dummy_decls; nonlocal_dummy_decls = decl; } @@ -1076,7 +1057,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) { gfc_component *c = CLASS_DATA (sym); if (!c->ts.u.derived->backend_decl) - gfc_find_derived_vtab (c->ts.u.derived, true); + gfc_find_derived_vtab (c->ts.u.derived); } if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref)) @@ -1090,7 +1071,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* For entry master function skip over the __entry argument. */ if (sym->ns->proc_name->attr.entry_master) - sym->backend_decl = TREE_CHAIN (sym->backend_decl); + sym->backend_decl = DECL_CHAIN (sym->backend_decl); } /* Dummy variables should already have been created. */ @@ -1980,8 +1961,6 @@ build_entry_thunks (gfc_namespace * ns) gfc_symbol *thunk_sym; stmtblock_t body; tree thunk_fndecl; - tree args; - tree string_args; tree tmp; locus old_loc; @@ -1991,6 +1970,9 @@ build_entry_thunks (gfc_namespace * ns) gfc_get_backend_locus (&old_loc); for (el = ns->entries; el; el = el->next) { + VEC(tree,gc) *args = NULL; + VEC(tree,gc) *string_args = NULL; + thunk_sym = el->sym; build_function_decl (thunk_sym); @@ -2004,18 +1986,16 @@ build_entry_thunks (gfc_namespace * ns) /* Pass extra parameter identifying this entry point. */ tmp = build_int_cst (gfc_array_index_type, el->id); - args = tree_cons (NULL_TREE, tmp, NULL_TREE); - string_args = NULL_TREE; + VEC_safe_push (tree, gc, args, tmp); if (thunk_sym->attr.function) { if (gfc_return_by_reference (ns->proc_name)) { tree ref = DECL_ARGUMENTS (current_function_decl); - args = tree_cons (NULL_TREE, ref, args); + VEC_safe_push (tree, gc, args, ref); if (ns->proc_name->ts.type == BT_CHARACTER) - args = tree_cons (NULL_TREE, TREE_CHAIN (ref), - args); + VEC_safe_push (tree, gc, args, DECL_CHAIN (ref)); } } @@ -2039,31 +2019,29 @@ build_entry_thunks (gfc_namespace * ns) { /* Pass the argument. */ DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1; - args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl, - args); + VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl); if (formal->sym->ts.type == BT_CHARACTER) { tmp = thunk_formal->sym->ts.u.cl->backend_decl; - string_args = tree_cons (NULL_TREE, tmp, string_args); + VEC_safe_push (tree, gc, string_args, tmp); } } else { /* Pass NULL for a missing argument. */ - args = tree_cons (NULL_TREE, null_pointer_node, args); + VEC_safe_push (tree, gc, args, null_pointer_node); if (formal->sym->ts.type == BT_CHARACTER) { tmp = build_int_cst (gfc_charlen_type_node, 0); - string_args = tree_cons (NULL_TREE, tmp, string_args); + VEC_safe_push (tree, gc, string_args, tmp); } } } /* Call the master function. */ - args = nreverse (args); - args = chainon (args, nreverse (string_args)); + VEC_safe_splice (tree, gc, args, string_args); tmp = ns->proc_name->backend_decl; - tmp = build_function_call_expr (input_location, tmp, args); + tmp = build_call_expr_loc_vec (input_location, tmp, args); if (ns->proc_name->attr.mixed_entry_master) { tree union_decl, field; @@ -2085,7 +2063,7 @@ build_entry_thunks (gfc_namespace * ns) gfc_add_expr_to_block (&body, tmp); for (field = TYPE_FIELDS (TREE_TYPE (union_decl)); - field; field = TREE_CHAIN (field)) + field; field = DECL_CHAIN (field)) if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), thunk_sym->result->name) == 0) break; @@ -2221,7 +2199,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) tree field; for (field = TYPE_FIELDS (TREE_TYPE (decl)); - field; field = TREE_CHAIN (field)) + field; field = DECL_CHAIN (field)) if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), sym->name) == 0) break; @@ -2272,7 +2250,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) if (sym->ns->proc_name->backend_decl == this_function_decl && sym->ns->proc_name->attr.entry_master) - decl = TREE_CHAIN (decl); + decl = DECL_CHAIN (decl); TREE_USED (decl) = 1; if (sym->as) @@ -2387,7 +2365,7 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) The SPEC parameter specifies the function argument and return type specification according to the fnspec function type attribute. */ -static tree +tree gfc_build_library_function_decl_with_spec (tree name, const char *spec, tree rettype, int nargs, ...) { @@ -2410,212 +2388,176 @@ gfc_build_intrinsic_function_decls (void) tree pchar4_type_node = gfc_get_pchar_type (4); /* String functions. */ - gfor_fndecl_compare_string = - gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")), - integer_type_node, 4, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_concat_string = - gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")), - void_type_node, 6, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_string_len_trim = - gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")), - 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_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_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_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_trim = - gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")), - void_type_node, 4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar1_type_node), - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_string_minmax = - gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")), - void_type_node, -4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar1_type_node), - integer_type_node, integer_type_node); - - gfor_fndecl_adjustl = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")), - void_type_node, 3, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_adjustr = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")), - void_type_node, 3, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_select_string = - gfc_build_library_function_decl (get_identifier (PREFIX("select_string")), - integer_type_node, 4, pvoid_type_node, - integer_type_node, pchar1_type_node, - gfc_charlen_type_node); - - gfor_fndecl_compare_string_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("compare_string_char4")), - integer_type_node, 4, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_concat_string_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("concat_string_char4")), - void_type_node, 6, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_string_len_trim_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_len_trim_char4")), - gfc_charlen_type_node, 2, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_string_index_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_index_char4")), - gfc_charlen_type_node, 5, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_scan_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_scan_char4")), - gfc_charlen_type_node, 5, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_verify_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_verify_char4")), - gfc_charlen_type_node, 5, - gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, - gfc_logical4_type_node); - - gfor_fndecl_string_trim_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_trim_char4")), - void_type_node, 4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar4_type_node), - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_string_minmax_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("string_minmax_char4")), - void_type_node, -4, - build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar4_type_node), - integer_type_node, integer_type_node); - - gfor_fndecl_adjustl_char4 = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")), - void_type_node, 3, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_adjustr_char4 = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")), - void_type_node, 3, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - - gfor_fndecl_select_string_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("select_string_char4")), - integer_type_node, 4, pvoid_type_node, - integer_type_node, pvoid_type_node, - gfc_charlen_type_node); + gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("compare_string")), "..R.R", + integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + DECL_PURE_P (gfor_fndecl_compare_string) = 1; + + gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("concat_string")), "..W.R.R", + void_type_node, 6, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + + gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_len_trim")), "..R", + gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node); + DECL_PURE_P (gfor_fndecl_string_len_trim) = 1; + + gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_index")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_index) = 1; + + gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_scan")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_scan) = 1; + + gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_verify")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_verify) = 1; + + gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_trim")), ".Ww.R", + void_type_node, 4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), gfc_charlen_type_node, + pchar1_type_node); + + gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_minmax")), ".Ww.R", + void_type_node, -4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), integer_type_node, + integer_type_node); + + gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustl")), ".W.R", + void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, + pchar1_type_node); + + gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustr")), ".W.R", + void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, + pchar1_type_node); + + gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("select_string")), ".R.R.", + integer_type_node, 4, pvoid_type_node, integer_type_node, + pchar1_type_node, gfc_charlen_type_node); + DECL_PURE_P (gfor_fndecl_select_string) = 1; + + gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("compare_string_char4")), "..R.R", + integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1; + + gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("concat_string_char4")), "..W.R.R", + void_type_node, 6, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + + gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_len_trim_char4")), "..R", + gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node); + DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1; + + gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_index_char4")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_index_char4) = 1; + + gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_scan_char4")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1; + + gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_verify_char4")), "..R.R.", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1; + + gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_trim_char4")), ".Ww.R", + void_type_node, 4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), gfc_charlen_type_node, + pchar4_type_node); + + gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_minmax_char4")), ".Ww.R", + void_type_node, -4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), integer_type_node, + integer_type_node); + + gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustl_char4")), ".W.R", + void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + + gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustr_char4")), ".W.R", + void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + + gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("select_string_char4")), ".R.R.", + integer_type_node, 4, pvoid_type_node, integer_type_node, + pvoid_type_node, gfc_charlen_type_node); + DECL_PURE_P (gfor_fndecl_select_string_char4) = 1; /* Conversion between character kinds. */ - gfor_fndecl_convert_char1_to_char4 = - gfc_build_library_function_decl (get_identifier - (PREFIX("convert_char1_to_char4")), - void_type_node, 3, - build_pointer_type (pchar4_type_node), - gfc_charlen_type_node, pchar1_type_node); + gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("convert_char1_to_char4")), ".w.R", + void_type_node, 3, build_pointer_type (pchar4_type_node), + gfc_charlen_type_node, pchar1_type_node); - gfor_fndecl_convert_char4_to_char1 = - gfc_build_library_function_decl (get_identifier - (PREFIX("convert_char4_to_char1")), - void_type_node, 3, - build_pointer_type (pchar1_type_node), - gfc_charlen_type_node, pchar4_type_node); + gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("convert_char4_to_char1")), ".w.R", + void_type_node, 3, build_pointer_type (pchar1_type_node), + gfc_charlen_type_node, pchar4_type_node); /* Misc. functions. */ - gfor_fndecl_ttynam = - gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")), - void_type_node, - 3, - pchar_type_node, - gfc_charlen_type_node, - integer_type_node); - - gfor_fndecl_fdate = - gfc_build_library_function_decl (get_identifier (PREFIX("fdate")), - void_type_node, - 2, - pchar_type_node, - gfc_charlen_type_node); - - gfor_fndecl_ctime = - gfc_build_library_function_decl (get_identifier (PREFIX("ctime")), - void_type_node, - 3, - pchar_type_node, - gfc_charlen_type_node, - gfc_int8_type_node); - - gfor_fndecl_sc_kind = - gfc_build_library_function_decl (get_identifier - (PREFIX("selected_char_kind")), - gfc_int4_type_node, 2, - gfc_charlen_type_node, pchar_type_node); - - gfor_fndecl_si_kind = - gfc_build_library_function_decl (get_identifier - (PREFIX("selected_int_kind")), - gfc_int4_type_node, 1, pvoid_type_node); - - gfor_fndecl_sr_kind = - gfc_build_library_function_decl (get_identifier - (PREFIX("selected_real_kind2008")), - gfc_int4_type_node, 3, - pvoid_type_node, pvoid_type_node, - pvoid_type_node); + gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("ttynam")), ".W", + void_type_node, 3, pchar_type_node, gfc_charlen_type_node, + integer_type_node); + + gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("fdate")), ".W", + void_type_node, 2, pchar_type_node, gfc_charlen_type_node); + + gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("ctime")), ".W", + void_type_node, 3, pchar_type_node, gfc_charlen_type_node, + gfc_int8_type_node); + + gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_char_kind")), "..R", + gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node); + DECL_PURE_P (gfor_fndecl_sc_kind) = 1; + + gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_int_kind")), ".R", + gfc_int4_type_node, 1, pvoid_type_node); + DECL_PURE_P (gfor_fndecl_si_kind) = 1; + + gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_real_kind2008")), ".RR", + gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node, + pvoid_type_node); + DECL_PURE_P (gfor_fndecl_sr_kind) = 1; /* Power functions. */ { @@ -2674,23 +2616,21 @@ gfc_build_intrinsic_function_decls (void) #undef NRKINDS } - gfor_fndecl_math_ishftc4 = - gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")), - gfc_int4_type_node, - 3, gfc_int4_type_node, - gfc_int4_type_node, gfc_int4_type_node); - gfor_fndecl_math_ishftc8 = - gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")), - gfc_int8_type_node, - 3, gfc_int8_type_node, - gfc_int4_type_node, gfc_int4_type_node); + gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc4")), + gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node, + gfc_int4_type_node); + + gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc8")), + gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node, + gfc_int4_type_node); + if (gfc_int16_type_node) - gfor_fndecl_math_ishftc16 = - gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")), - gfc_int16_type_node, 3, - gfc_int16_type_node, - gfc_int4_type_node, - gfc_int4_type_node); + gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc16")), + gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node, + gfc_int4_type_node); /* BLAS functions. */ { @@ -2736,32 +2676,30 @@ gfc_build_intrinsic_function_decls (void) } /* Other functions. */ - gfor_fndecl_size0 = - gfc_build_library_function_decl (get_identifier (PREFIX("size0")), - gfc_array_index_type, - 1, pvoid_type_node); - gfor_fndecl_size1 = - gfc_build_library_function_decl (get_identifier (PREFIX("size1")), - gfc_array_index_type, - 2, pvoid_type_node, - gfc_array_index_type); - - gfor_fndecl_iargc = - gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")), - gfc_int4_type_node, - 0); + gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("size0")), ".R", + gfc_array_index_type, 1, pvoid_type_node); + DECL_PURE_P (gfor_fndecl_size0) = 1; + + gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("size1")), ".R", + gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type); + DECL_PURE_P (gfor_fndecl_size1) = 1; + + gfor_fndecl_iargc = gfc_build_library_function_decl ( + get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); if (gfc_type_for_size (128, true)) { tree uint128 = gfc_type_for_size (128, true); - gfor_fndecl_clz128 = - gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")), - integer_type_node, 1, uint128); + gfor_fndecl_clz128 = gfc_build_library_function_decl ( + get_identifier (PREFIX ("clz128")), integer_type_node, 1, uint128); + TREE_READONLY (gfor_fndecl_clz128) = 1; - gfor_fndecl_ctz128 = - gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")), - integer_type_node, 1, uint128); + gfor_fndecl_ctz128 = gfc_build_library_function_decl ( + get_identifier (PREFIX ("ctz128")), integer_type_node, 1, uint128); + TREE_READONLY (gfor_fndecl_ctz128) = 1; } } @@ -2773,113 +2711,104 @@ gfc_build_builtin_function_decls (void) { tree gfc_int4_type_node = gfc_get_int_type (4); - gfor_fndecl_stop_numeric = - gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")), - void_type_node, 1, gfc_int4_type_node); + gfor_fndecl_stop_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("stop_numeric")), + void_type_node, 1, gfc_int4_type_node); /* STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; - - gfor_fndecl_stop_string = - gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")), - void_type_node, 2, pchar_type_node, - gfc_int4_type_node); + gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("stop_string")), ".R.", + void_type_node, 2, pchar_type_node, gfc_int4_type_node); /* STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; - - gfor_fndecl_error_stop_numeric = - gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_numeric")), - void_type_node, 1, gfc_int4_type_node); + gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("error_stop_numeric")), + void_type_node, 1, gfc_int4_type_node); /* ERROR STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1; - - gfor_fndecl_error_stop_string = - gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")), - void_type_node, 2, pchar_type_node, - gfc_int4_type_node); + gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("error_stop_string")), ".R.", + void_type_node, 2, pchar_type_node, gfc_int4_type_node); /* ERROR STOP doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; + gfor_fndecl_pause_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("pause_numeric")), + void_type_node, 1, gfc_int4_type_node); - gfor_fndecl_pause_numeric = - gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")), - void_type_node, 1, gfc_int4_type_node); - - gfor_fndecl_pause_string = - gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")), - void_type_node, 2, pchar_type_node, - gfc_int4_type_node); + gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("pause_string")), ".R.", + void_type_node, 2, pchar_type_node, gfc_int4_type_node); - gfor_fndecl_runtime_error = - gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")), - void_type_node, -1, pchar_type_node); + gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_error")), ".R", + void_type_node, -1, pchar_type_node); /* The runtime_error function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; - gfor_fndecl_runtime_error_at = - gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")), - void_type_node, -2, pchar_type_node, - pchar_type_node); + gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_error_at")), ".RR", + void_type_node, -2, pchar_type_node, pchar_type_node); /* The runtime_error_at function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; - gfor_fndecl_runtime_warning_at = - gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")), - void_type_node, -2, pchar_type_node, - pchar_type_node); - gfor_fndecl_generate_error = - gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")), - void_type_node, 3, pvoid_type_node, - integer_type_node, pchar_type_node); - - gfor_fndecl_os_error = - gfc_build_library_function_decl (get_identifier (PREFIX("os_error")), - void_type_node, 1, pchar_type_node); + gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_warning_at")), ".RR", + void_type_node, -2, pchar_type_node, pchar_type_node); + + gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("generate_error")), ".R.R", + void_type_node, 3, pvoid_type_node, integer_type_node, + pchar_type_node); + + gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("os_error")), ".R", + void_type_node, 1, pchar_type_node); /* The runtime_error function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1; - gfor_fndecl_set_args = - gfc_build_library_function_decl (get_identifier (PREFIX("set_args")), - void_type_node, 2, integer_type_node, - build_pointer_type (pchar_type_node)); + gfor_fndecl_set_args = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_args")), + void_type_node, 2, integer_type_node, + build_pointer_type (pchar_type_node)); - gfor_fndecl_set_fpe = - gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_fpe = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_fpe")), + void_type_node, 1, integer_type_node); /* Keep the array dimension in sync with the call, later in this file. */ - gfor_fndecl_set_options = - gfc_build_library_function_decl (get_identifier (PREFIX("set_options")), - void_type_node, 2, integer_type_node, - build_pointer_type (integer_type_node)); + gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("set_options")), "..R", + void_type_node, 2, integer_type_node, + build_pointer_type (integer_type_node)); - gfor_fndecl_set_convert = - gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_convert = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_convert")), + void_type_node, 1, integer_type_node); - gfor_fndecl_set_record_marker = - gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_record_marker = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_record_marker")), + void_type_node, 1, integer_type_node); - gfor_fndecl_set_max_subrecord_length = - gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")), - void_type_node, 1, integer_type_node); + gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_max_subrecord_length")), + void_type_node, 1, integer_type_node); gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("internal_pack")), ".r", - pvoid_type_node, 1, pvoid_type_node); + get_identifier (PREFIX("internal_pack")), ".r", + pvoid_type_node, 1, pvoid_type_node); gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("internal_unpack")), ".wR", - void_type_node, 2, pvoid_type_node, pvoid_type_node); + get_identifier (PREFIX("internal_unpack")), ".wR", + void_type_node, 2, pvoid_type_node, pvoid_type_node); - gfor_fndecl_associated = - gfc_build_library_function_decl ( - get_identifier (PREFIX("associated")), - integer_type_node, 2, ppvoid_type_node, - ppvoid_type_node); + gfor_fndecl_associated = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("associated")), ".RR", + integer_type_node, 2, ppvoid_type_node, ppvoid_type_node); + DECL_PURE_P (gfor_fndecl_associated) = 1; gfc_build_intrinsic_function_decls (); gfc_build_intrinsic_lib_fndecls (); @@ -2889,72 +2818,70 @@ gfc_build_builtin_function_decls (void) /* Evaluate the length of dummy character variables. */ -static tree -gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody) +static void +gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, + gfc_wrapped_block *block) { - stmtblock_t body; + stmtblock_t init; gfc_finish_decl (cl->backend_decl); - gfc_start_block (&body); + gfc_start_block (&init); /* Evaluate the string length expression. */ - gfc_conv_string_length (cl, NULL, &body); + gfc_conv_string_length (cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &body); + gfc_trans_vla_type_sizes (sym, &init); - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } /* Allocate and cleanup an automatic character variable. */ -static tree -gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody) +static void +gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block) { - stmtblock_t body; + stmtblock_t init; tree decl; tree tmp; gcc_assert (sym->backend_decl); gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length); - gfc_start_block (&body); + gfc_start_block (&init); /* Evaluate the string length expression. */ - gfc_conv_string_length (sym->ts.u.cl, NULL, &body); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &body); + gfc_trans_vla_type_sizes (sym, &init); decl = sym->backend_decl; /* Emit a DECL_EXPR for this variable, which will cause the gimplifier to allocate storage, and all that good stuff. */ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&body, tmp); + gfc_add_expr_to_block (&init, tmp); - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */ -static tree -gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody) +static void +gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block) { - stmtblock_t body; + stmtblock_t init; gcc_assert (sym->backend_decl); - gfc_start_block (&body); + gfc_start_block (&init); /* Set the initial value to length. See the comments in function gfc_add_assign_aux_vars in this file. */ - gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl), - build_int_cst (NULL_TREE, -2)); + gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl), + build_int_cst (NULL_TREE, -2)); - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } static void @@ -3067,15 +2994,15 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) /* Initialize a derived type by building an lvalue from the symbol and using trans_assignment to do the work. Set dealloc to false if no deallocation prior the assignment is needed. */ -tree -gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc) +void +gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) { - stmtblock_t fnblock; gfc_expr *e; tree tmp; tree present; - gfc_init_block (&fnblock); + gcc_assert (block); + gcc_assert (!sym->attr.allocatable); gfc_set_sym_referenced (sym); e = gfc_lval_expr_from_sym (sym); @@ -3087,11 +3014,8 @@ gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc) tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (block, tmp); gfc_free_expr (e); - if (body) - gfc_add_expr_to_block (&fnblock, body); - return gfc_finish_block (&fnblock); } @@ -3099,15 +3023,15 @@ gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc) them their default initializer, if they do not have allocatable components, they have their allocatable components deallocated. */ -static tree -init_intent_out_dt (gfc_symbol * proc_sym, tree body) +static void +init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) { - stmtblock_t fnblock; + stmtblock_t init; gfc_formal_arglist *f; tree tmp; tree present; - gfc_init_block (&fnblock); + gfc_init_block (&init); for (f = proc_sym->formal; f; f = f->next) if (f->sym && f->sym->attr.intent == INTENT_OUT && !f->sym->attr.pointer @@ -3127,14 +3051,13 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body) tmp, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&init, tmp); } else if (f->sym->value) - body = gfc_init_default_dt (f->sym, body, true); + gfc_init_default_dt (f->sym, &init, true); } - gfc_add_expr_to_block (&fnblock, body); - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } @@ -3146,13 +3069,13 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body) Initialization of ASSIGN statement auxiliary variable. Automatic deallocation. */ -tree -gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) +void +gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) { locus loc; gfc_symbol *sym; gfc_formal_arglist *f; - stmtblock_t body; + stmtblock_t tmpblock; bool seen_trans_deferred_array = false; /* Deal with implicit return variables. Explicit return variables will @@ -3176,19 +3099,17 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) else if (proc_sym->as) { tree result = TREE_VALUE (current_fake_result_decl); - fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody); + gfc_trans_dummy_array_bias (proc_sym, result, block); /* An automatic character length, pointer array result. */ if (proc_sym->ts.type == BT_CHARACTER && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) - fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, - fnbody); + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); } else if (proc_sym->ts.type == BT_CHARACTER) { if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) - fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, - fnbody); + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); } else gcc_assert (gfc_option.flag_f2c @@ -3198,7 +3119,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) /* Initialize the INTENT(OUT) derived type dummy arguments. This should be done here so that the offsets and lbounds of arrays are available. */ - fnbody = init_intent_out_dt (proc_sym, fnbody); + init_intent_out_dt (proc_sym, block); for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) { @@ -3210,8 +3131,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) { case AS_EXPLICIT: if (sym->attr.dummy || sym->attr.result) - fnbody = - gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody); + gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); else if (sym->attr.pointer || sym->attr.allocatable) { if (TREE_STATIC (sym->backend_decl)) @@ -3219,7 +3139,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) else { seen_trans_deferred_array = true; - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, block); } } else @@ -3227,18 +3147,24 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) if (sym_has_alloc_comp) { seen_trans_deferred_array = true; - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, block); } else if (sym->ts.type == BT_DERIVED && sym->value && !sym->attr.data && sym->attr.save == SAVE_NONE) - fnbody = gfc_init_default_dt (sym, fnbody, false); + { + gfc_start_block (&tmpblock); + gfc_init_default_dt (sym, &tmpblock, false); + gfc_add_init_cleanup (block, + gfc_finish_block (&tmpblock), + NULL_TREE); + } gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); - fnbody = gfc_trans_auto_array_allocation (sym->backend_decl, - sym, fnbody); + gfc_trans_auto_array_allocation (sym->backend_decl, + sym, block); gfc_set_backend_locus (&loc); } break; @@ -3249,27 +3175,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) /* We should always pass assumed size arrays the g77 way. */ if (sym->attr.dummy) - fnbody = gfc_trans_g77_array (sym, fnbody); - break; + gfc_trans_g77_array (sym, block); + break; case AS_ASSUMED_SHAPE: /* Must be a dummy parameter. */ gcc_assert (sym->attr.dummy); - fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl, - fnbody); + gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); break; case AS_DEFERRED: seen_trans_deferred_array = true; - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, block); break; default: gcc_unreachable (); } if (sym_has_alloc_comp && !seen_trans_deferred_array) - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, block); } else if (sym->attr.allocatable || (sym->ts.type == BT_CLASS @@ -3282,7 +3207,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) tree tmp; gfc_expr *e; gfc_se se; - stmtblock_t block; + stmtblock_t init; e = gfc_lval_expr_from_sym (sym); if (sym->ts.type == BT_CLASS) @@ -3294,49 +3219,54 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) gfc_free_expr (e); /* Nullify when entering the scope. */ - gfc_start_block (&block); - gfc_add_modify (&block, se.expr, + gfc_start_block (&init); + gfc_add_modify (&init, se.expr, fold_convert (TREE_TYPE (se.expr), null_pointer_node)); - gfc_add_expr_to_block (&block, fnbody); /* Deallocate when leaving the scope. Nullifying is not needed. */ - tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, - NULL); - gfc_add_expr_to_block (&block, tmp); - fnbody = gfc_finish_block (&block); + tmp = NULL; + if (!sym->attr.result) + tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, + true, NULL); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } } else if (sym_has_alloc_comp) - fnbody = gfc_trans_deferred_array (sym, fnbody); + gfc_trans_deferred_array (sym, block); else if (sym->ts.type == BT_CHARACTER) { gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); if (sym->attr.dummy || sym->attr.result) - fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody); + gfc_trans_dummy_character (sym, sym->ts.u.cl, block); else - fnbody = gfc_trans_auto_character_variable (sym, fnbody); + gfc_trans_auto_character_variable (sym, block); gfc_set_backend_locus (&loc); } else if (sym->attr.assign) { gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); - fnbody = gfc_trans_assign_aux_var (sym, fnbody); + gfc_trans_assign_aux_var (sym, block); gfc_set_backend_locus (&loc); } else if (sym->ts.type == BT_DERIVED && sym->value && !sym->attr.data && sym->attr.save == SAVE_NONE) - fnbody = gfc_init_default_dt (sym, fnbody, false); + { + gfc_start_block (&tmpblock); + gfc_init_default_dt (sym, &tmpblock, false); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), + NULL_TREE); + } else gcc_unreachable (); } - gfc_init_block (&body); + gfc_init_block (&tmpblock); for (f = proc_sym->formal; f; f = f->next) { @@ -3344,7 +3274,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) { gcc_assert (f->sym->ts.u.cl->backend_decl != NULL); if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL) - gfc_trans_vla_type_sizes (f->sym, &body); + gfc_trans_vla_type_sizes (f->sym, &tmpblock); } } @@ -3353,11 +3283,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) { gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL); if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL) - gfc_trans_vla_type_sizes (proc_sym, &body); + gfc_trans_vla_type_sizes (proc_sym, &tmpblock); } - gfc_add_expr_to_block (&body, fnbody); - return gfc_finish_block (&body); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } static GTY ((param_is (struct module_htab_entry))) htab_t module_htab; @@ -4355,6 +4284,56 @@ create_main_function (tree fndecl) } +/* Get the result expression for a procedure. */ + +static tree +get_proc_result (gfc_symbol* sym) +{ + if (sym->attr.subroutine || sym == sym->result) + { + if (current_fake_result_decl != NULL) + return TREE_VALUE (current_fake_result_decl); + + return NULL_TREE; + } + + return sym->result->backend_decl; +} + + +/* Generate an appropriate return-statement for a procedure. */ + +tree +gfc_generate_return (void) +{ + gfc_symbol* sym; + tree result; + tree fndecl; + + sym = current_procedure_symbol; + fndecl = sym->backend_decl; + + if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node) + result = NULL_TREE; + else + { + result = get_proc_result (sym); + + /* Set the return value to the dummy result variable. The + types may be different for scalar default REAL functions + with -ff2c, therefore we have to convert. */ + if (result != NULL_TREE) + { + result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result); + result = fold_build2 (MODIFY_EXPR, TREE_TYPE (result), + DECL_RESULT (fndecl), result); + } + } + + return build1_v (RETURN_EXPR, result); +} + + /* Generate code for a function. */ void @@ -4364,16 +4343,18 @@ gfc_generate_function_code (gfc_namespace * ns) tree old_context; tree decl; tree tmp; - tree tmp2; - stmtblock_t block; + stmtblock_t init, cleanup; stmtblock_t body; - tree result; + gfc_wrapped_block try_block; tree recurcheckvar = NULL_TREE; gfc_symbol *sym; + gfc_symbol *previous_procedure_symbol; int rank; bool is_recursive; sym = ns->proc_name; + previous_procedure_symbol = current_procedure_symbol; + current_procedure_symbol = sym; /* Check that the frontend isn't still using this. */ gcc_assert (sym->tlink == NULL); @@ -4395,7 +4376,7 @@ gfc_generate_function_code (gfc_namespace * ns) trans_function_start (sym); - gfc_init_block (&block); + gfc_init_block (&init); if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) { @@ -4434,34 +4415,32 @@ gfc_generate_function_code (gfc_namespace * ns) else current_fake_result_decl = NULL_TREE; - current_function_return_label = NULL; + is_recursive = sym->attr.recursive + || (sym->attr.entry_master + && sym->ns->entries->sym->attr.recursive); + if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) + && !is_recursive + && !gfc_option.flag_recursive) + { + char * msg; + + asprintf (&msg, "Recursive call to nonrecursive procedure '%s'", + sym->name); + recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive"); + TREE_STATIC (recurcheckvar) = 1; + DECL_INITIAL (recurcheckvar) = boolean_false_node; + gfc_add_expr_to_block (&init, recurcheckvar); + gfc_trans_runtime_check (true, false, recurcheckvar, &init, + &sym->declared_at, msg); + gfc_add_modify (&init, recurcheckvar, boolean_true_node); + gfc_free (msg); + } /* Now generate the code for the body of this function. */ gfc_init_block (&body); - is_recursive = sym->attr.recursive - || (sym->attr.entry_master - && sym->ns->entries->sym->attr.recursive); - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive - && !gfc_option.flag_recursive) - { - char * msg; - - asprintf (&msg, "Recursive call to nonrecursive procedure '%s'", - sym->name); - recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive"); - TREE_STATIC (recurcheckvar) = 1; - DECL_INITIAL (recurcheckvar) = boolean_false_node; - gfc_add_expr_to_block (&block, recurcheckvar); - gfc_trans_runtime_check (true, false, recurcheckvar, &block, - &sym->declared_at, msg); - gfc_add_modify (&block, recurcheckvar, boolean_true_node); - gfc_free (msg); - } - if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node - && sym->attr.subroutine) + && sym->attr.subroutine) { tree alternate_return; alternate_return = gfc_get_fake_result_decl (sym, 0); @@ -4484,29 +4463,9 @@ gfc_generate_function_code (gfc_namespace * ns) tmp = gfc_trans_code (ns->code); gfc_add_expr_to_block (&body, tmp); - /* Add a return label if needed. */ - if (current_function_return_label) - { - tmp = build1_v (LABEL_EXPR, current_function_return_label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_finish_block (&body); - /* Add code to create and cleanup arrays. */ - tmp = gfc_trans_deferred_vars (sym, tmp); - if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node) { - if (sym->attr.subroutine || sym == sym->result) - { - if (current_fake_result_decl != NULL) - result = TREE_VALUE (current_fake_result_decl); - else - result = NULL_TREE; - current_fake_result_decl = NULL_TREE; - } - else - result = sym->result->backend_decl; + tree result = get_proc_result (sym); if (result != NULL_TREE && sym->attr.function @@ -4516,24 +4475,12 @@ gfc_generate_function_code (gfc_namespace * ns) && sym->ts.u.derived->attr.alloc_comp) { rank = sym->as ? sym->as->rank : 0; - tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank); - gfc_add_expr_to_block (&block, tmp2); + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank); + gfc_add_expr_to_block (&init, tmp); } else if (sym->attr.allocatable && sym->attr.dimension == 0) - gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result), - null_pointer_node)); - } - - gfc_add_expr_to_block (&block, tmp); - - /* Reset recursion-check variable. */ - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive - && !gfc_option.flag_openmp - && recurcheckvar != NULL_TREE) - { - gfc_add_modify (&block, recurcheckvar, boolean_false_node); - recurcheckvar = NULL; + gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result), + null_pointer_node)); } if (result == NULL_TREE) @@ -4546,31 +4493,28 @@ gfc_generate_function_code (gfc_namespace * ns) TREE_NO_WARNING(sym->backend_decl) = 1; } else - { - /* Set the return value to the dummy result variable. The - types may be different for scalar default REAL functions - with -ff2c, therefore we have to convert. */ - tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result); - tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), - DECL_RESULT (fndecl), tmp); - tmp = build1_v (RETURN_EXPR, tmp); - gfc_add_expr_to_block (&block, tmp); - } + gfc_add_expr_to_block (&body, gfc_generate_return ()); } - else + + gfc_init_block (&cleanup); + + /* Reset recursion-check variable. */ + if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) + && !is_recursive + && !gfc_option.flag_openmp + && recurcheckvar != NULL_TREE) { - gfc_add_expr_to_block (&block, tmp); - /* Reset recursion-check variable. */ - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive - && !gfc_option.flag_openmp - && recurcheckvar != NULL_TREE) - { - gfc_add_modify (&block, recurcheckvar, boolean_false_node); - recurcheckvar = NULL_TREE; - } + gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node); + recurcheckvar = NULL; } + /* Finish the function body and add init and cleanup code. */ + tmp = gfc_finish_block (&body); + gfc_start_wrapped_block (&try_block, tmp); + /* Add code to create and cleanup arrays. */ + gfc_trans_deferred_vars (sym, &try_block); + gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); /* Add all the decls we created during processing. */ decl = saved_function_decls; @@ -4578,14 +4522,14 @@ gfc_generate_function_code (gfc_namespace * ns) { tree next; - next = TREE_CHAIN (decl); - TREE_CHAIN (decl) = NULL_TREE; + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; pushdecl (decl); decl = next; } saved_function_decls = NULL_TREE; - DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block); + DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block); decl = getdecls (); /* Finish off this function and send it for code generation. */ @@ -4636,6 +4580,8 @@ gfc_generate_function_code (gfc_namespace * ns) if (sym->attr.is_main_program) create_main_function (fndecl); + + current_procedure_symbol = previous_procedure_symbol; } @@ -4757,8 +4703,8 @@ gfc_process_block_locals (gfc_namespace* ns) { tree next; - next = TREE_CHAIN (decl); - TREE_CHAIN (decl) = NULL_TREE; + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; pushdecl (decl); decl = next; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 692b3e2f846..a83d4b3eda4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "toplev.h" /* For fatal_error. */ +#include "diagnostic-core.h" /* For fatal_error. */ #include "langhooks.h" #include "flags.h" #include "gfortran.h" @@ -1365,7 +1365,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, rse.string_length, rse.expr, - expr->value.op.op1->ts.kind); + expr->value.op.op1->ts.kind, + code); rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0); gfc_add_block_to_block (&lse.post, &rse.post); } @@ -1388,17 +1389,45 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) /* If a string's length is one, we convert it to a single character. */ -static tree -string_to_single_character (tree len, tree str, int kind) +tree +gfc_string_to_single_character (tree len, tree str, int kind) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (str))); - if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1 - && TREE_INT_CST_HIGH (len) == 0) + if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0) + return NULL_TREE; + + if (TREE_INT_CST_LOW (len) == 1) { str = fold_convert (gfc_get_pchar_type (kind), str); - return build_fold_indirect_ref_loc (input_location, - str); + return build_fold_indirect_ref_loc (input_location, str); + } + + if (kind == 1 + && TREE_CODE (str) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF + && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST + && array_ref_low_bound (TREE_OPERAND (str, 0)) + == TREE_OPERAND (TREE_OPERAND (str, 0), 1) + && TREE_INT_CST_LOW (len) > 1 + && TREE_INT_CST_LOW (len) + == (unsigned HOST_WIDE_INT) + TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) + { + tree ret = fold_convert (gfc_get_pchar_type (kind), str); + ret = build_fold_indirect_ref_loc (input_location, ret); + if (TREE_CODE (ret) == INTEGER_CST) + { + tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); + int i, length = TREE_STRING_LENGTH (string_cst); + const char *ptr = TREE_STRING_POINTER (string_cst); + + for (i = 1; i < length; i++) + if (ptr[i] != ' ') + return NULL_TREE; + + return ret; + } } return NULL_TREE; @@ -1446,7 +1475,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) { if ((*expr)->ref == NULL) { - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), gfc_get_symbol_decl @@ -1456,7 +1485,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) else { gfc_conv_variable (se, *expr); - se->expr = string_to_single_character + se->expr = gfc_string_to_single_character (build_int_cst (integer_type_node, 1), gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), se->expr), @@ -1466,47 +1495,91 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) } } +/* Helper function for gfc_build_compare_string. Return LEN_TRIM value + if STR is a string literal, otherwise return -1. */ + +static int +gfc_optimize_len_trim (tree len, tree str, int kind) +{ + if (kind == 1 + && TREE_CODE (str) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF + && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST + && array_ref_low_bound (TREE_OPERAND (str, 0)) + == TREE_OPERAND (TREE_OPERAND (str, 0), 1) + && TREE_INT_CST_LOW (len) >= 1 + && TREE_INT_CST_LOW (len) + == (unsigned HOST_WIDE_INT) + TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) + { + tree folded = fold_convert (gfc_get_pchar_type (kind), str); + folded = build_fold_indirect_ref_loc (input_location, folded); + if (TREE_CODE (folded) == INTEGER_CST) + { + tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); + int length = TREE_STRING_LENGTH (string_cst); + const char *ptr = TREE_STRING_POINTER (string_cst); + + for (; length > 0; length--) + if (ptr[length - 1] != ' ') + break; + + return length; + } + } + return -1; +} /* Compare two strings. If they are all single characters, the result is the subtraction of them. Otherwise, we build a library call. */ tree -gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind, + enum tree_code code) { tree sc1; tree sc2; - tree tmp; + tree fndecl; gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); - sc1 = string_to_single_character (len1, str1, kind); - sc2 = string_to_single_character (len2, str2, kind); + sc1 = gfc_string_to_single_character (len1, str1, kind); + sc2 = gfc_string_to_single_character (len2, str2, kind); if (sc1 != NULL_TREE && sc2 != NULL_TREE) { /* Deal with single character specially. */ sc1 = fold_convert (integer_type_node, sc1); sc2 = fold_convert (integer_type_node, sc2); - tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2); + return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2); } - else - { - /* Build a call for the comparison. */ - tree fndecl; - - if (kind == 1) - fndecl = gfor_fndecl_compare_string; - else if (kind == 4) - fndecl = gfor_fndecl_compare_string_char4; - else - gcc_unreachable (); - tmp = build_call_expr_loc (input_location, - fndecl, 4, len1, str1, len2, str2); + if ((code == EQ_EXPR || code == NE_EXPR) + && optimize + && INTEGER_CST_P (len1) && INTEGER_CST_P (len2)) + { + /* If one string is a string literal with LEN_TRIM longer + than the length of the second string, the strings + compare unequal. */ + int len = gfc_optimize_len_trim (len1, str1, kind); + if (len > 0 && compare_tree_int (len2, len) < 0) + return integer_one_node; + len = gfc_optimize_len_trim (len2, str2, kind); + if (len > 0 && compare_tree_int (len1, len) < 0) + return integer_one_node; } - return tmp; + /* Build a call for the comparison. */ + if (kind == 1) + fndecl = gfor_fndecl_compare_string; + else if (kind == 4) + fndecl = gfor_fndecl_compare_string_char4; + else + gcc_unreachable (); + + return build_call_expr_loc (input_location, fndecl, 4, + len1, str1, len2, str2); } @@ -2478,8 +2551,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, var, cmp->backend_decl, NULL_TREE); /* Remember the vtab corresponds to the derived type - not to the class declared type. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived, true); + not to the class declared type. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); gcc_assert (vtab); gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); @@ -2653,7 +2726,6 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 0; } - /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -2662,11 +2734,11 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, int gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_actual_arglist * arg, gfc_expr * expr, - tree append_args) + VEC(tree,gc) *append_args) { gfc_interface_mapping mapping; - tree arglist; - tree retargs; + VEC(tree,gc) *arglist; + VEC(tree,gc) *retargs; tree tmp; tree fntype; gfc_se parmse; @@ -2677,7 +2749,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree type; tree var; tree len; - tree stringargs; + VEC(tree,gc) *stringargs; tree result = NULL; gfc_formal_arglist *formal; int has_alternate_specifier = 0; @@ -2690,10 +2762,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t post; enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; gfc_component *comp = NULL; + int arglen; - arglist = NULL_TREE; - retargs = NULL_TREE; - stringargs = NULL_TREE; + arglist = NULL; + retargs = NULL; + stringargs = NULL; var = NULL_TREE; len = NULL_TREE; gfc_clear_ts (&ts); @@ -3136,9 +3209,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Character strings are passed as two parameters, a length and a pointer - except for Bind(c) which only passes the pointer. */ if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) - stringargs = gfc_chainon_list (stringargs, parmse.string_length); + VEC_safe_push (tree, gc, stringargs, parmse.string_length); - arglist = gfc_chainon_list (arglist, parmse.expr); + VEC_safe_push (tree, gc, arglist, parmse.expr); } gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); @@ -3160,7 +3233,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, For dummies, we have to look through the formal argument list for this function and use the character length found there.*/ if (!sym->attr.dummy) - cl.backend_decl = TREE_VALUE (stringargs); + cl.backend_decl = VEC_index (tree, stringargs, 0); else { formal = sym->ns->proc_name->formal; @@ -3213,7 +3286,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, result = build_fold_indirect_ref_loc (input_location, se->expr); - retargs = gfc_chainon_list (retargs, se->expr); + VEC_safe_push (tree, gc, retargs, se->expr); } else if (comp && comp->attr.dimension) { @@ -3237,7 +3310,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Pass the temporary as the first argument. */ result = info->descriptor; tmp = gfc_build_addr_expr (NULL_TREE, result); - retargs = gfc_chainon_list (retargs, tmp); + VEC_safe_push (tree, gc, retargs, tmp); } else if (!comp && sym->result->attr.dimension) { @@ -3261,7 +3334,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Pass the temporary as the first argument. */ result = info->descriptor; tmp = gfc_build_addr_expr (NULL_TREE, result); - retargs = gfc_chainon_list (retargs, tmp); + VEC_safe_push (tree, gc, retargs, tmp); } else if (ts.type == BT_CHARACTER) { @@ -3288,7 +3361,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else var = gfc_conv_string_tmp (se, type, len); - retargs = gfc_chainon_list (retargs, var); + VEC_safe_push (tree, gc, retargs, var); } else { @@ -3296,25 +3369,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, type = gfc_get_complex_type (ts.kind); var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx")); - retargs = gfc_chainon_list (retargs, var); + VEC_safe_push (tree, gc, retargs, var); } /* Add the string length to the argument list. */ if (ts.type == BT_CHARACTER) - retargs = gfc_chainon_list (retargs, len); + VEC_safe_push (tree, gc, retargs, len); } gfc_free_interface_mapping (&mapping); + /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */ + arglen = (VEC_length (tree, arglist) + + VEC_length (tree, stringargs) + VEC_length (tree, append_args)); + VEC_reserve_exact (tree, gc, retargs, arglen); + /* Add the return arguments. */ - arglist = chainon (retargs, arglist); + VEC_splice (tree, retargs, arglist); /* Add the hidden string length parameters to the arguments. */ - arglist = chainon (arglist, stringargs); + VEC_splice (tree, retargs, stringargs); /* We may want to append extra arguments here. This is used e.g. for calls to libgfortran_matmul_??, which need extra information. */ - if (append_args != NULL_TREE) - arglist = chainon (arglist, append_args); + if (!VEC_empty (tree, append_args)) + VEC_splice (tree, retargs, append_args); + arglist = retargs; /* Generate the actual call. */ conv_function_val (se, sym, expr); @@ -3338,7 +3417,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } fntype = TREE_TYPE (TREE_TYPE (se->expr)); - se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist); + se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist); /* If we have a pointer function, but we don't want a pointer, e.g. something like @@ -3539,7 +3618,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (slength != NULL_TREE) { slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block)); - ssc = string_to_single_character (slen, src, skind); + ssc = gfc_string_to_single_character (slen, src, skind); } else { @@ -3550,7 +3629,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, if (dlength != NULL_TREE) { dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block)); - dsc = string_to_single_character (slen, dest, dkind); + dsc = gfc_string_to_single_character (dlen, dest, dkind); } else { @@ -3558,12 +3637,6 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, dsc = dest; } - if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src))) - ssc = string_to_single_character (slen, src, skind); - if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest))) - dsc = string_to_single_character (dlen, dest, dkind); - - /* Assign directly if the types are compatible. */ if (dsc != NULL_TREE && ssc != NULL_TREE && TREE_TYPE (dsc) == TREE_TYPE (ssc)) @@ -3786,8 +3859,7 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) if (!sym) sym = expr->symtree->n.sym; - gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, - NULL_TREE); + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL); } @@ -4973,6 +5045,11 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) if (!expr2->value.function.esym->attr.contained) return false; + /* A temporary is not needed if the lhs has never been host + associated and the procedure is contained. */ + else if (!sym->attr.host_assoc) + 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 @@ -5226,6 +5303,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, bool l_is_temp; bool scalar_to_array; tree string_length; + int n; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -5271,6 +5349,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Calculate the bounds of the scalarization. */ gfc_conv_ss_startstride (&loop); + /* Enable loop reversal. */ + for (n = 0; n < loop.dimen; n++) + loop.reverse[n] = GFC_REVERSE_NOT_SET; /* Resolve any data dependencies in the statement. */ gfc_conv_resolve_dependencies (&loop, lss, rss); /* Setup the scalarizing loops. */ @@ -5631,7 +5712,7 @@ gfc_trans_class_assign (gfc_code *code) { gfc_symbol *vtab; gfc_symtree *st; - vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true); + vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived); gcc_assert (vtab); gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab); rhs = gfc_get_expr (); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 06fd538d775..c277e8e6376 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -28,7 +28,8 @@ along with GCC; see the file COPYING3. If not see #include "tm.h" /* For UNITS_PER_WORD. */ #include "tree.h" #include "ggc.h" -#include "toplev.h" /* For rest_of_decl_compilation/internal_error. */ +#include "diagnostic-core.h" /* For internal_error. */ +#include "toplev.h" /* For rest_of_decl_compilation. */ #include "flags.h" #include "gfortran.h" #include "arith.h" @@ -1570,7 +1571,7 @@ static void gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) { gfc_symbol *sym; - tree append_args; + VEC(tree,gc) *append_args; gcc_assert (!se->ss || se->ss->expr == expr); @@ -1583,7 +1584,7 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) /* Calls to libgfortran_matmul need to be appended special arguments, to be able to call the BLAS ?gemm functions if required and possible. */ - append_args = NULL_TREE; + append_args = NULL; if (expr->value.function.isym->id == GFC_ISYM_MATMUL && sym->ts.type != BT_LOGICAL) { @@ -1611,19 +1612,19 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) gemm_fndecl = gfor_fndecl_zgemm; } - append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1)); - append_args = gfc_chainon_list - (append_args, build_int_cst - (cint, gfc_option.blas_matmul_limit)); - append_args = gfc_chainon_list (append_args, - gfc_build_addr_expr (NULL_TREE, - gemm_fndecl)); + append_args = VEC_alloc (tree, gc, 3); + VEC_quick_push (tree, append_args, build_int_cst (cint, 1)); + VEC_quick_push (tree, append_args, + build_int_cst (cint, gfc_option.blas_matmul_limit)); + VEC_quick_push (tree, append_args, + gfc_build_addr_expr (NULL_TREE, gemm_fndecl)); } else { - append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0)); - append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0)); - append_args = gfc_chainon_list (append_args, null_pointer_node); + append_args = VEC_alloc (tree, gc, 3); + VEC_quick_push (tree, append_args, build_int_cst (cint, 0)); + VEC_quick_push (tree, append_args, build_int_cst (cint, 0)); + VEC_quick_push (tree, append_args, null_pointer_node); } } @@ -3285,7 +3286,7 @@ conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, unsigned cur_pos; gfc_actual_arglist* arg; gfc_symbol* sym; - tree append_args; + VEC(tree,gc) *append_args; /* Find the two arguments given as position. */ cur_pos = 0; @@ -3309,13 +3310,14 @@ conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, /* If we do have type CHARACTER and the optional argument is really absent, append a dummy 0 as string length. */ - append_args = NULL_TREE; + append_args = NULL; if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr) { tree dummy; dummy = build_int_cst (gfc_charlen_type_node, 0); - append_args = gfc_chainon_list (append_args, dummy); + append_args = VEC_alloc (tree, gc, 1); + VEC_quick_push (tree, append_args, dummy); } /* Build the call itself. */ @@ -3883,6 +3885,9 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) if (ss == gfc_ss_terminator) { + if (arg->ts.type == BT_CLASS) + gfc_add_component_ref (arg, "$data"); + gfc_conv_expr_reference (&argse, arg); type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, @@ -3932,6 +3937,56 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) } +static void +gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *arg; + gfc_ss *ss; + gfc_se argse,eight; + tree type, result_type, tmp; + + arg = expr->value.function.actual->expr; + gfc_init_se (&eight, NULL); + gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8)); + + gfc_init_se (&argse, NULL); + ss = gfc_walk_expr (arg); + result_type = gfc_get_int_type (expr->ts.kind); + + if (ss == gfc_ss_terminator) + { + if (arg->ts.type == BT_CLASS) + { + gfc_add_component_ref (arg, "$vptr"); + gfc_add_component_ref (arg, "$size"); + gfc_conv_expr (&argse, arg); + tmp = fold_convert (result_type, argse.expr); + goto done; + } + + gfc_conv_expr_reference (&argse, arg); + type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); + } + else + { + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg, ss); + type = gfc_get_element_type (TREE_TYPE (argse.expr)); + } + + /* Obtain the argument's word length. */ + if (arg->ts.type == BT_CHARACTER) + tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); + else + tmp = fold_convert (result_type, size_in_bytes (type)); + +done: + se->expr = fold_build2 (MULT_EXPR, result_type, tmp, eight.expr); + gfc_add_block_to_block (&se->pre, &argse.pre); +} + + /* Intrinsic string comparison functions. */ static void @@ -3943,7 +3998,8 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op) se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3], - expr->value.function.actual->expr->ts.kind); + expr->value.function.actual->expr->ts.kind, + op); se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); } @@ -4566,10 +4622,10 @@ static void gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) { gfc_actual_arglist *actual; - tree args, type; + tree type; gfc_se argse; + VEC(tree,gc) *args = NULL; - args = NULL_TREE; for (actual = expr->value.function.actual; actual; actual = actual->next) { gfc_init_se (&argse, se); @@ -4594,13 +4650,13 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - args = gfc_chainon_list (args, argse.expr); + VEC_safe_push (tree, gc, args, argse.expr); } /* Convert it to the required type. */ type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_function_call_expr (input_location, - gfor_fndecl_sr_kind, args); + se->expr = build_call_expr_loc_vec (input_location, + gfor_fndecl_sr_kind, args); se->expr = fold_convert (type, se->expr); } @@ -5268,9 +5324,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_SIZEOF: + case GFC_ISYM_C_SIZEOF: gfc_conv_intrinsic_sizeof (se, expr); break; + case GFC_ISYM_STORAGE_SIZE: + gfc_conv_intrinsic_storage_size (se, expr); + break; + case GFC_ISYM_SPACING: gfc_conv_intrinsic_spacing (se, expr); break; diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 1608a5e6598..a806d423417 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -25,7 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "tree.h" #include "ggc.h" -#include "toplev.h" /* For internal_error. */ +#include "diagnostic-core.h" /* For internal_error. */ #include "gfortran.h" #include "trans.h" #include "trans-stmt.h" @@ -156,6 +156,7 @@ gfc_build_st_parameter (enum ioparam_type ptype, tree *types) char name[64]; size_t len; tree t = make_node (RECORD_TYPE); + tree *chain = NULL; len = strlen (st_parameter[ptype].name); gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_")); @@ -175,33 +176,31 @@ gfc_build_st_parameter (enum ioparam_type ptype, tree *types) case IOPARM_type_parray: case IOPARM_type_pchar: case IOPARM_type_pad: - p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, - get_identifier (p->name), - types[p->type]); + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + types[p->type], &chain); break; case IOPARM_type_char1: - p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, - get_identifier (p->name), - pchar_type_node); + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + pchar_type_node, &chain); /* FALLTHROUGH */ case IOPARM_type_char2: len = strlen (p->name); gcc_assert (len <= sizeof (name) - sizeof ("_len")); memcpy (name, p->name, len); memcpy (name + len, "_len", sizeof ("_len")); - p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, - get_identifier (name), - gfc_charlen_type_node); + p->field_len = gfc_add_field_to_struct (t, get_identifier (name), + gfc_charlen_type_node, + &chain); if (p->type == IOPARM_type_char2) - p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, - get_identifier (p->name), - pchar_type_node); + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + pchar_type_node, &chain); break; case IOPARM_type_common: p->field - = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, + = gfc_add_field_to_struct (t, get_identifier (p->name), - st_parameter[IOPARM_ptype_common].type); + st_parameter[IOPARM_ptype_common].type, + &chain); break; case IOPARM_type_num: gcc_unreachable (); @@ -304,132 +303,117 @@ gfc_build_io_library_fndecls (void) for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) gfc_build_st_parameter ((enum ioparam_type) ptype, types); - /* Define the transfer functions. */ + /* Define the transfer functions. + TODO: Split them between READ and WRITE to allow further + optimizations, e.g. by using aliases? */ dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type); - iocall[IOCALL_X_INTEGER] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_integer")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_LOGICAL] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_logical")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_CHARACTER] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_character")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_CHARACTER_WIDE] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_character_wide")), - void_type_node, 4, dt_parm_type, - pvoid_type_node, gfc_charlen_type_node, - gfc_int4_type_node); - - iocall[IOCALL_X_REAL] = - gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_COMPLEX] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_complex")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_ARRAY] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_array")), - void_type_node, 4, dt_parm_type, - pvoid_type_node, integer_type_node, - gfc_charlen_type_node); + iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_integer")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_logical")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character_wide")), ".wW", + void_type_node, 4, dt_parm_type, pvoid_type_node, + gfc_charlen_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex")), ".wW", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_array")), ".wW", + void_type_node, 4, dt_parm_type, pvoid_type_node, + integer_type_node, gfc_charlen_type_node); /* Library entry points */ - iocall[IOCALL_READ] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_read")), - void_type_node, 1, dt_parm_type); + iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_read")), ".w", + void_type_node, 1, dt_parm_type); - iocall[IOCALL_WRITE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_write")), - void_type_node, 1, dt_parm_type); + iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_write")), ".w", + void_type_node, 1, dt_parm_type); parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type); - iocall[IOCALL_OPEN] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_open")), - void_type_node, 1, parm_type); - + iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_open")), ".w", + void_type_node, 1, parm_type); parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type); - iocall[IOCALL_CLOSE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_close")), - void_type_node, 1, parm_type); + iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_close")), ".w", + void_type_node, 1, parm_type); parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type); - iocall[IOCALL_INQUIRE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")), - gfc_int4_type_node, 1, parm_type); + iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_inquire")), ".w", + gfc_int4_type_node, 1, parm_type); - iocall[IOCALL_IOLENGTH] = - gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")), - void_type_node, 1, dt_parm_type); + iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec( + get_identifier (PREFIX("st_iolength")), ".w", + void_type_node, 1, dt_parm_type); + /* TODO: Change when asynchronous I/O is implemented. */ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); - iocall[IOCALL_WAIT] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")), - gfc_int4_type_node, 1, parm_type); + iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_wait")), ".X", + gfc_int4_type_node, 1, parm_type); parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); - iocall[IOCALL_REWIND] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")), - gfc_int4_type_node, 1, parm_type); + iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_rewind")), ".w", + gfc_int4_type_node, 1, parm_type); - iocall[IOCALL_BACKSPACE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")), - gfc_int4_type_node, 1, parm_type); + iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_backspace")), ".w", + gfc_int4_type_node, 1, parm_type); - iocall[IOCALL_ENDFILE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")), - gfc_int4_type_node, 1, parm_type); + iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_endfile")), ".w", + gfc_int4_type_node, 1, parm_type); - iocall[IOCALL_FLUSH] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")), - gfc_int4_type_node, 1, parm_type); + iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_flush")), ".w", + gfc_int4_type_node, 1, parm_type); /* Library helpers */ - iocall[IOCALL_READ_DONE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")), - gfc_int4_type_node, 1, dt_parm_type); - - iocall[IOCALL_WRITE_DONE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")), - gfc_int4_type_node, 1, dt_parm_type); + iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_read_done")), ".w", + gfc_int4_type_node, 1, dt_parm_type); - iocall[IOCALL_IOLENGTH_DONE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")), - gfc_int4_type_node, 1, dt_parm_type); + iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_write_done")), ".w", + gfc_int4_type_node, 1, dt_parm_type); + iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_iolength_done")), ".w", + gfc_int4_type_node, 1, dt_parm_type); - iocall[IOCALL_SET_NML_VAL] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")), - void_type_node, 6, dt_parm_type, - pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_charlen_type_node, - gfc_int4_type_node); + iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_var")), ".w.R", + void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node, + gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node); - iocall[IOCALL_SET_NML_VAL_DIM] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")), - void_type_node, 5, dt_parm_type, - gfc_int4_type_node, gfc_array_index_type, - gfc_array_index_type, gfc_array_index_type); + iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_var_dim")), ".w", + void_type_node, 5, dt_parm_type, gfc_int4_type_node, + gfc_array_index_type, gfc_array_index_type, gfc_array_index_type); } @@ -1670,7 +1654,8 @@ build_dt (tree function, gfc_code * code) { mask |= set_internal_unit (&block, &post_iu_block, var, dt->io_unit); - set_parameter_const (&block, var, IOPARM_common_unit, 0); + set_parameter_const (&block, var, IOPARM_common_unit, + dt->io_unit->ts.kind == 1 ? 0 : -1); } } else diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 7a7d33088d7..4a7f70e7b6e 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -25,7 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "tree.h" #include "gimple.h" /* For create_tmp_var_raw. */ -#include "toplev.h" /* For internal_error. */ +#include "diagnostic-core.h" /* For internal_error. */ #include "gfortran.h" #include "trans.h" #include "trans-stmt.h" diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6fa84b91694..019555ae7f9 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -34,6 +34,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-const.h" #include "arith.h" #include "dependency.h" +#include "ggc.h" typedef struct iter_info { @@ -373,7 +374,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, /* Translate the call. */ has_alternate_specifier = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual, - code->expr1, NULL_TREE); + code->expr1, NULL); /* A subroutine without side-effect, by definition, does nothing! */ TREE_SIDE_EFFECTS (se.expr) = 1; @@ -457,8 +458,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, /* Add the subroutine call to the block. */ gfc_conv_procedure_call (&loopse, code->resolved_sym, - code->ext.actual, code->expr1, - NULL_TREE); + code->ext.actual, code->expr1, NULL); if (mask && count1) { @@ -491,7 +491,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, /* Translate the RETURN statement. */ tree -gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) +gfc_trans_return (gfc_code * code) { if (code->expr1) { @@ -500,16 +500,16 @@ gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) tree result; /* If code->expr is not NULL, this return statement must appear - in a subroutine and current_fake_result_decl has already + in a subroutine and current_fake_result_decl has already been generated. */ result = gfc_get_fake_result_decl (NULL, 0); if (!result) - { - gfc_warning ("An alternate return at %L without a * dummy argument", - &code->expr1->where); - return build1_v (GOTO_EXPR, gfc_get_return_label ()); - } + { + gfc_warning ("An alternate return at %L without a * dummy argument", + &code->expr1->where); + return gfc_generate_return (); + } /* Start a new block for this statement. */ gfc_init_se (&se, NULL); @@ -517,17 +517,20 @@ gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) gfc_conv_expr (&se, code->expr1); + /* Note that the actually returned expression is a simple value and + does not depend on any pointers or such; thus we can clean-up with + se.post before returning. */ tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (result), result, fold_convert (TREE_TYPE (result), se.expr)); gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); - tmp = build1_v (GOTO_EXPR, gfc_get_return_label ()); + tmp = gfc_generate_return (); gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); } - else - return build1_v (GOTO_EXPR, gfc_get_return_label ()); + + return gfc_generate_return (); } @@ -847,8 +850,7 @@ gfc_trans_block_construct (gfc_code* code) { gfc_namespace* ns; gfc_symbol* sym; - stmtblock_t body; - tree tmp; + gfc_wrapped_block body; ns = code->ext.block.ns; gcc_assert (ns); @@ -858,14 +860,12 @@ gfc_trans_block_construct (gfc_code* code) gcc_assert (!sym->tlink); sym->tlink = sym; - gfc_start_block (&body); gfc_process_block_locals (ns); - tmp = gfc_trans_code (ns->code); - tmp = gfc_trans_deferred_vars (sym, tmp); + gfc_start_wrapped_block (&body, gfc_trans_code (ns->code)); + gfc_trans_deferred_vars (sym, &body); - gfc_add_expr_to_block (&body, tmp); - return gfc_finish_block (&body); + return gfc_finish_wrapped_block (&body); } @@ -1595,6 +1595,10 @@ gfc_trans_logical_select (gfc_code * code) } +/* The jump table types are stored in static variables to avoid + constructing them from scratch every single time. */ +static GTY(()) tree select_struct[2]; + /* Translate the SELECT CASE construct for CHARACTER case expressions. Instead of generating compares and jumps, it is far simpler to generate a data structure describing the cases in order and call a @@ -1611,18 +1615,171 @@ gfc_trans_character_select (gfc_code *code) stmtblock_t block, body; gfc_case *cp, *d; gfc_code *c; - gfc_se se; + gfc_se se, expr1se; int n, k; VEC(constructor_elt,gc) *inits = NULL; + tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); + /* The jump table types are stored in static variables to avoid constructing them from scratch every single time. */ - static tree select_struct[2]; static tree ss_string1[2], ss_string1_len[2]; static tree ss_string2[2], ss_string2_len[2]; static tree ss_target[2]; - tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); + cp = code->block->ext.case_list; + while (cp->left != NULL) + cp = cp->left; + + /* Generate the body */ + gfc_start_block (&block); + gfc_init_se (&expr1se, NULL); + gfc_conv_expr_reference (&expr1se, code->expr1); + + gfc_add_block_to_block (&block, &expr1se.pre); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + /* Attempt to optimize length 1 selects. */ + if (expr1se.string_length == integer_one_node) + { + for (d = cp; d; d = d->right) + { + int i; + if (d->low) + { + gcc_assert (d->low->expr_type == EXPR_CONSTANT + && d->low->ts.type == BT_CHARACTER); + if (d->low->value.character.length > 1) + { + for (i = 1; i < d->low->value.character.length; i++) + if (d->low->value.character.string[i] != ' ') + break; + if (i != d->low->value.character.length) + { + if (optimize && d->high && i == 1) + { + gcc_assert (d->high->expr_type == EXPR_CONSTANT + && d->high->ts.type == BT_CHARACTER); + if (d->high->value.character.length > 1 + && (d->low->value.character.string[0] + == d->high->value.character.string[0]) + && d->high->value.character.string[1] != ' ' + && ((d->low->value.character.string[1] < ' ') + == (d->high->value.character.string[1] + < ' '))) + continue; + } + break; + } + } + } + if (d->high) + { + gcc_assert (d->high->expr_type == EXPR_CONSTANT + && d->high->ts.type == BT_CHARACTER); + if (d->high->value.character.length > 1) + { + for (i = 1; i < d->high->value.character.length; i++) + if (d->high->value.character.string[i] != ' ') + break; + if (i != d->high->value.character.length) + break; + } + } + } + if (d == NULL) + { + tree ctype = gfc_get_char_type (code->expr1->ts.kind); + + for (c = code->block; c; c = c->block) + { + for (cp = c->ext.case_list; cp; cp = cp->next) + { + tree low, high; + tree label; + gfc_char_t r; + + /* Assume it's the default case. */ + low = high = NULL_TREE; + + if (cp->low) + { + /* CASE ('ab') or CASE ('ab':'az') will never match + any length 1 character. */ + if (cp->low->value.character.length > 1 + && cp->low->value.character.string[1] != ' ') + continue; + + if (cp->low->value.character.length > 0) + r = cp->low->value.character.string[0]; + else + r = ' '; + low = build_int_cst (ctype, r); + + /* If there's only a lower bound, set the high bound + to the maximum value of the case expression. */ + if (!cp->high) + high = TYPE_MAX_VALUE (ctype); + } + + if (cp->high) + { + if (!cp->low + || (cp->low->value.character.string[0] + != cp->high->value.character.string[0])) + { + if (cp->high->value.character.length > 0) + r = cp->high->value.character.string[0]; + else + r = ' '; + high = build_int_cst (ctype, r); + } + + /* Unbounded case. */ + if (!cp->low) + low = TYPE_MIN_VALUE (ctype); + } + + /* Build a label. */ + label = gfc_build_label_decl (NULL_TREE); + + /* Add this case label. + Add parameter 'label', make it match GCC backend. */ + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + low, high, label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_string_to_single_character (expr1se.string_length, + expr1se.expr, + code->expr1->ts.kind); + case_num = gfc_create_var (ctype, "case_num"); + gfc_add_modify (&block, case_num, tmp); + + gfc_add_block_to_block (&block, &expr1se.post); + + tmp = gfc_finish_block (&body); + tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); + } + } if (code->expr1->ts.kind == 1) k = 0; @@ -1633,6 +1790,7 @@ gfc_trans_character_select (gfc_code *code) if (select_struct[k] == NULL) { + tree *chain = NULL; select_struct[k] = make_node (RECORD_TYPE); if (code->expr1->ts.kind == 1) @@ -1643,10 +1801,11 @@ gfc_trans_character_select (gfc_code *code) gcc_unreachable (); #undef ADD_FIELD -#define ADD_FIELD(NAME, TYPE) \ - ss_##NAME[k] = gfc_add_field_to_struct \ - (&(TYPE_FIELDS (select_struct[k])), select_struct[k], \ - get_identifier (stringize(NAME)), TYPE) +#define ADD_FIELD(NAME, TYPE) \ + ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \ + get_identifier (stringize(NAME)), \ + TYPE, \ + &chain) ADD_FIELD (string1, pchartype); ADD_FIELD (string1_len, gfc_charlen_type_node); @@ -1660,28 +1819,19 @@ gfc_trans_character_select (gfc_code *code) gfc_finish_type (select_struct[k]); } - cp = code->block->ext.case_list; - while (cp->left != NULL) - cp = cp->left; - n = 0; for (d = cp; d; d = d->right) d->n = n++; - end_label = gfc_build_label_decl (NULL_TREE); - - /* Generate the body */ - gfc_start_block (&block); - gfc_init_block (&body); - for (c = code->block; c; c = c->block) { for (d = c->ext.case_list; d; d = d->next) { label = gfc_build_label_decl (NULL_TREE); tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, - build_int_cst (NULL_TREE, d->n), - build_int_cst (NULL_TREE, d->n), label); + (d->low == NULL && d->high == NULL) + ? NULL : build_int_cst (NULL_TREE, d->n), + NULL, label); gfc_add_expr_to_block (&body, tmp); } @@ -1693,7 +1843,7 @@ gfc_trans_character_select (gfc_code *code) } /* Generate the structure describing the branches */ - for(d = cp; d; d = d->right) + for (d = cp; d; d = d->right) { VEC(constructor_elt,gc) *node = NULL; @@ -1750,11 +1900,6 @@ gfc_trans_character_select (gfc_code *code) /* Build the library call */ init = gfc_build_addr_expr (pvoid_type_node, init); - gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, code->expr1); - - gfc_add_block_to_block (&block, &se.pre); - if (code->expr1->ts.kind == 1) fndecl = gfor_fndecl_select_string; else if (code->expr1->ts.kind == 4) @@ -1764,11 +1909,11 @@ gfc_trans_character_select (gfc_code *code) tmp = build_call_expr_loc (input_location, fndecl, 4, init, build_int_cst (NULL_TREE, n), - se.expr, se.string_length); + expr1se.expr, expr1se.string_length); case_num = gfc_create_var (integer_type_node, "case_num"); gfc_add_modify (&block, case_num, tmp); - gfc_add_block_to_block (&block, &se.post); + gfc_add_block_to_block (&block, &expr1se.post); tmp = gfc_finish_block (&body); tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE); @@ -4294,7 +4439,7 @@ gfc_trans_allocate (gfc_code * code) if (ts->type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (ts->u.derived, true); + vtab = gfc_find_derived_vtab (ts->u.derived); gcc_assert (vtab); gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab); gfc_init_se (&lse, NULL); @@ -4492,3 +4637,4 @@ gfc_trans_deallocate (gfc_code *code) return gfc_finish_block (&block); } +#include "gt-fortran-trans-stmt.h" diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 2f5b759886d..34efa9ad82c 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -30,7 +30,8 @@ along with GCC; see the file COPYING3. If not see #include "langhooks.h" /* For iso-c-bindings.def. */ #include "target.h" #include "ggc.h" -#include "toplev.h" /* For rest_of_decl_compilation/fatal_error. */ +#include "diagnostic-core.h" /* For fatal_error. */ +#include "toplev.h" /* For rest_of_decl_compilation. */ #include "gfortran.h" #include "trans.h" #include "trans-types.h" @@ -86,6 +87,7 @@ gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1]; static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1]; static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1]; +static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **); /* The integer kind to use for array indices. This will be set to the proper value based on target information from the backend. */ @@ -1232,8 +1234,7 @@ static tree gfc_get_desc_dim_type (void) { tree type; - tree decl; - tree fieldlist; + tree decl, *chain = NULL; if (gfc_desc_dim_type) return gfc_desc_dim_type; @@ -1245,30 +1246,22 @@ gfc_get_desc_dim_type (void) TYPE_PACKED (type) = 1; /* Consists of the stride, lbound and ubound members. */ - decl = build_decl (input_location, - FIELD_DECL, - get_identifier ("stride"), gfc_array_index_type); - DECL_CONTEXT (decl) = type; + decl = gfc_add_field_to_struct_1 (type, + get_identifier ("stride"), + gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; - fieldlist = decl; - decl = build_decl (input_location, - FIELD_DECL, - get_identifier ("lbound"), gfc_array_index_type); - DECL_CONTEXT (decl) = type; + decl = gfc_add_field_to_struct_1 (type, + get_identifier ("lbound"), + gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; - fieldlist = chainon (fieldlist, decl); - decl = build_decl (input_location, - FIELD_DECL, - get_identifier ("ubound"), gfc_array_index_type); - DECL_CONTEXT (decl) = type; + decl = gfc_add_field_to_struct_1 (type, + get_identifier ("ubound"), + gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; - fieldlist = chainon (fieldlist, decl); /* Finish off the type. */ - TYPE_FIELDS (type) = fieldlist; - gfc_finish_type (type); TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; @@ -1540,7 +1533,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, static tree gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) { - tree fat_type, fieldlist, decl, arraytype; + tree fat_type, decl, arraytype, *chain = NULL; char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; int idx = 2 * (codimen + dimen - 1) + restricted; @@ -1553,30 +1546,26 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen); TYPE_NAME (fat_type) = get_identifier (name); + TYPE_NAMELESS (fat_type) = 1; /* Add the data member as the first element of the descriptor. */ - decl = build_decl (input_location, - FIELD_DECL, get_identifier ("data"), - restricted ? prvoid_type_node : ptr_type_node); - - DECL_CONTEXT (decl) = fat_type; - fieldlist = decl; + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("data"), + (restricted + ? prvoid_type_node + : ptr_type_node), &chain); /* Add the base component. */ - decl = build_decl (input_location, - FIELD_DECL, get_identifier ("offset"), - gfc_array_index_type); - DECL_CONTEXT (decl) = fat_type; + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("offset"), + gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; - fieldlist = chainon (fieldlist, decl); /* Add the dtype component. */ - decl = build_decl (input_location, - FIELD_DECL, get_identifier ("dtype"), - gfc_array_index_type); - DECL_CONTEXT (decl) = fat_type; + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("dtype"), + gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; - fieldlist = chainon (fieldlist, decl); /* Build the array type for the stride and bound components. */ arraytype = @@ -1585,15 +1574,12 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) gfc_index_zero_node, gfc_rank_cst[codimen + dimen - 1])); - decl = build_decl (input_location, - FIELD_DECL, get_identifier ("dim"), arraytype); - DECL_CONTEXT (decl) = fat_type; + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("dim"), + arraytype, &chain); TREE_NO_WARNING (decl) = 1; - fieldlist = chainon (fieldlist, decl); /* Finish off the type. */ - TYPE_FIELDS (fat_type) = fieldlist; - gfc_finish_type (fat_type); TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1; @@ -1631,6 +1617,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen, GFC_MAX_SYMBOL_LEN, type_name); TYPE_NAME (fat_type) = get_identifier (name); + TYPE_NAMELESS (fat_type) = 1; GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; TYPE_LANG_SPECIFIC (fat_type) @@ -1853,26 +1840,41 @@ gfc_finish_type (tree type) } /* Add a field of given NAME and TYPE to the context of a UNION_TYPE - or RECORD_TYPE pointed to by STYPE. The new field is chained - to the fieldlist pointed to by FIELDLIST. + or RECORD_TYPE pointed to by CONTEXT. The new field is chained + to the end of the field list pointed to by *CHAIN. Returns a pointer to the new field. */ -tree -gfc_add_field_to_struct (tree *fieldlist, tree context, - tree name, tree type) +static tree +gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain) { - tree decl; - - decl = build_decl (input_location, - FIELD_DECL, name, type); + tree decl = build_decl (input_location, FIELD_DECL, name, type); DECL_CONTEXT (decl) = context; + DECL_CHAIN (decl) = NULL_TREE; + if (TYPE_FIELDS (context) == NULL_TREE) + TYPE_FIELDS (context) = decl; + if (chain != NULL) + { + if (*chain != NULL) + **chain = decl; + *chain = &DECL_CHAIN (decl); + } + + return decl; +} + +/* Like `gfc_add_field_to_struct_1', but adds alignment + information. */ + +tree +gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain) +{ + tree decl = gfc_add_field_to_struct_1 (context, name, type, chain); + DECL_INITIAL (decl) = 0; DECL_ALIGN (decl) = 0; DECL_USER_ALIGN (decl) = 0; - TREE_CHAIN (decl) = NULL_TREE; - *fieldlist = chainon (*fieldlist, decl); return decl; } @@ -1948,8 +1950,9 @@ gfc_get_ppc_type (gfc_component* c) tree gfc_get_derived_type (gfc_symbol * derived) { - tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL; + tree typenode = NULL, field = NULL, field_type = NULL; tree canonical = NULL_TREE; + tree *chain = NULL; bool got_canonical = false; gfc_component *c; gfc_dt_list *dt; @@ -1969,14 +1972,6 @@ gfc_get_derived_type (gfc_symbol * derived) else derived->backend_decl = pfunc_type_node; - /* Create a backend_decl for the __c_ptr_c_address field. */ - derived->components->backend_decl = - gfc_add_field_to_struct (&(derived->backend_decl->type.values), - derived->backend_decl, - get_identifier (derived->components->name), - gfc_typenode_for_spec ( - &(derived->components->ts))); - derived->ts.kind = gfc_index_integer_kind; derived->ts.type = BT_INTEGER; /* Set the f90_type to BT_VOID as a way to recognize something of type @@ -2098,7 +2093,6 @@ gfc_get_derived_type (gfc_symbol * derived) /* Build the type member list. Install the newly created RECORD_TYPE node as DECL_CONTEXT of each FIELD_DECL. */ - fieldlist = NULL_TREE; for (c = derived->components; c; c = c->next) { if (c->attr.proc_pointer) @@ -2145,8 +2139,14 @@ gfc_get_derived_type (gfc_symbol * derived) && !c->attr.proc_pointer) field_type = build_pointer_type (field_type); - field = gfc_add_field_to_struct (&fieldlist, typenode, - get_identifier (c->name), field_type); + /* vtype fields can point to different types to the base type. */ + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.vtype) + field_type = build_pointer_type_for_mode (TREE_TYPE (field_type), + ptr_mode, true); + + field = gfc_add_field_to_struct (typenode, + get_identifier (c->name), + field_type, &chain); if (c->loc.lb) gfc_set_decl_location (field, &c->loc); else if (derived->declared_at.lb) @@ -2159,9 +2159,7 @@ gfc_get_derived_type (gfc_symbol * derived) c->backend_decl = field; } - /* Now we have the final fieldlist. Record it, then lay out the - derived type, including the fields. */ - TYPE_FIELDS (typenode) = fieldlist; + /* Now lay out the derived type, including the fields. */ if (canonical) TYPE_CANONICAL (typenode) = canonical; @@ -2224,8 +2222,7 @@ static tree gfc_get_mixed_entry_union (gfc_namespace *ns) { tree type; - tree decl; - tree fieldlist; + tree *chain = NULL; char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_entry_list *el, *el2; @@ -2238,7 +2235,6 @@ gfc_get_mixed_entry_union (gfc_namespace *ns) type = make_node (UNION_TYPE); TYPE_NAME (type) = get_identifier (name); - fieldlist = NULL; for (el = ns->entries; el; el = el->next) { @@ -2248,19 +2244,12 @@ gfc_get_mixed_entry_union (gfc_namespace *ns) break; if (el == el2) - { - decl = build_decl (input_location, - FIELD_DECL, - get_identifier (el->sym->result->name), - gfc_sym_type (el->sym->result)); - DECL_CONTEXT (decl) = type; - fieldlist = chainon (fieldlist, decl); - } + gfc_add_field_to_struct_1 (type, + get_identifier (el->sym->result->name), + gfc_sym_type (el->sym->result), &chain); } /* Finish off the type. */ - TYPE_FIELDS (type) = fieldlist; - gfc_finish_type (type); TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; return type; @@ -2552,16 +2541,16 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type)); data_off = byte_position (field); - field = TREE_CHAIN (field); - field = TREE_CHAIN (field); - field = TREE_CHAIN (field); + field = DECL_CHAIN (field); + field = DECL_CHAIN (field); + field = DECL_CHAIN (field); dim_off = byte_position (field); dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field))); field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field))); stride_suboff = byte_position (field); - field = TREE_CHAIN (field); + field = DECL_CHAIN (field); lower_suboff = byte_position (field); - field = TREE_CHAIN (field); + field = DECL_CHAIN (field); upper_suboff = byte_position (field); t = base_decl; diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 0b962114b96..7e79480c438 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -77,7 +77,7 @@ tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int, tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool); /* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE. */ -tree gfc_add_field_to_struct (tree *, tree, tree, tree); +tree gfc_add_field_to_struct (tree, tree, tree, tree **); /* Layout and output debugging info for a type. */ void gfc_finish_type (tree); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 43b69d5a2b0..003f6090c2f 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -25,7 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "gimple.h" /* For create_tmp_var_raw. */ #include "tree-iterator.h" -#include "toplev.h" /* For internal_error. */ +#include "diagnostic-core.h" /* For internal_error. */ #include "defaults.h" #include "flags.h" #include "gfortran.h" @@ -57,7 +57,7 @@ gfc_advance_chain (tree t, int n) for (; n > 0; n--) { gcc_assert (t != NULL_TREE); - t = TREE_CHAIN (t); + t = DECL_CHAIN (t); } return t; } @@ -218,8 +218,8 @@ gfc_merge_block_scope (stmtblock_t * block) /* Add them to the parent scope. */ while (decl != NULL_TREE) { - next = TREE_CHAIN (decl); - TREE_CHAIN (decl) = NULL_TREE; + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; pushdecl (decl); decl = next; @@ -977,31 +977,47 @@ gfc_call_realloc (stmtblock_t * block, tree mem, tree size) return res; } -/* Add a statement to a block. */ -void -gfc_add_expr_to_block (stmtblock_t * block, tree expr) -{ - gcc_assert (block); +/* Add an expression to another one, either at the front or the back. */ +static void +add_expr_to_chain (tree* chain, tree expr, bool front) +{ if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) return; - if (block->head) + if (*chain) { - if (TREE_CODE (block->head) != STATEMENT_LIST) + if (TREE_CODE (*chain) != STATEMENT_LIST) { tree tmp; - tmp = block->head; - block->head = NULL_TREE; - append_to_statement_list (tmp, &block->head); + tmp = *chain; + *chain = NULL_TREE; + append_to_statement_list (tmp, chain); } - append_to_statement_list (expr, &block->head); + + if (front) + { + tree_stmt_iterator i; + + i = tsi_start (*chain); + tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); + } + else + append_to_statement_list (expr, chain); } else - /* Don't bother creating a list if we only have a single statement. */ - block->head = expr; + *chain = expr; +} + +/* Add a statement to a block. */ + +void +gfc_add_expr_to_block (stmtblock_t * block, tree expr) +{ + gcc_assert (block); + add_expr_to_chain (&block->head, expr, false); } @@ -1393,3 +1409,55 @@ gfc_generate_module_code (gfc_namespace * ns) } } + +/* Initialize an init/cleanup block with existing code. */ + +void +gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) +{ + gcc_assert (block); + + block->init = NULL_TREE; + block->code = code; + block->cleanup = NULL_TREE; +} + + +/* Add a new pair of initializers/clean-up code. */ + +void +gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) +{ + gcc_assert (block); + + /* The new pair of init/cleanup should be "wrapped around" the existing + block of code, thus the initialization is added to the front and the + cleanup to the back. */ + add_expr_to_chain (&block->init, init, true); + add_expr_to_chain (&block->cleanup, cleanup, false); +} + + +/* Finish up a wrapped block by building a corresponding try-finally expr. */ + +tree +gfc_finish_wrapped_block (gfc_wrapped_block* block) +{ + tree result; + + gcc_assert (block); + + /* Build the final expression. For this, just add init and body together, + and put clean-up with that into a TRY_FINALLY_EXPR. */ + result = block->init; + add_expr_to_chain (&result, block->code, false); + if (block->cleanup) + result = build2 (TRY_FINALLY_EXPR, void_type_node, result, block->cleanup); + + /* Clear the block. */ + block->init = NULL_TREE; + block->code = NULL_TREE; + block->cleanup = NULL_TREE; + + return result; +} diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 02361fc8466..9872e83df9e 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -114,8 +114,8 @@ typedef struct gfc_ss_info tree stride[GFC_MAX_DIMENSIONS]; tree delta[GFC_MAX_DIMENSIONS]; - /* Translation from scalarizer dimensions to actual dimensions. - actual = dim[scalarizer] */ + /* Translation from loop dimensions to actual dimensions. + actual_dim = dim[loop_dim] */ int dim[GFC_MAX_DIMENSIONS]; } gfc_ss_info; @@ -240,6 +240,9 @@ typedef struct gfc_loopinfo /* Order in which the dimensions should be looped, innermost first. */ int order[GFC_MAX_DIMENSIONS]; + /* Enum to control loop reversal. */ + gfc_reverse reverse[GFC_MAX_DIMENSIONS]; + /* The number of dimensions for which a temporary is used. */ int temp_dim; @@ -258,6 +261,29 @@ typedef struct gfc_saved_var; +/* Store information about a block of code together with special + initialization and clean-up code. This can be used to incrementally add + init and cleanup, and in the end put everything together to a + try-finally expression. */ +typedef struct +{ + tree init; + tree cleanup; + tree code; +} +gfc_wrapped_block; + + +/* Initialize an init/cleanup block. */ +void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code); +/* Add a pair of init/cleanup code to the block. Each one might be a + NULL_TREE if not required. */ +void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup); +/* Finalize the block, that is, create a single expression encapsulating the + original code together with init and clean-up code. */ +tree gfc_finish_wrapped_block (gfc_wrapped_block* block); + + /* Advance the SS chain to the next term. */ void gfc_advance_se_ss_chain (gfc_se *); @@ -279,7 +305,7 @@ void gfc_make_safe_expr (gfc_se * se); void gfc_conv_string_parameter (gfc_se * se); /* Compare two strings. */ -tree gfc_build_compare_string (tree, tree, tree, tree, int); +tree gfc_build_compare_string (tree, tree, tree, tree, int, enum tree_code); /* Add an item to the end of TREE_LIST. */ tree gfc_chainon_list (tree, tree); @@ -299,6 +325,7 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); /* trans-expr.c */ void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr); +tree gfc_string_to_single_character (tree len, tree str, int kind); /* Find the decl containing the auxiliary variables for assigned variables. */ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); @@ -314,7 +341,7 @@ int gfc_is_intrinsic_libcall (gfc_expr *); /* Used to call ordinary functions/subroutines and procedure pointer components. */ int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *, - gfc_expr *, tree); + gfc_expr *, VEC(tree,gc) *); void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool); @@ -384,9 +411,6 @@ tree gfc_build_label_decl (tree); Do not use if the function has an explicit result variable. */ tree gfc_get_fake_result_decl (gfc_symbol *, int); -/* Get the return label for the current function. */ -tree gfc_get_return_label (void); - /* Add a decl to the binding level for the current function. */ void gfc_add_decl_to_function (tree); @@ -403,7 +427,7 @@ tree gfc_get_symbol_decl (gfc_symbol *); tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool); /* Assign a default initializer to a derived type. */ -tree gfc_init_default_dt (gfc_symbol *, tree, bool); +void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool); /* Substitute a temporary variable in place of the real one. */ void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *); @@ -432,6 +456,8 @@ void gfc_generate_function_code (gfc_namespace *); void gfc_generate_block_data (gfc_namespace *); /* Output a decl for a module variable. */ void gfc_generate_module_vars (gfc_namespace *); +/* Get the appropriate return statement for a procedure. */ +tree gfc_generate_return (void); struct GTY(()) module_htab_entry { const char *name; @@ -502,12 +528,14 @@ void gfc_trans_io_runtime_check (tree, tree, int, const char *, stmtblock_t *); void gfc_build_io_library_fndecls (void); /* Build a function decl for a library function. */ tree gfc_build_library_function_decl (tree, tree, int, ...); +tree gfc_build_library_function_decl_with_spec (tree name, const char *spec, + tree rettype, int nargs, ...); /* Process the local variable decls of a block construct. */ void gfc_process_block_locals (gfc_namespace*); /* Output initialization/clean-up code that was deferred. */ -tree gfc_trans_deferred_vars (gfc_symbol*, tree); +void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *); /* somewhere! */ tree pushdecl (tree); |